Consulting

Results 1 to 2 of 2

Thread: VBA code to save textfiles,JPEG,JPG attachments to PDF in a folder

  1. #1

    VBA code to save textfiles,JPEG,JPG attachments to PDF in a folder

    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

  2. #2
    Any help in this guys? Please can anyone help me in this.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •