Option Explicit
Private objitem As MailItem
Private wdApp As Object
Private wdDoc As Object
Private bStarted As Boolean
Const strPath As String = "H:\Uploads\"
Sub SaveMessageAsPDF()
MapHDrive
'Select the messages to process and run this macro
Dim olMsg As MailItem
'Create the folder to store the messages if not present
If CreateFolders(strPath) = False Then GoTo lbl_Exit
'Open or Create a Word object
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo lbl_Exit:
For Each olMsg In Application.ActiveExplorer.Selection
SaveAsPDFfile olMsg, wdApp
Next olMsg
lbl_Exit:
If bStarted Then wdApp.Quit
Set wdApp = Nothing
Exit Sub
End Sub
Sub SaveAsPDFfile(olItem As MailItem, wdApp As Object)
Dim FSO As Object, TmpFolder As Object
Dim tmppath As String
Dim strfilename As String
Dim strAttachPrefix As String
Dim strName As String
Dim oRegEx As Object
Dim oShape As Object
Dim oRng As Object
'Get the user's TempFolder to store the temporary file
Set FSO = CreateObject("Scripting.FileSystemObject")
tmppath = FSO.GetSpecialFolder(2)
'construct the filename for the temp mht-file
strName = "email.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)
'Change Font color to black and resize images
Set oRng = wdDoc.Range
oRng.Font.Color = -587137025
For Each oShape In oRng.InlineShapes
With oShape
oShape.LockAspectRatio = msoTrue
End If
If oShape.Width > wdApp.InchesToPoints(6.5) Then
oShape.Width = wdApp.InchesToPoints(6.5)
End If
End With
Next oShape
'Create a file name from the message subject
strfilename = InputBox("Enter claim number for message" & vbCr & _
olItem.subject, "Claim Number")
If strfilename = "" Then GoTo lbl_Exit
'Remove illegal filename characters
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
strfilename = Trim(oRegEx.Replace(strfilename, "")) & ".pdf"
strfilename = FileNameUnique(strPath, strfilename, "pdf")
strAttachPrefix = Replace(strfilename, ".pdf", "")
'save attachments
SaveAttachments olItem, strAttachPrefix
strfilename = strPath & Format(Date, "mmmm dd, yyyy") & "\" & strfilename
'Save As pdf
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 and Word
lbl_Exit:
wdDoc.Close 0
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As MailItem, strName As String)
Dim olAttach As Attachment
Dim strFname As String
Dim strExt As String
Dim strSaveFldr As String
strSaveFldr = strPath
CreateFolders strSaveFldr
On Error GoTo lbl_Exit
If olItem.Attachments.Count > 0 Then
For Each olAttach In olItem.Attachments
If Not olAttach.Filename Like "image*.*" Then
strFname = strName & "_" & olAttach.Filename
strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
strFname = FileNameUnique(strSaveFldr, strFname, strExt)
olAttach.SaveAsFile strSaveFldr & strFname
End If
Next olAttach
End If
lbl_Exit:
Set olAttach = Nothing
Exit Sub
End Sub
Private Function CreateFolders(strPath As String) As Boolean
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath & Format(Date, "mmmm dd, yyyy"), "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
On Error GoTo Err_Handler
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
CreateFolders = True
lbl_Exit:
Exit Function
Err_Handler:
MsgBox "The path " & strPath & " is invalid!"
CreateFolders = False
Resume lbl_Exit
End Function
Private Function FileNameUnique(strPath As String, _
strfilename As String, _
strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strfilename) - (Len(strExtension) + 1)
strfilename = Left(strfilename, lngName)
Do While FileExists(strPath & Format(Date, "mmmm dd, yyyy") & "\" & 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 FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
Exit Function
End Function
Private Function FileExists(ByVal Filename As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFile
nAttr = GetAttr(Filename)
If (nAttr And vbDirectory) <> vbDirectory Then
FileExists = True
End If
NoFile:
Exit Function
End Function
Function MapHDrive()
Dim oNetwork As Object, sDrive As String, sPath As String
If FolderExists("H:\") Then
GoTo Already_Mapped
Else
Set oNetwork = CreateObject("WScript.Network")
sDrive = "H:"
sPath = "\\ns-uticvfs01\" & (Environ$("Username"))
oNetwork.MapNetworkDrive sDrive, sPath
End If
Already_Mapped:
End Function
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function
Reply With Quote
