RajOberoi
11-21-2018, 06:37 AM
Hi Guys
The below code works fine to convert Word documents or text files into PDF files but how can we make it working to convert JPEG /JPG into PDF and save down in a folder on the network.
Also how can distinguish between real attachments and fake attachments ( logos/signature etc.)
Option Explicit
Const strSaveFldr As String = "U:\Word\"
Private wdApp As Object
Private wdDoc As Object
Sub ProcessSelection()
Dim olMailItem As Object
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
For Each olMailItem In Application.ActiveExplorer.Selection
SaveAttachments olMailItem
DoEvents
Next olMailItem
Err_Handler:
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As Object)
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", ".txt", ".JPEG", "JPG"
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:=True
wdDoc.Close 0
wdApp.Quit
'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
MsgBox olAttach.FileName
End Select
olItem.Categories = ""
olItem.FlagStatus = olFlagComplete
olItem.UnRead = False
olItem.Save
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:=True
' close the document
wdDoc.Close 0
wdApp.Quit
lbl_Exit:
'Cleanup
Set olNS = Nothing
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub
The below code works fine to convert Word documents or text files into PDF files but how can we make it working to convert JPEG /JPG into PDF and save down in a folder on the network.
Also how can distinguish between real attachments and fake attachments ( logos/signature etc.)
Option Explicit
Const strSaveFldr As String = "U:\Word\"
Private wdApp As Object
Private wdDoc As Object
Sub ProcessSelection()
Dim olMailItem As Object
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
For Each olMailItem In Application.ActiveExplorer.Selection
SaveAttachments olMailItem
DoEvents
Next olMailItem
Err_Handler:
Set olMailItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Private Sub SaveAttachments(olItem As Object)
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", ".txt", ".JPEG", "JPG"
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:=True
wdDoc.Close 0
wdApp.Quit
'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
MsgBox olAttach.FileName
End Select
olItem.Categories = ""
olItem.FlagStatus = olFlagComplete
olItem.UnRead = False
olItem.Save
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:=True
' close the document
wdDoc.Close 0
wdApp.Quit
lbl_Exit:
'Cleanup
Set olNS = Nothing
Set wdDoc = Nothing
Set oRegEx = Nothing
Exit Sub
End Sub