' -- Example to demonstrate CODE of built-in Outlook *email objects*
' -- DO NOT RUN without BACKUP and SAFETY test for your unique environment and version
' -- requires prior creation of target email folders as 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.
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
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
' ───────
