Outlook – Backup Selected Items

' -- (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
' ───────