' -- (Non)Functioning Example to demonstrate built-in Outlook *email objects*
' -- DO NOT RUN without SAFETY test for your target environment and version
' -- requires prior creation of target email folders and CONSTANTS
Const TARGETPATH = "\My Documents\CONSTANTNAME\xEmailArchive\" Option Explicit ' ' SUPPLEMENT TO native AUTO ARCHIVE - saves to pre-set folder ' ' ' ' ' ─────── Sub SaveAttachmentsToFolder() ' checks selected messages with attachments ' of a specific type (here file with an "xls" extension) ' and saves them to disk. Saved files are timestamped. The user ' can choose to view the saved files in Windows Explorer. On Error GoTo SaveAttachmentsToFolder_err Dim myItem As Outlook.Inspector ' objects from a MicSoft sample routine Dim myOlExp As Outlook.Explorer Dim myOlSel As Outlook.Selection Dim ns As NameSpace Set ns = GetNamespace("MAPI") Dim Inbox As MAPIFolder Set Inbox = ns.GetDefaultFolder(olFolderInbox) Dim SubFolder As MAPIFolder ' not used Dim Item As Object Dim Atmt As Attachment Dim FileName, strSaveToPath As String Dim x, i As Integer Dim varResponse As VbMsgBoxResult 'below set statements were for hard coded target email folders 'Set SubFolder = Inbox.Folders("Sales Reports") ' Enter correct subfolder name. 'Set myOlSel = Inbox.Folders("Sales Reports") ' Enter correct subfolder name. 'For x = 1 To myOlSel.Count 'added strSaveToPath = getENV("USERPROFILE") & TARGETPATH 'MUST HAVE TRAILING SLASH 'strSaveToPath = getENV("HOMEPATH") & "\My Documents\TEMP\" Set myItem = Application.ActiveInspector Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection '''''''''''''' For x = 1 To myOlSel.Count 'For Each Item In myOlSel.Items ''replaced by net for each myOlSel.Item(x).Display For Each Atmt In myOlSel.Item(x).Attachments ' strname = stripIllegalChars(myOlSel.Item(x).Subject) ' save if filename has "xls" extension ' If Right(Atmt.FileName, 3) = "xls" Then ' This path must exist! Change folder name as necessary. 'if debugflag then MsgBox strSaveToPath & "\" & Atmt.FileName FileName = strSaveToPath & _ Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName ' & stripIllegalChars(Atmt.FileName) & ".xyz" ' Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName Atmt.SaveAsFile FileName ' 'End If Next Atmt myOlSel.Item(x).Close olPromptForSave Next x ' Show summary message i = myOlSel.Count If i > 0 Then varResponse = MsgBox("I found " & i & " attached files." _ & vbCrLf & "I have saved them into the " & strSaveToPath & "." _ & vbCrLf & vbCrLf & "Would you like to view the files now?" _ , vbQuestion + vbYesNo, "Finished!") ' Open Windows Explorer to display saved files if user chooses If varResponse = vbYes Then ' ' Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus Shell "Explorer.exe /e," & strSaveToPath, vbNormalFocus End If Else MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!" End If ' Clear memory SaveAttachmentsToFolder_exit: Set Atmt = Nothing Set Item = Nothing Set ns = Nothing Exit Sub ' Handle Errors SaveAttachmentsToFolder_err: MsgBox "An unexpected error has occurred." _ & vbCrLf & "Please note and report the following information." _ & vbCrLf & "Macro Name: GetAttachments" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL ' "Joe Xplsknik - joex@utestme.com" _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" Resume SaveAttachmentsToFolder_exit End Sub ' ─────── Sub SaveSelectedAsHTML() Dim myItem As Outlook.Inspector Dim myOlExp As Outlook.Explorer ' Dim myOlSel As Outlook.Selection ' Dim objItem As Object Dim strname, strSaveToPath As String Dim x As Integer strSaveToPath = getENV("USERPROFILE") & "\Desktop\" strSaveToPath = getENV("HOMEPATH") & "\My Documents\CONSTANTNAME\xEmailArchive\" Set myItem = Application.ActiveInspector Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection If Not TypeName(myOlExp) = "Nothing" Then ' Set objItem = myOlExp.CurrentItem ' strname = stripIllegalChars(objItem.Subject) 'Prompt the user for confirmation Dim strPrompt As String strPrompt = IIf(myOlSel.Count = 1, myOlSel.Count & " Selected Item", myOlSel.Count & " Selected Items") strPrompt = strPrompt & " will be saved to " & vbCrLf & strSaveToPath & vbCrLf & _ "Any files with the same name will be OVERWRITTEN." If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then 'objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT For x = 1 To myOlSel.Count On Error GoTo FileError ' strname = stripIllegalChars(myOlSel.Item(x).Subject) ' strname = stripIllegalChars(myOlSel.Item(x).SenderEmailAddress & myOlSel.Item(x).Subject) strname = stripIllegalChars(myOlSel.Item(x).SenderName) 'SenderName SenderEmailAddress strname = strname & "_" & stripIllegalChars(myOlSel.Item(x).Subject) strname = strname & "_" & Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss") 'MsgTxt = MsgTxt & vbCrLf & myOlSel.Item(x).SenderName & ";" 'objItem.SaveAs Environ("USERPROFILE") & "\Desktop\" & strname & ".txt", olTXT myOlSel.Item(x).Display myOlSel.Item(x).SaveAs strSaveToPath & strname & ".htm", olHTML 'olMSGUnicode olTXT 'The file type to save. Can be one of the following OlSaveAsType constants: ' olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode. myOlSel.Item(x).Close olPromptForSave ' olSave olDiscard either has no effect if NOT changed ' myFolder.Items(1).Display 'Set myinspector = Application.ActiveInspector 'Set myItem = myinspector.CurrentItem 'myItem.Close olSave Next x End If Else MsgBox "There is no current active Explorer." End If Exit Sub FileError: MsgBox "Error: (Likely " & strSaveToPath & " does not exist!)" _ & vbCrLf & "Please note and report the following information." _ & vbCrLf & "Macro Name: SaveSelectedAsHTML" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL & _ ' "Joe Xplsknik - joex@utestme.com" _ & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" 'Resume 'SaveAttachmentsToFolder_exit End Sub ' ─────── Sub SaveSelectedAsTXT() Dim myItem As Outlook.Inspector Dim myOlExp As Outlook.Explorer ' Dim myOlSel As Outlook.Selection ' Dim objItem As Object Dim strname, strSaveToPath As String Dim x As Integer 'strSaveToPath = getENV("USERPROFILE") & "\Desktop\" 'strSaveToPath = getENV("HOMEPATH") & "\My Documents\CONSTANTNAME\xEmailArchive\" strSaveToPath = getENV("USERPROFILE") & "\My Documents\CONSTANTNAME\xEmailArchive\" On Error GoTo FileError Set myItem = Application.ActiveInspector Set myOlExp = Application.ActiveExplorer Set myOlSel = myOlExp.Selection If Not TypeName(myOlExp) = "Nothing" Then ' Set objItem = myOlExp.CurrentItem ' strname = stripIllegalChars(objItem.Subject) 'Prompt the user for confirmation Dim strPrompt As String strPrompt = IIf(myOlSel.Count = 1, myOlSel.Count & " Selected Item", myOlSel.Count & " Selected Items") strPrompt = strPrompt & " will be saved to " & vbCrLf & strSaveToPath & vbCrLf & _ "Any files with the same name will be OVERWRITTEN." If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then 'objItem.SaveAs Environ("HOMEPATH") & "\My Documents\" & strname & ".txt", olTXT For x = 1 To myOlSel.Count strname = stripIllegalChars(myOlSel.Item(x).SenderName) 'SenderName SenderEmailAddress strname = strname & "_" & stripIllegalChars(myOlSel.Item(x).Subject) strname = strname & "_" & Format(myOlSel.Item(x).CreationTime, "yyyymmdd_hhnnss") & Int(Rnd(1) * 1000) 'strname = stripIllegalChars(myOlSel.Item(x).Subject) 'MsgTxt = MsgTxt & vbCrLf & myOlSel.Item(x).SenderName & ";" 'objItem.SaveAs Environ("USERPROFILE") & "\Desktop\" & strname & ".txt", olTXT myOlSel.Item(x).Display myOlSel.Item(x).SaveAs strSaveToPath & strname & ".txt", olTXT 'The file type to save. Can be one of the following OlSaveAsType constants: ' olHTML, olMSG, olRTF, olTemplate, olDoc, olTXT, olVCal, olVCard, olICal, or olMSGUnicode. myOlSel.Item(x).Close olPromptForSave ' olSave olDiscard either has no effect if NOT changed ' myFolder.Items(1).Display 'Set myinspector = Application.ActiveInspector 'Set myItem = myinspector.CurrentItem 'myItem.Close olSave Next x End If Else MsgBox "There is no current active Explorer." End If Exit Sub FileError: MsgBox "Error: (Likely " & strSaveToPath & " does not exist!)" _ & vbCrLf & "Please note the following information." _ & vbCrLf & "Macro Name: SaveSelectedAsTXT" _ & vbCrLf & "Error Number: " & Err.Number _ & vbCrLf & CONSTANT_FULL_NAME_and_EMAIL & _' redundant - see above & vbCrLf & "Error Description: " & Err.Description _ , vbCritical, "Error!" 'Resume 'SaveAttachmentsToFolder_exit End Sub ' ─────── Private Function getENV(strReturn As String) 'CALLED BY ChDir getENV("userprofile") & "\Desktop\" Dim EnvString, Indx, Msg, PathLen ' Declare variables. Indx = 1 ' Initialize index to 1. For Indx = 1 To Len(Environ(Indx)) + 2 EnvString = Environ(Indx) ' Get environment If UCase(Left(EnvString, Len(strReturn))) = UCase(strReturn) Then getENV = Mid(EnvString, Len(strReturn) + 2) End If Next Indx 'Loop Until EnvString = "" End Function ' ─────── Private Function stripIllegalChars(strTest As String) Dim strTemp, testThis As String Dim kount As Integer strTemp = "" strTest = Trim(strTest) For kount = 1 To Len(strTest) testThis = Mid(strTest, kount, 1) If InStr(".|\/?*:<>' ", testThis) > 0 Or Asc(testThis) < 32 Or Asc(testThis) = 34 Or Asc(testThis) > 129 Then 'strTemp = strTemp & "_" Else: strTemp = strTemp & Mid(strTest, kount, 1) End If Next kount stripIllegalChars = IIf(Len(strTemp) < 1, "Missing_Subject" & Int(Rnd(1) * 1000), strTemp) End Function ' ─────── Sub SetFlagIcon() Dim mpfInbox As Outlook.Folder Dim obj As Outlook.MailItem Dim i As Integer Set mpfInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("Test") ' Loop all items in the Inbox\Test Folder For i = 1 To mpfInbox.Items.Count If mpfInbox.Items(i).Class = olMail Then Set obj = mpfInbox.Items.Item(i) If obj.SenderEmailAddress = "someone@example.com" Then 'Set the yellow flag icon obj.FlagIcon = olYellowFlagIcon obj.Save End If End If Next End Sub ' ───────