Hi all,
in another thread I promised to publish my code for an MS-Outlook clone using Excel.
I publish this because the code others published was so useful to me and I want to do somethig in return.
I am not a professional programmer, so please don't laugh at what I did. It works and for the most of it I even
understand how and why.
The reason for me to start doing something with VBA is the fact that my employer seriously reduced our email
boxes 3 months ago. We are told to store emails on the network as *.msg files (PST files not allowed), which
sucks. In Explorer you can only use file names to look for emails.
I desperately need to be able to use the "metadata" of the *.msg files as well (sender, receivers, etc.).
My employer is not going to help out with suitable software and we are not allowed to install software ourselves.
I decided to try to use Excel as an Outlook clone. That way I can profit from the built in sort and search
functions of Excel.
The Excel program is a suplement to a piece of VBA I made together with a colleague, that works within MS-Outlook.
With that program we are able to put a date-and-time stamp in the subject of selected emails in Outlook.
The subject becomes the file name in Explorer. The date-and-time stamp ensures the file name is unique.
I am from The Netherlands. Most of my variable names and so on are in Dutch. Sorry about that. The advantage
for me is that Dutch terms will never clash with names VBA reserves for itself.
I started with publishing all of the code for my Excel program, but I think it is a little too much for the forum.
The webpage stalls each time.
So, instead of publishing all of the code I herewith only show the core of the program. I hope it inspires others
to find VBA solutions for things they encounter.
(You have enable Microsoft Outlook 14.0 Object Library for it to work (menu Extra > references))
That's it. I hope someone can use it.
Cheers,
Ro.
in another thread I promised to publish my code for an MS-Outlook clone using Excel.
I publish this because the code others published was so useful to me and I want to do somethig in return.
I am not a professional programmer, so please don't laugh at what I did. It works and for the most of it I even
understand how and why.
The reason for me to start doing something with VBA is the fact that my employer seriously reduced our email
boxes 3 months ago. We are told to store emails on the network as *.msg files (PST files not allowed), which
sucks. In Explorer you can only use file names to look for emails.
I desperately need to be able to use the "metadata" of the *.msg files as well (sender, receivers, etc.).
My employer is not going to help out with suitable software and we are not allowed to install software ourselves.
I decided to try to use Excel as an Outlook clone. That way I can profit from the built in sort and search
functions of Excel.
The Excel program is a suplement to a piece of VBA I made together with a colleague, that works within MS-Outlook.
With that program we are able to put a date-and-time stamp in the subject of selected emails in Outlook.
The subject becomes the file name in Explorer. The date-and-time stamp ensures the file name is unique.
I am from The Netherlands. Most of my variable names and so on are in Dutch. Sorry about that. The advantage
for me is that Dutch terms will never clash with names VBA reserves for itself.
I started with publishing all of the code for my Excel program, but I think it is a little too much for the forum.
The webpage stalls each time.
So, instead of publishing all of the code I herewith only show the core of the program. I hope it inspires others
to find VBA solutions for things they encounter.
(You have enable Microsoft Outlook 14.0 Object Library for it to work (menu Extra > references))
Code:
Sub NieuweMailsToevoegen()
'This sub adds metadata of *.msg files to a list in an Excel worksheet
'User can select a folder where *.msg files are stored
'If user selects a path different from the one mentioned in cel B2 of the active worksheet
'user is warned that the path is changed. If OK, all metadata is deleted and the whole list is refreshed.
'To save time only new or removed *.msg files are procesed.
'CHANGE LOG
'19 Dec. '13
'- The hyperlinks to *.msg files are no longer used, as they are too vulnerable. They easily "die" after network
'modifications. In stead I use path and file name.
'21 Dec. '13
'- metadata for conversation mode of emails is added to the list.
Dim AantalMSGBestanden As Long
Dim MSGTeller As Long
Dim Voortgang As Single
Dim AantalGegevensInExcellijst As Long
Dim AantalDodeLinks As Long
Dim BekendeMailArray() As Variant
Dim NieuweMailArray() As Variant
Dim Bestandslijst As New Collection
Dim BekendeMailPositie As Long
Dim NieuweMailPositie As Long
Dim BestandslijstPositie As Long
Dim teller As Long
Dim GeenDodeLinksOver As Boolean
Dim DodeLinkGevonden As Boolean
Dim VerversAlleGegevens As Boolean
Dim Doorgaan As Integer
Dim Melding As String
Dim NieuweMail As Boolean
Dim FileName As String
Dim MyOutlook As Outlook.Application
Dim X As Namespace
Dim msg As Outlook.MailItem
Dim ResetVerticalScroll As Range
Dim pad As String 'THis is the path where a user wants to search for *.msg files
Dim Pad2 As String 'I need this variable because function Browsefolder(....) returns a string without "\" at the end
Set MyOutlook = New Outlook.Application
Set X = MyOutlook.GetNamespace("MAPI")
'This is for the pop up screen with the progress bar
Set ProgressIndicator = New UserForm1
Call ResetFiltersEnSorteerGegevensOpDatumOplopend
Application.ScreenUpdating = False
'### DETERMINE PATH #######################################################################
'Open the folder with *.msg files.
'Function Browsefolder(....) returns the path the user selected.
'The path Browsefolder(....) returns is compared with the value in cel "B2".
'If ther is a difference between them, the user is warned and all data is refreshed.
pad = Range("B2").Value
pad = browsefolder("Select a folder with *.msg files.", pad)
Pad2 = pad & "\*.msg"
FileName = Dir(Pad2)
'Terminate sub if user selected cancel during execution of function Browsefolder(....)
If pad = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
'Check if it is necessary to refresh all email data.
'This is required if the user selected path different from the value in cel B2, or if no email data was found in the
'active sheet.
VerversAlleGegevens = False
If Range("E6").Value = "" Then
VerversAlleGegevens = True
End If
If Range("B2").Value <> pad Then
VerversAlleGegevens = True
Melding = "You have selected the following path to look for email data:" & Chr(13) & _
" " & pad & Chr(13) & Chr(13) & _
"This path is not the same as the path used before, which was:" & Chr(13) & _
" " & Range("B2").Value & Chr(13) & Chr(13) & _
"If you continue, all available data in this Excel sheet will be deleted and then refreshed." & Chr(13) & Chr(13) & _
"Continue?" & Chr(13)
Doorgaan = MsgBox(Melding, vbYesNo + vbExclamation, "New Path Detected")
If Doorgaan = vbYes Then
Call WisGegevens
Range("B2").Value = ""
'Show user that email data is removed by switching screen updating on and off again.
Application.ScreenUpdating = True
Application.ScreenUpdating = False
ElseIf Doorgaan = vbNo Then
Application.ScreenUpdating = True
Exit Sub
End If
End If
'### RECORD MAIL DATA #######################################################################
'First determine how much email data is available to be able to use the progress bar pop up screen
Range("E5").Select
Do
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Offset(1, 0).Value = ""
AantalGegevensInExcellijst = ActiveCell.Row - 5
Range("E6").Select
'show progress screen
ProgressIndicator.Show vbModeless
'Store all file names in arrayvariabele BestandArray
BekendeMailPositie = 0
Do While ActiveCell.Value <> "" 'as long as file names are found
BekendeMailPositie = BekendeMailPositie + 1 'counter needed to make room in the array variable
ReDim Preserve BekendeMailArray(1 To BekendeMailPositie) 'change the size of the array variable if another filename must be added (while preserving the existing data)
BekendeMailArray(BekendeMailPositie) = ActiveCell.Value 'store the current file name in the array variable
ActiveCell.Offset(1, 0).Activate
'calculate the progress and show the updated progress bar
If ActiveCell.Value <> "" Then
Voortgang = (ActiveCell.Row - 5) / AantalGegevensInExcellijst
Call UpdateProgress(Voortgang, "Capturing current Email data")
End If
Loop
'remove the pop up screen with the progress bar and reset it
Unload ProgressIndicator
Set ProgressIndicator = New UserForm1
Voortgang = 0
'Move all file names from arrayvariable BestandArray to collection variable Bestandslijst
'because it is easier to remove a certain record from a collection variable. I need that later on
'I am a little too lazy now to spend time figure out how to remove a certain record from an array variable....
For BestandslijstPositie = 1 To BekendeMailPositie
Bestandslijst.Add BekendeMailArray(BestandslijstPositie)
Next BestandslijstPositie
'### SEARCH FOR NEW MSG FILES #######################################################################
'Go through all *.msg files in the selected folder. Check for each file if it was already present in collection
'variable FileLijst. If already present, remove this name from the collection variable.
'show progress screen
ProgressIndicator.Show vbModeless
NieuweMailPositie = 0
AantalMSGBestanden = CountFiles(pad, "msg") 'needed to calculate progress
Do While FileName <> ""
NieuweMail = True
BestandslijstPositie = 0
If VerversAlleGegevens = False Then
If BekendeMailPositie > 0 Then
Do
BestandslijstPositie = BestandslijstPositie + 1
If FileName = Bestandslijst(BestandslijstPositie) Then
Bestandslijst.Remove (BestandslijstPositie)
BekendeMailPositie = BekendeMailPositie - 1
NieuweMail = False
End If
Loop Until BestandslijstPositie = BekendeMailPositie _
Or BekendeMailPositie = 0 Or NieuweMail = False
If BekendeMailPositie = 0 Then
Bestandslijst.Add "Geen dode links"
End If
End If
End If
If NieuweMail = True Then
NieuweMailPositie = NieuweMailPositie + 1 ''counter needed to make room in the array variable
ReDim Preserve NieuweMailArray(1 To NieuweMailPositie) 'change the size of the array variable if another filename must be added (while preserving the existing data)
NieuweMailArray(NieuweMailPositie) = FileName 'put the current file name in the array varable
End If
MSGTeller = MSGTeller + 1
Voortgang = MSGTeller / AantalMSGBestanden
Call UpdateProgress(Voortgang, "Looking for new *.msg files.")
FileName = Dir()
Loop
'remove the progress screen and reset it
Unload ProgressIndicator
Set ProgressIndicator = New UserForm1
Voortgang = 0
'### REMOVE EMAIL DATA OF MSG FILES THAT NO LONGER EXIST ####################################################################
'Count how many "dead links" there are (rows with data of files that no longer exist).
'The number of dead links is the same as the number of records that are left in
'collection variable Bestandslijst()
AantalDodeLinks = 0
DodeLinkGevonden = True
Do
AantalDodeLinks = AantalDodeLinks + 1
On Error Resume Next
Bestandslijst (AantalDodeLinks)
If Err.Number = 9 Then
DodeLinkGevonden = False
AantalDodeLinks = AantalDodeLinks - 1
ElseIf Bestandslijst(AantalDodeLinks) = "Geen dode links" Then
DodeLinkGevonden = False
End If
Loop Until DodeLinkGevonden = False
'Remove rows with dead links from the excel sheet
If AantalDodeLinks > 0 Then
teller = 0
Range("E5").Select
Do
ActiveCell.Offset(1, 0).Activate
For teller = 1 To AantalDodeLinks
If Bestandslijst(teller) = "Geen dode links" Then
Exit Do
ElseIf ActiveCell.Value = Bestandslijst(teller) Then
Rows(ActiveCell.Row).Delete Shift:=xlUp
ActiveCell.Offset(-1, 0).Activate
End If
Next teller
Loop Until ActiveCell.Value = ""
End If
'### ADD DATA OF NEW MSG FILES TO THE LIST #######################################################################
'Show progress screen
ProgressIndicator.Show vbModeless
'add new data to the list
Range("E5").Select
Do
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""
For teller = 1 To NieuweMailPositie
'add metadata of the active mailfile in the list
Set msg = X.OpenSharedItem(pad & "\" + NieuweMailArray(teller))
Application.Wait (True)
ActiveCell.Offset(0, -4).Value = msg.SenderName
ActiveCell.Offset(0, -3).Value = msg.To
ActiveCell.Offset(0, -2).Value = msg.CC
ActiveCell.Offset(0, -1).Value = msg.SentOn
ActiveCell.Value = NieuweMailArray(teller) 'add the file name instead of a hyperlink
ActiveCell.Font.Color = -4165632 'blue text for legibility
ActiveCell.Offset(0, 1).Value = msg.Body
ActiveCell.RowHeight = 12.75
If msg.Attachments.Count > 0 Then
ActiveCell.Offset(0, 2).Value = "Attachment(s)"
End If
ActiveCell.Offset(0, 3).Value = msg.ConversationTopic
ActiveCell.Offset(1, 0).Select
Voortgang = teller / NieuweMailPositie
Call UpdateProgress(Voortgang, "Adding Email data to list.")
Next teller
'remove progress screen and reset values
Unload ProgressIndicator
Set ProgressIndicator = Nothing
Voortgang = 0
'### CLEAN, SORT, ETC. ##############################################################
Call ResetFiltersEnSorteerGegevensOpDatumOplopend
Application.ScreenUpdating = False
Range("B2").Value = pad
Range("B3").Value = Now()
Range("B3").HorizontalAlignment = xlLeft
Range("B3").VerticalAlignment = xlBottom
Range("A6").Select
'make sure the vertical scroll function is usable again (without this the screen flashes up and down
'if a user tries to scroll using the ruler on the right side of the screen, as all 10 milion + rows
'were modified while executing this sub)
Set ResetVerticalScroll = ActiveSheet.UsedRange
Application.ScreenUpdating = True
'### CHECK IF THE SUB WORKED CORRECTLY ############################################################################
'The sub worked correctly if the number of *.msg files is the same as the number
'of records in the Excel list.
AantalGegevensInExcellijst = 0
Range("E5").Select
If ActiveCell.Offset(1, 0).Value <> "" Then
Do
ActiveCell.Offset(1, 0).Activate
AantalGegevensInExcellijst = AantalGegevensInExcellijst + 1
Loop Until ActiveCell.Offset(1, 0).Value = ""
End If
If AantalMSGBestanden <> AantalGegevensInExcellijst Then
Melding = MsgBox("Something is wrong." & Chr(13) & Chr(13) & _
AantalMSGBestanden & " *.msg files were found in the selected folder." & Chr(13) & _
AantalGegevensInExcellijst & " items were recorded in this Excel list." & Chr(13) & _
"These two figures should be the same." & Chr(13) & Chr(13) & _
"Try to refresh all items by first removing the link in cell B2" & Chr(13) & _
"and then pressing the refresh button.", vbOKOnly + vbCritical, "Program fault detected")
ElseIf AantalMSGBestanden = AantalGegevensInExcellijst Then
Melding = MsgBox("Program completed successfully." & Chr(13) & Chr(13) & _
AantalMSGBestanden & " *.msg files were found in the selected folder." & Chr(13) & _
AantalGegevensInExcellijst & " items are now recorded in this Excel list." & Chr(13), _
vbOKOnly + vbInformation, "Ready")
End If
End Sub 'NieuweMailsToevoegen
Function browsefolder(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
'Found on the Internet. Thanks!
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
browsefolder = CStr(V)
End Function 'browsefolder
Function CountFiles(strDirectory As String, Optional strExt As String = "*.*") As Double
'Found on the Internet, Thanks!
'Author : Ken Puls ([URL="http://www.excelguru.ca"]www.excelguru.ca[/URL])
'Function purpose: To count files in a directory. If a file extension is provided,
' then count only files of that type, otherwise return a count of all files.
Dim objFso As Object
Dim objFiles As Object
Dim objFile As Object
'Set Error Handling
On Error GoTo EarlyExit
'Create objects to get a count of files in the directory
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFso.GetFolder(strDirectory).Files
'Count files (that match the extension if provided)
If strExt = "*.*" Then
CountFiles = objFiles.Count
Else
For Each objFile In objFiles
If UCase(Right(objFile.Path, (Len(objFile.Path) - InStrRev(objFile.Path, ".")))) = UCase(strExt) Then
CountFiles = CountFiles + 1
End If
Next objFile
End If
EarlyExit:
'Clean up
On Error Resume Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFso = Nothing
On Error GoTo 0
End Function 'CountFilesThat's it. I hope someone can use it.
Cheers,
Ro.
