Modify File before saving it.

[josros60]

Hi,

found very helpful code to print multiples attachments in outlook, just wonder if can prompt to when open file to fix like columns showing ##### because is narrow after modifying saving it.

here is the code ( and after will put a sample that you can see that date cannot see it because columns no wide enough is excel file converted to pdf)

Sub BatchPrintAllAttachmentsinMultipleEmails()
    Dim objFileSystem As Object
    Dim strTempFolder As String
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objShell As Object
    Dim objTempFolder As Object
    Dim objTempFolderItem As Object
    Dim strFilePath As String
 
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Attachments " & Format(Now, "YYYY-MM-DD_hh-mm-ss")
    'Create a new temp folder
    MkDir (strTempFolder)
 
    Set objSelection = Outlook.Application.ActiveExplorer.Selection
 
    For Each objItem In objSelection
        If TypeOf objItem Is MailItem Then
           Set objMail = objItem
           Set objAttachments = objMail.Attachments
 
           'Save all the attachments in the temp folder
           For Each objAttachment In objAttachments
               strFilePath = strTempFolder & "\" & objAttachment.FileName
               objAttachment.SaveAsFile (strFilePath)
 
               'Print all the files in the temp folder
               Set objShell = CreateObject("Shell.Application")
               Set objTempFolder = objShell.NameSpace(0)
               Set objTempFolderItem = objTempFolder.ParseName(strFilePath)
               objTempFolderItem.InvokeVerbEx ("print")
           Next objAttachment
        End If
    Next
End Sub

Sample:

 

[josros60]

Hi,

Can it possible to change to prompt me for saving location instead of fix one?

thank you,

 

[Domenic]

When the SaveAs prompt is displayed and the user is prompted to choose a name, the user also has the opportunity to choose a location other than the default one. Doesn't this suffice?

 

[josros60]

Hi,

When I run it getting "Run-time error '1004': Method 'This workbook of object, failed and highlight this line:

saveAsPdfFilename = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Path, FileFilter:="PDF File (*.pdf), *.pdf", Title:="Save As")

Please note:

I change this line to the folder I created "Attachments"

strTempFolder = objFileSystem.GetSpecialFolder(2).Path & [B][COLOR=rgb(226, 80, 65)]"\Attachments "[/COLOR][/B] & Format(Now, "YYYY-MM-DD_hh-mm-ss")

thank you

 

[Domenic]

Try changing the InitialFilename argument as follows . . .

saveAsPdfFilename = Application.GetSaveAsFilename(InitialFileName:=strTempFolder, FileFilter:="PDF File (*.pdf), *.pdf", Title:="Save As")

Does this help?

 

[josros60]

changed it now giving me this error:

Run-Time error '438' object doesn't support property or method

 

[Domenic]

Are you running your code within Excel or Outlook?

When the error occurs, what exactly does it highlight?

 

[josros60]

Outlook.

 

[josros60]

sorry missed 2nd question, it highlights this one:

aveAsPdfFilename = Application.GetSaveAsFilename(InitialFileName:=strTempFolder, FileFilter:="PDF File (*.pdf), *.pdf", Title:="Save As")

 

[Domenic]

Outlook.

That would explain why you're getting the error. But if that's the case, you should have received a user-defined type compile error highlighting this line . . .

Dim wb as Workbook

Did you not get an error?

 

[Domenic]

Try the following code instead . . .

Sub BatchPrintAllAttachmentsinMultipleEmails()
    Dim objFileSystem As Object
    Dim strTempFolder As String
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objShell As Object
    'Dim objTempFolder As Object
    'Dim objTempFolderItem As Object
    Dim strFilePath As String
    Dim saveAsPdfFilename As Variant
    Dim xl As Object
    Dim wb As Object
    
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Attachments " & Format(Now, "YYYY-MM-DD_hh-mm-ss")
    'Create a new temp folder
    MkDir (strTempFolder)
    
    Set xl = CreateObject("Excel.Application")
 
    Set objSelection = Outlook.Application.ActiveExplorer.Selection
 
    For Each objItem In objSelection
        If TypeOf objItem Is MailItem Then
           Set objMail = objItem
           Set objAttachments = objMail.Attachments
           For Each objAttachment In objAttachments
              If LCase(Right(objAttachment.FileName, 4)) = ".csv" Or LCase(Right(objAttachment.FileName, 5)) = ".xlsx" Then
                    saveAsPdfFilename = xl.GetSaveAsFilename(InitialFileName:=strTempFolder, FileFilter:="PDF File (*.pdf), *.pdf", Title:="Save As")
                    If saveAsPdfFilename = False Then Exit Sub
                    strFilePath = strTempFolder & "\" & objAttachment.FileName
                    objAttachment.SaveAsFile strFilePath
                    Set wb = xl.Workbooks.Open(strFilePath)
                    wb.worksheets(1).Columns("A:B").AutoFit
                    wb.ExportAsFixedFormat 0, saveAsPdfFilename '0 = xlTypePDF
                    wb.Close SaveChanges:=False
                    Exit For
              End If
           Next objAttachment
        End If
    Next
End Sub

Note, however, you can instead use the Environ function to retrieve the path to your temporary folder . . .

strTempFolder = Environ("temp") & "\Temp for Attachments " & Format(Now, "YYYY-MM-DD_hh-mm-ss")

And, since you're running your within Outlook, the following would suffice . . .

Set objSelection = Application.ActiveExplorer.Selection

So the code can be re-written as follows . . .

Sub BatchPrintAllAttachmentsinMultipleEmails()
    Dim objFileSystem As Object
    Dim strTempFolder As String
    Dim objSelection As Outlook.Selection
    Dim objItem As Object
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objShell As Object
    Dim strFilePath As String
    Dim saveAsPdfFilename As Variant
    
    'Excel objects
    Dim xl As Object
    Dim wb As Object
    
    strTempFolder = Environ("temp") & "\Temp for Attachments " & Format(Now, "YYYY-MM-DD_hh-mm-ss")
    
    'Create a new temp folder
    MkDir (strTempFolder)
    
    Set xl = CreateObject("Excel.Application")
 
    Set objSelection = Application.ActiveExplorer.Selection
 
    For Each objItem In objSelection
        If TypeOf objItem Is MailItem Then
           Set objMail = objItem
           Set objAttachments = objMail.Attachments
           For Each objAttachment In objAttachments
              If LCase(Right(objAttachment.FileName, 4)) = ".csv" Or LCase(Right(objAttachment.FileName, 5)) = ".xlsx" Then
                    saveAsPdfFilename = xl.GetSaveAsFilename(InitialFileName:=strTempFolder, FileFilter:="PDF File (*.pdf), *.pdf", Title:="Save As")
                    If saveAsPdfFilename = False Then Exit Sub
                    strFilePath = strTempFolder & "\" & objAttachment.FileName
                    objAttachment.SaveAsFile strFilePath
                    Set wb = xl.Workbooks.Open(strFilePath)
                    wb.worksheets(1).Columns("A:B").AutoFit
                    wb.ExportAsFixedFormat 0, saveAsPdfFilename '0 = xlTypePDF
                    wb.Close SaveChanges:=False
                    Exit For
              End If
           Next objAttachment
        End If
    Next
    
    Set xl = Nothing
End Sub

Does this help?