Issue:
Hello, I have a macro, which saves me for a lot of clicking, but in the end not so much time, when it all comes down to it. The code allows me to mark everything within any mail folder. It will print the attachments within the email.
After this the error starts. Whenever I press this button, the items are ready and set to go, for a race to the printer. Meaning that whatever attachment that gets to the printer first, is the one that gets printed first. I then have to put everything in the right order when it has been printed.
My current code:
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
Goal:
I would like the code to look for dates, and print the oldest first, and work its way up for the newest date. Is there by any chance, that I can put in a string, which gets the macro to "cool down" and send it to the printer in order, by the oldest date to the newest?
Related
I am just looking to just save the PDFs from the select email attachments to a folder on my computer. Right now with the code below it is saving all the attachments such as the JPG and htm items. Do I have the selection for PDFs in the incorrect location? It seems after playing around no matter where I am placing the code for selecting PDFs that it isn't actually picking out the PDFs
Sub SavePDFAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim l As Long
Dim lngCount As Long
Dim tlngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim finalpath As String
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = Application
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' Set the Attachment folder.
strFolderpath = "T:"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
' Pull PDFs only
For Each objAttachment In objMsg.Attachments
If Right(objAttachment.FileName, 3) = "pdf" Then
objAttachment.SaveAsFile strFolderpath & strFile
End If
Next objAttachment
lngCount = objAttachments.count
If lngCount > 0 Then
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Please refer to the following code:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\TEST\"
' Check each selected item for attachments.
For Each objMsg In objSelection
For each objAttachment in objMsg.Attachments
if Right(objAttachment.FileName, 3) = "pdf" then
' Append the file name to the folder.
strFile = strFolderpath & objAttachment.FileName
' Save it
objAttachments.Item(i).SaveAsFile strFile
end if
Next objAttachment
Next objMsg
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Save PDF Code:
if Right(objAttachment.FileName, 3) = "pdf" then
For more information, please see the link: VBA save email attachments with pdf extension to folder
I have emails in Outlook 2013, each with only one file attached called "Report.pdf".
I am trying to batch print all of the attachments from my selection of emails.
I found the below code which works if the attachments all have different names. Is it possible to amend this to print nearly 150 attachments which all have the same name?
The names of the reports don't matter, so feel free to add what you need to them inside the code.
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 DateFormat
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
You do not say why the code does not work if all the attachments have the same name. I assume it is because SaveAsFile wants to overwrite the last “Report.pdf” with the next “Report.pdf” before printing is finished.
My first thought was to add Kill strFilePath before the SaveAsFile. On reflection, I decided that would not work because Shell would still be printing the previous “Report.pdf” when you attempted to delete it.
I think the simplest approach would be:
Add
Dim Count as Long
to your Dims.
Replace strFilePath = strTempFolder & "\" & objAttachment.FileName by:
Count = Count + 1
strFilePath = strTempFolder & "\" & Count & objAttachment.FileName
This will create and print files named “1Report.pdf”, “2Report.pdf”, “3Report.pdf” and so on. I have used a prefix rather than the traditional suffix because it saves the bother of placing Count between the file name and the extension.
I assume you have some method of deleting all the attachments from the temporary folder.
I have a VBA script which cycles through selected emails and prints all PDF attachments in said emails.
Currently, the script saves the PDF files to the hard drive and then opens and prints them.
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")
strTempFolder = "W:\my documents\test"
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
If InStr(strFilePath, ".pdf") <> 0 Or InStr(strFilePath, ".PDF") <> 0 Then
objAttachment.SaveAsFile (strFilePath)
Set objShell = CreateObject("Shell.Application")
Set objTempFolder = objShell.NameSpace(0)
Set objTempFolderItem = objTempFolder.ParseName(strFilePath)
objTempFolderItem.InvokeVerbEx ("print") 'try now
End If
Next objAttachment
End If
Next
End Sub
I am wondering if it is possible to execute this code without saving the files to the hard drive, i.e. just opening them from memory in VBA, print them, and have no trace of them on the hard drive?
Even "big" softwares, for example Outlook, are saving PDF-files to a local drive (temp-Folder) to open them in another program.
The problem here is that the PDF-reader needs a reference/path to the file you want to open.
I would suggest to delete the file from the drive after it is printed.
I have the following code which I am using to save an email attachment into a folder. I want to make this vba run automatically each time I open outlook and check all emails in my creditchecks#hewden.co.uk inbox (non default inbox).
At the moment though it only checks the email which is selected in the active inbox. can someone please show me how I can edit my code to get it to do what I need. thanks
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Just need to edit some lines. Use something like objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk") to a folder in the same level of your Inbox folder. Here is your code modified:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
'Set objSelection = objOL.ActiveExplorer.Selection
'Istead set this to the selected objects you just need to set to your email folder
'This is for a inbox same level folder
Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk")
'This is for a folder inside the inbox folder
'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("credutchecks#hewden.co.uk")
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
To run it automatically when the Outlook starts just put it on the 'ThisOutlookSession' in the objects folder and name it 'Sub Application_Startup()'. Don't forget to enable macros before.
I am using the following code to save attachments from an email into a folder, now I want to add a if clause or conditions which says only save attachments with a .pdf extension.
Can someone please show me how I can change my code to get this to happen, thanks in advance
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\TEST\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Temp folder.
strFile = strFolderpath & strFile
' Save the attachment as a file.
objAttachments.Item(i).SaveAsFile strFile
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
You'll want to iterate through the attachments collection on your objMsg to find the PDF.
This will look like:
For each objAttachment in objMsg.Attachments
if Right(objAttachment.FileName, 3) = "pdf" then
objAttachment.SaveAsFile strFolderPath & strFile
end if
Next objAttachment
Just make sure you decalre objAttachment at the top with:
Dim objAttachment as Attachment
Updated with full code from your example:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderpath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\TEST\"
' Check each selected item for attachments.
For Each objMsg In objSelection
For each objAttachment in objMsg.Attachments
if Right(objAttachment.FileName, 3) = "pdf" then
' Append the file name to the folder.
strFile = strFolderpath & objAttachment.FileName
' Save it
objAttachments.Item(i).SaveAsFile strFile
end if
Next objAttachment
Next objMsg
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub