Option Explicit
Const strSaveFldr As String = "C:\Path\Attachments\"
Private wdApp As Object
Private wdDoc As Object
Sub ProcessMessage()
'An Outlook macro by Graham Mayor
Dim olMsg As Object
'On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
SaveAttachments olMsg
lbl_Exit:
Exit Sub
End Sub
Sub ProcessFolder()
'An Outlook macro by Graham Mayor
Dim olNS As Outlook.NameSpace
Dim olMailFolder As Outlook.MAPIFolder
Dim olItems As Outlook.Items
Dim olMailItem As Object
On Error GoTo Err_Handler
Set olNS = GetNamespace("MAPI")
Set olMailFolder = olNS.PickFolder
Set olItems = olMailFolder.Items
For Each olMailItem In olItems
SaveAttachments olMailItem
DoEvents
Next olMailItem
Err_Handler:
Set olNS = Nothing
Set olMailFolder = Nothing
Set olItems = Nothing
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As Object)
'Graham Mayor - http://www.gmayor.com - Last updated - 09 Oct 2018
Dim olAttach As Attachment
Dim strFName As String
Dim strExt As String
Dim j As Long
Dim olInsp As Inspector
Dim oRng As Object
Dim strTemp As String
Dim intPos As Integer
strTemp = Environ("TEMP") & "\"
If Not TypeName(olItem) = "MailItem" Then GoTo lbl_Exit
CreateFolders strSaveFldr
SaveAsPDFfile olItem
If olItem.Attachments.Count > 0 Then
For j = 1 To olItem.Attachments.Count
Set olAttach = olItem.Attachments(j)
Select Case LCase(Mid(olAttach.fileName, InStrRev(olAttach.fileName, Chr(46))))
Case ".docx", ".doc"
On Error Resume Next
olAttach.SaveAsFile strTemp & olAttach.fileName
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(strTemp & olAttach.fileName)
intPos = InStrRev(olAttach.fileName, ".")
strFName = Left(olAttach.fileName, intPos - 1)
strFName = strFName & ".pdf"
strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
strFName = FileNameUnique(strSaveFldr, strFName, strExt)
wdDoc.ExportAsFixedFormat OutputFilename:=strSaveFldr & strFName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
wdDoc.Close 0
'If bWordWasNotRunning = True Then wdApp.Quit
Case ".pdf"
strFName = olAttach.fileName
strExt = Right(strFName, Len(strFName) - InStrRev(strFName, Chr(46)))
strFName = FileNameUnique(strSaveFldr, strFName, strExt)
olAttach.SaveAsFile strSaveFldr & strFName
Case Else
End Select
Next j
olItem.Save
End If
lbl_Exit:
Set olAttach = Nothing
Set olItem = Nothing
Exit Sub
End Sub
Private Sub SaveAsPDFfile(olItem As Object)
Dim olNS As NameSpace
Dim tmpPath As String
Dim strFileName As String
Dim strName As String
Dim oRegex As Object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Set olNS = Application.GetNamespace("MAPI")
'Get the user's TempFolder to store the temporary file
tmpPath = Environ("TEMP")
'construct the filename for the temp mht-file
strName = "email_temp.mht"
tmpPath = tmpPath & "\" & strName
'Save temporary file
olItem.SaveAs tmpPath, 10
'Open the temporary file in Word
Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
AddToRecentFiles:=False, _
Visible:=False, _
Format:=7)
'Create a file name from the message subject
strFileName = olItem.Subject
'Remove illegal filename characters
Set oRegex = CreateObject("vbscript.regexp")
oRegex.Global = True
oRegex.Pattern = "[\/:*?""<>|]"
strFileName = Trim(oRegex.Replace(strFileName, "")) & ".pdf"
strFileName = FileNameUnique(strSaveFldr, strFileName, "pdf")
strFileName = strSaveFldr & strFileName
wdDoc.ExportAsFixedFormat OutputFilename:= _
strFileName, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
' close the document
wdDoc.Close 0
lbl_Exit:
'Cleanup
Set olNS = Nothing
Set wdDoc = Nothing
Set oRegex = Nothing
Exit Sub
End Sub
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'An Outlook macro by Graham Mayor
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName) - (Len(strExtension) + 1)
strFileName = Left(strFileName, lngName)
Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = strFileName & Chr(46) & strExtension
lbl_Exit:
Exit Function
End Function
Private Function FileExists(strName As String) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function FolderExists(strFolder As String) As Boolean
'An Outlook macro by Graham Mayor
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(strFolder)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function
Private Function CreateFolders(strPath As String)
'An Outlook macro by Graham Mayor
Dim strTempPath As String
Dim lngPath As Long
Dim VPath As Variant
VPath = Split(strPath, "\")
strPath = VPath(0) & "\"
For lngPath = 1 To UBound(VPath)
strPath = strPath & VPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function
Reply With Quote