Below code saves all items in an outlook folder to my desktop as PDFs. One flaw, The heading of the last email in the string is cut off. So when i send out vottingOptions, the PDF comes up blank for the response. Any ideas? Thank you.
Dim outApp As Object, objOutlook As Object, objFolder As Object, myItems As Object, myItem As Object
Dim psName As String, pdfName As String
Set outApp = CreateObject("Outlook.Application")
Set objOutlook = outApp.GetNamespace("MAPI")
Set objFolder = objOutlook.GetDefaultFolder(olFolderInbox).Folders("PDF Conversion")
Set myItems = objFolder.Items
FolderPath = "C:\Users\E086365\Desktop\Suz Macros\PDF Emails\"
Dim objDoc As Object, objInspector As Object
For Each myItem In myItems
FileName = Replace(myItem.SenderName, ":", "") & " - " & Replace(myItem.Subject, ":", "") & " - " & Replace(Replace(myItem.ReceivedTime, ":", ""), "/", "-")
Set objInspector = myItem.GetInspector
Set objDoc = objInspector.WordEditor
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Set objInspector = Nothing
Set objDoc = Nothing
Next myItem
End Sub```
First of all, there is no need to create a new Outlook Application instance if the code is run in Outlook. Instead, use the built-in Application property:
Set objOutlook = Application.GetNamespace("MAPI")
In the code, I also recommend checking the file path string after all replacing operations run against values:
objDoc.ExportAsFixedFormat FolderPath & FileName & ".pdf", 17
Related
Every day I receive hundreds of emails with pdf attachments of invoices that I need to print off.
Currently, I print them off manually and it takes me upwards of a couple hours a day.
How do I auto print attachment in the emails using Outlook-vba and then delete that email.
Add Microsoft Scripting Runtime to References...
Create New Rule, then click on Apply rule on messages I receive / which has an attachment / run a script
Option Explicit
Public Sub Example(Item As Outlook.MailItem)
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject
'Temporary Folder
Dim TempFldr As String
TempFldr = Environ("USERPROFILE") & "\Documents\Temp\"
CreateDir TempFldr
Dim Atmt As Attachment
Dim AtmtName As String
Dim oShell As Object
Dim Fldr As Object
Dim FldrItem As Object
For Each Atmt In Item.Attachments
AtmtName = TempFldr & Atmt.FileName
Atmt.SaveAsFile AtmtName
Set oShell = CreateObject("Shell.Application")
Set Fldr = oShell.NameSpace(0)
Set FldrItem = Fldr.ParseName(AtmtName)
FldrItem.InvokeVerbEx ("print")
Next Atmt
'Cleans up
If Not FSO Is Nothing Then Set FSO = Nothing
If Not Fldr Is Nothing Then Set Fldr = Nothing
If Not FldrItem Is Nothing Then Set FldrItem = Nothing
If Not oShell Is Nothing Then Set oShell = Nothing
End Sub
Private Function CreateDir(FldrPath As String)
Dim Elm As Variant
Dim CheckPath As String
CheckPath = ""
For Each Elm In Split(FldrPath, "\")
CheckPath = CheckPath & Elm & "\"
If Len(Dir(CheckPath, vbDirectory)) = 0 Then
MkDir CheckPath
Debug.Print CheckPath & " Folder Created"
End If
Debug.Print CheckPath & " Folder Exist"
Next
End Function
I create a folder with VBA.
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Folder File
Set fso = CreateObject("Scripting.FileSystemObject")
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
fldrname = Mailobject.To
fldrpath = "\\abc\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set objCopy = Mailobject.Copy
objCopy.SaveAs fldrpath, olMSG
Next
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
When I try to use
Mailobject.SaveAs fldrpath, olMSG
to save the mail into the folder, I cannot write to file.
Right clicking the folder, and then clicking properties on the shortcut menu to check permission of the folder, I see attribute as Read Only.
Could you please help me figure out the alternative?
You must pass a fully qualified file name to SaveAs. You are passing just the folder name:
objCopy.SaveAs fldrpath & "\test.msg", olMSG
fldrpath = "\\abc\" & fldrname &
"\"
savepath = fldrpath & Mailobject.Subject & Format(Now(), "yyyy-mm-dd-
hhNNss")
savepath = savepath & ".msg"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set objCopy = Mailobject.Copy
objCopy.SaveAs savepath, olMSG
I am working on a code which attachment will be download to folder location in context to subject by using a subject filter.
After a long search on the internet, my code is working but the problem here is that I want to put the keyword in the subject filter so that it will download the attachment as the subject keep changing every day
e.g. Sub: training_24357 on one day and training_24359 on the next day.
Also, I want to run my code after every 5 minutes automatically, any help will be much appreciated,
below is my code.
Sub Attachment()
Dim OutOpened As Boolean
Dim App As Outlook.Application
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Dim Attach As Outlook.Attachment
Dim Item As Object
Dim MailItem As Outlook.MailItem
Dim subject As String
Dim saveFolder As String
Dim dateFormat As String
saveFolder = "D:\Outlook\POS Visit Report"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
subject = """*POS Visit*"""
OutOpened = False
On Error Resume Next
Set App = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set App = New Outlook.Application
OutOpened = True
End If
On Error GoTo 0
If App Is Nothing Then
MsgBox "Cannot Start Outlook Mail", vbExclamation
Exit Sub
End If
Set Ns = App.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
If Not olFolder Is Nothing Then
For Each Item In olFolder.Items
If Item.Class = Outlook.ObjectClass.olMail Then
Set MailItem = Item
If MailItem.subject = subject Then
Debug.Print MailItem.subject
For Each Attach In MailItem.Attachments
dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
Next
End If
End If
Next
End If
If OutOpened Then App.Quit
Set App = Nothing
End Sub
To Search for Items with Attachment and by Subject line you can use Items.Restrict Method to filter Items collection containing all the match from the filter
Filter Example: [Attachment & Subject Like '%training%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%training%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
VBA Example https://stackoverflow.com/a/42547062/4539709 Or https://stackoverflow.com/a/42777485/4539709
Now if your running the code from Outlook then you do not need to GetObject, or Set App = New Outlook.Application Just simply Set Ns = Application.GetNamespace("MAPI")
To run your code when Items are added to you Inbox - Try working with Application.Startup Event (Outlook) And Items_ItemAdd Event (Outlook)
Items.ItemAdd Event Occurs when one or more Items are added to the specified collection. This event does not run when a large number of items are added to the folder at once.
Code Example:
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
'// call sub here
End If
End Sub
I have some code that searches the rfin#example.com inbox for messages with a certain subject and then debug prints the subject to the console, I'd like to add code that saves the attachments of those emails flagged by the search. The MSDN documentation was vague on this issue.
The area I'm looking for help with is commented out with '### about 12 lines from the bottom
Sub Search_Inbox()
'This subroutine searchest the RFin Inbox for the prior month's Acting / Additional forms
'Then it saves the .xlsx attachments
Dim objNamespace As Outlook.NameSpace
Dim olShareName As Outlook.Recipient
Dim myDestFolder As Outlook.Folder
Dim objFolder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim filteredItems As Outlook.Items
Dim itm As Object
Dim Found As Boolean
Dim strFilter As String
Dim mon As String
mon = Format(Date - 30, "mmmm")
Set objNamespace = Application.GetNamespace("MAPI")
Set olShareName = objNamespace.CreateRecipient("rfin#example.com") 'contains secondary address
Set objFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderInbox)
Set DestFolder = objNamespace.GetSharedDefaultFolder(olShareName, olFolderToDo)
strFilter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%" & mon & " Acting / Additional Bonus %'"
Set filteredItems = objFolder.Items.Restrict(strFilter)
If filteredItems.Count = 0 Then
Debug.Print "No emails found"
Found = False
Else
Found = True
' this loop displays the list of emails by subject in the debug console and saves the attachments to the specified folder
dim z as integer
z=0
For Each itm In filteredItems
z=z+1
Debug.Print itm.Subject
'### Insert code here to Open the attachments with .xlsx extensions, if any, in each of the emails found, save them as "[Mon] Acting / Additional Bonus (1 to n).xlsx"
Next
End If
'If the subject isn't found:
If Not Found Then
'NoResults.Show
Else
Debug.Print "Found " & filteredItems.Count & " items."
End If
End Sub
Try something like the following:
for each attach in itm.Attachments
if (attach.Type = olByValue) or (attach.Type = olEmbeddeditem) Then
attach.SaveAsFile "c:\temp\" & itm.FileName
End If
next
I am running the following script on the event that I receive an email from a specific address with a specific subject. The goal is to tag an email with a hyperlink that will be useful for the recipient of said email to have in the original message's body.
Option Explicit
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
'On Error Resume Next
Set objOL = Application
strID = MyMail.EntryID
Set MyMail = Application.Session.GetItemFromID(strID)
If Not MyMail Is Nothing Then
Set objNS = objOL.Session
MyMail.BodyFormat = olFormatHTML
If MyMail.BodyFormat = olFormatHTML Then
MsgBox ("set to html")
End If
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
MsgBox ("Hyperlink appended!")
Else
MsgBox ("Failure!")
End If
End Sub
While I get the message box telling me that the proper event occurred it appears that no actual changes are made (or are not being saved properly?).
This is the first work I have done with any kind of programming. I've gone through some tutorials for VB specifically, but I am very new to this. Any help/guidance is much appreciated!
This is a classic case of needing to use Option Explicit to require explicit variable declarations. Use this, since you are learning VBA. Also avoid the habit of using On Error Resume Next as this ignores all error handling.
You might not realize this but you are referring to your mail item in the following ways:
MyMail
objItem
objMsg
objMail
Note that the following two commands
objMsg.HTMLBody
objMail.Save
are performed on non-existent objects.
Remove the above three extra references:
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
end Sub
You also don't need the cleanup either.