OUTLOOK - Export_email_messages_to_mht_files_and_save_attachments.vba

Export_email_messages_to_mht_files_and_save_attachments.vba

' Save files as mht file to storage device
' Highlight the messages to archive and then run script
Public Sub samht()
Const olFolderInbox = 6
Dim i As Integer
Dim k As Integer
Dim m As Integer
Dim x As Integer
Dim CU As String
Dim strFName As String
Dim strName As String
Dim strExt As String
Dim strNoData As String
Dim strFN As String
Dim j As Long
Dim lngCount As Long
Dim strFile As String
Dim strLocation As String
Dim strLocationF As String
x = 0
k = 0
m = 0
'CU = ""
Set objOutlook = CreateObject("Outlook.Application")
Set objNameSpace = objOutlook.GetNamespace("MAPI")

' Set to do Inbox ----------------------------------------------------------
Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
Set colItems = objFolder.Items
'Set CU = Session.CurrentUser

Set OlExp = Application.ActiveExplorer
Set selItems = OlExp.Selection

Set objFSO = CreateObject("Scripting.FileSystemObject")
strFN = ""
strLocation = "\\Network_Storage\Folders\mht_archive\" 'The folder to save the emails to
On Error GoTo errorHandler 'If there are any errors - SQUAWK!
 
For Each objMessage In selItems 'For every message in the inbox
x = x + 1
    'SSN = Replace(Replace(objMessage.ReceivedTime, "/", "-"), ":", "-")
    Set SubFolder = objMessage.Parent
    strLocationF = "\\Network_Storage\Folders\mht_archive\" & SubFolder 'The folder to save the emails to 'Added
    Set frmItem = objMessage.Sender
    Set toItem = objMessage.Recipients
    frmItemTemp1 = Replace(Split(frmItem, "@")(0), ", ", " ")
    frmItemTemp1 = Replace(frmItemTemp1, "/\|><", "-")
    'frmItemTemp1 = Replace(frmItemTemp1, "\", "-")
    SSM = objMessage.ReceivedTime
    SSN = Format(objMessage.ReceivedTime, "yyyymmdd-hhmmss") & "." & Strings.Right(Strings.Format(Timer, "#0.00"), 2)
    intCount = colItems.Count 'Count the number of message in the folder
    sstring = CleanFileName(objMessage.Subject)
    If intCount > 0 Then 'If there ARE messages in the folder - proceed / If not - Next
        strName = SSN & " " & frmItemName & " - " & sstring & ".mht" 'Assign the destination filename and add mht
        ' objMessage.SaveAsFile strLocation & strName, FileFormat:=wdFormatWebArchive
        'If Not (fso.FolderExists(strLocationF)) Then                   'added
        If Not objFSO.FolderExists(strLocationF) Then                   'Added
            objFSO.CreateFolder (strLocationF)                          'Added
            objMessage.SaveAs strLocationF & "\" & strName, olMHTML     'Added
        Else                                                            'Added
            If Not objFSO.FileExists(strLocationF & "\" & strName) Then
                objMessage.SaveAs strLocationF & "\" & strName, olMHTML     'added
            End If
        'Original objMessage.SaveAs strLocation & strName, olMHTML
        End If                                                          'Added
    End If 'If intCount > 0
    
            Set objAttachments = objMessage.Attachments
            lngCount = objAttachments.Count
                
            If lngCount > 0 Then
                
                ' Use a count down loop for removing items
                ' from a collection. Otherwise, the loop counter gets
                ' confused and only every other item is removed.
                
                For j = lngCount To 1 Step -1
                    ' Get the file name.
                    strFile = objAttachments.Item(j).FileName
                    If Split(LCase(strFile), ".")(1) <> "msg" Then
                        ' Don't save baby files
                        If objAttachments.Item(j).Size > 5200 Then
    
                            ' Combine with the path to the Temp folder.
                            strFile = strLocationF & "\" & strFile
                                                            
                            ' Save the attachment as a file.
                            objAttachments.Item(j).SaveAsFile strFile
                            k = k + 1
                        
                        Else
                            m = m + 1
                        End If
                    Else
                        m = m + 1
                    End If
                Next j
            End If
        
Next 'For Each objMessage In colItems

    'MsgBox (x & " files were saved to: " & strLocation)
    If x = 0 Then
        MsgBox ("Task Completed. Nothing to do.")
    Else
        MsgBox (x & " files were saved to: " & vbNewLine & vbNewLine & strLocationF & _
        vbNewLine & k & " attachments were saved. " & m & " files skipped due to size or they were msgs")
' vbNewLine & "Report requested by: " & CU)
    End If
Set objOutlook = Nothing 'Clean things up
Set objNameSpace = Nothing 'Clean things up
Set objFolder = Nothing 'Clean things up
Set colItems = Nothing 'Clean things up
Set objFSO = Nothing 'Clean things up
Set OlExp = Nothing
Set selItems = Nothing
strFName = ""
strName = ""
strExt = ""
strNoData = ""
strFN = ""
j = 0
lngCount = 0
strFile = ""
strLocation = ""
strLocationF = ""
Exit Sub 'Dishes are DONE MAN

errorHandler:  ' Error-handling routine.
    strFName = Right$(strName, 4)
    MsgBox ("Sorry - there was an error." & vbNewLine & vbNewLine & Error(Err) & "." & _
    vbNewLine & "The error occurred with: " & vbNewLine & strName)
    Resume Next 'Go back to after where the error occurred
    
End Sub

Function CleanFileName(strText As String) As String
    Dim strStripChars As String
    Dim intLen As Integer
    Dim i As Integer
    strStripChars = "/\[]:=,|?><" & Chr(34)
    intLen = Len(strStripChars)
    strText = Trim(strText)
    For i = 1 To intLen
        strText = Replace(strText, Mid(strStripChars, i, 1), "")
    Next

    CleanFileName = strText
End Function