My folder is called "Request Mailbox" in Outlook
How can I get a list of all mailitems in that folder
To get list of MailItems, you can simply do this
MailItem list will be displayed as Email
Option Explicit
Sub MailItems()
Dim olNamespace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Set olNamespace = Application.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("Request Mailbox")
Set olItem = Application.CreateItem(olMailItem) ' Creat EMail
With olItem
For Each olItem In olFolder.Items
Debug.Print olItem.Subject ' Print to immediate window
.body = .body & olItem.Subject & vbCrLf ' Print to Email
Debug.Print olItem.SenderName
.body = .body & olItem.SenderName & vbCrLf
Debug.Print olItem.ReceivedTime
.body = .body & olItem.ReceivedTime & vbCrLf & vbCrLf
Next ' vbCrLf = vb: Visual Basic Cr: Carriage Return Lf: LineFeed
.Subject = "Mail Items" ' Subject
.Display ' Display Msg
End With
End Sub
For Shared Folder Try this
Option Explicit
Sub ShareMailItems()
Dim olNamespace As Outlook.NameSpace
Dim olShareName As Outlook.Recipient
Dim olShareInbox As Outlook.Folder
Dim olItem As Outlook.MailItem
Set olNamespace = Application.GetNamespace("MAPI")
Set olShareName = olNamespace.CreateRecipient("0m3r#email.com") '// Owner's email address
Set olShareInbox = olNamespace.GetSharedDefaultFolder( _
olShareName, olFolderInbox).Folders("Request Mailbox") '// FolderName
Set olItem = Application.CreateItem(olMailItem) ' Creat EMail
With olItem
For Each olItem In olShareInbox.Items
Debug.Print olItem.Subject ' Print to immediate window
.body = .body & olItem.Subject & vbCrLf ' Print to Email
Debug.Print olItem.SenderName
.body = .body & olItem.SenderName & vbCrLf
Debug.Print olItem.ReceivedTime
.body = .body & olItem.ReceivedTime & vbCrLf & vbCrLf
Next ' vbCrLf = vb: Visual Basic Cr: Carriage Return Lf: LineFeed
.Subject = "Mail Items" ' Subject
.Display ' Display
End With
End Sub
For a delegate mailbox already open in Outlook, use Application.Session.Folders.("TheDelegateMialboxName#YourCompany.com").Folders("TheFolderName")
Related
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "a22550#stuart.iit.edu"
.Subject = "Report of Fixed Income" & Format(Now() - 1, "mmmm dd,yyyy")
.Body = "Dear Sir" & vbNewLine & Format(Now() - 1, "mmmm dd,yyyy") &
"Please regard the following tables:" & vbNewLine &
"Thank you!"
.Attachments.Add "C:\Users\008425\Desktop\Fixed Income--2020.05.13.xlsm
'word Editor
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = objMail.GetInspector.WordEditor
wdDoc.Application.Selection.Start = Len(.Body)
I tried to Copy my excel range to Outlook mail with the my greeting description in the beginning and come next my excel copy range as a picture...After I run this syntax, my greeting skip to the end of the mail body just like signature..
Does anyone know hot to set sequences greetings→ paste charts→signatures from start to end in the outlook mail body by VBA?
[ wdDoc.Application.Selection.Start = Len(.Body)] is not right
Private Sub test()
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Dim defSignature As String
With objMail
.Display ' Bring the signature to the body
defSignature = objMail.Body ' Save the signature
' Replace the body
.Body = "Dear Sir" & vbNewLine & Format(Now() - 1, "mmmm dd,yyyy") & _
"Please regard the following tables:" & vbNewLine & vbNewLine
'.Attachments.Add "C:\Users\008425\Desktop\Fixed Income--2020.05.13.xlsm"
'word Editor
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = objMail.GetInspector.WordEditor
' Move the cursor to the end of the body
wdDoc.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
' Insert after the cursor
wdDoc.Application.Selection.InsertAfter "This should be inserted after current body."
objMail.Body = objMail.Body & vbNewLine & "Thank you!" & defSignature
End With
End Sub
I have working code that replies to an email in the user's Outlook, based on the subject. If the most recent item is a meeting invite, my code will not retrieve the email I want. Instead it will not pass the meeting invite and will display an error.
Code is as follows.
Sub Display()
Dim Fldr As Outlook.Folder
Dim olfolder As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
Dim olReply As Outlook.MailItem
Dim olItems As Outlook.Items
Dim i As Integer
Dim signature As String
Set Fldr = Session.GetDefaultFolder(olFolderInbox)
Set olItems = Fldr.Items
olItems.Sort "[Received]", True
For i = 1 To olItems.Count
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then
signature = signature & Dir$(signature & "*.htm")
Else:
signature = ""
End If
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
Set olMail = olItems(i)
If InStr(olMail.Subject, Worksheets("Checklist Form").Range("B8")) <> 0 Then
If Not olMail.Categories = "Executed" Then
Set olReply = olMail.ReplyAll
With olReply
.HTMLBody = "<p style='font-family:calibri;font-size:14.5'>" & "Hi Everyone," & "<p style='font-family:calibri;font-size:14.5'>" & "Workflow ID:" & " " & Worksheets("Checklist Form").Range("B6") & "<p style='font-family:calibri;font-size:14.5'>" & Worksheets("Checklist Form").Range("B11") & "<p style='font-family:calibri;font-size:14.5'>" & "Regards," & "</p><br>" & signature & .HTMLBody
.Display
.Subject = "RO Finalized WF:" & Worksheets("Checklist Form").Range("B6") & " " & Worksheets("Checklist Form").Range("B2") & " -" & Worksheets("Fulfillment Checklist").Range("B3")
End With
Exit For
olMail.Categories = "Executed"
End If
End If
Next i
End Sub
Is it possible to bypass the most recent item if the code will not pass the first email. Example: Meeting Invite
Dim olMail As Outlook.MailItem
...
Set olMail = olItems(i)
That Set assignment will not only fail if the first item is a meeting invite, it will fail for any olItems(i) (i.e. any value of i) that is not an Outlook.MailItem instance. That includes anything that can possibly land into an Outlook inbox, including a meeting invite.
One way to go would be to handle the runtime error that's thrown in the specific case where olItems(i) isn't a MailItem:
For i = 1 To olItems.Count
On Error GoTo ErrHandler ' jumps to error-handling subroutine if there's an error
Set olMail = olItems(i)
On Error GoTo 0 ' let any other error blow everything up
...
SkipToNext:
Next i
Exit Sub
ErrHandler:
Debug.Print "Item index " & i & " is not a MailItem; skipping."
Resume SkipToNext
Notice I'm putting the assignment/validation as early as possible in the loop - that way you don't run useless instructions if you're not looking at a MailItem.
Another - better - way to go about it, would be to validate the type of olItems(i):
Dim olItem As Object
'...
For i = 1 To olItems.Count
Set olItem = olItems(i)
If Not TypeOf olItem Is Outlook.MailItem Then Goto SkipToNext
Set olMail = olItem ' essentially a type cast from Object to MailItem
...
SkipToNext:
Next
Alternatively, you can drop that GoTo jump and increase the nesting level instead:
For i = 1 To olItems.Count
Set olItem = olItems(i)
If TypeOf olItem Is Outlook.MailItem Then
Set olMail = olItem ' essentially a type cast from Object to MailItem
...
End If
Next
Note the indentation; feel free to use an indenter if you're not sure how to do this correctly & consistently. Proper indentation is critical for code readability, especially given nested looping & conditional structures (disclaimer: I own that website and the OSS project it's for).
I have written a working code to reply to an email in certain format, however the result is missing some info for the last received email in the Html body (From, sent, to, cc, subject. I'm not even sure if this is called the mail header).
If I click on the Outlook 2013 default 'reply' button, these info would have been auto-generated ahead of the last email, while above it would then be my reply content.
So which function should I use to call these info out? The info must appear in all my replies, so I need to figure it out one way or the other. My code:
'there is a getsignature function before the code.
Public Sub my_reply()
Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Outlook.Selection
Dim objMail As Outlook.mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
objMsg.Categories = "Category A"
Set myreply = objMsg.Reply
myreply.To = objMsg.SenderEmailAddress
myreply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myreply.Subject = "XYZ matter" & objMsg.Subject
myreply.Display
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Release:
Set objMsg = Nothing
Set oExplorer = Nothing
End If
Next
End Sub
ReplyAll should get the cc. If you are only concerned about missing text ignore this.
Set myReply = objMsg.ReplyAll
You are overwriting the initial myreply.HTMLBody with objMsg.HTMLBody
myreply.HTMLBody = StrSignature & "<br><br>" & objMsg.HTMLBody
Instead append to the initial myreply.HTMLBody
Option Explicit
Public Sub my_replyAll()
'Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objSelection As Selection
'Dim objMail As Outlook.mailitem
Dim myReply As mailitem
Dim StrSignature As String
StrSignature = GetSignature("C:\Users\xxx\xxx\Microsoft\Signatures\ABC.htm")
' Set objOL = CreateObject("Outlook.Application")
'Set objSelection = objOL.ActiveExplorer.Selection
Set objSelection = ActiveExplorer.Selection
For Each objMsg In objSelection
If objMsg.Class = olMail Then
Set myReply = objMsg.ReplyAll
myReply.To = objMsg.SenderEmailAddress
myReply.BCC = "xxx#abc" & " ; " & "xxx#abc"
myReply.Subject = "XYZ matter " & objMsg.Subject
myReply.Display
'myReply.HtmlBody = StrSignature & "<br><br>" & objMsg.HtmlBody
myReply.HtmlBody = StrSignature & "<br><br>" & myReply.HtmlBody
Release:
Set objMsg = Nothing
End If
Next
End Sub
I'm trying to create a macro where I can save the attachments from an email. The problem I'm currently having is that I want the macro to add the ReceivedTime of the email on the file name it saves (i.e.: File TESTSHEET.xls was received on 2016-01-01 3:02AM. I want the saved file to show 201601010302AM-TESTSHEET.xls or something similar)
Here's my current code:
Public itm As Object
Public Sub saveAttachtoDisk()
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\Username\Documents\TEST REPORTS"
For Each objAtt In itm.Attachments
objAtt.SaveAsFile objAtt.DisplayName
Next objAtt
End Sub
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 objDate As String
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim StrDate As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Set itm = Application.CreateItem(olMailItem)
Dim CurrentMsg As Outlook.MailItem
' Get the path to your My Documents folder
strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
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
' Set the Attachment folder.
strFolderpath = strFolderpath & "\TEST REPORTS\"
' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
' This code only strips attachments from mail items.
' If objMsg.class=olMail Then
' Get the Attachments collection of the item.
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
' We need to 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
' Save attachment before deleting from item.
' Get the file name.
strFile = objAttachments.Item(i).FileName
' Combine with the path to the Save folder.
StrDate = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
strFile = strFolderpath & StrDate & strFile
' Save the attachment as a file.
MsgBox strFile
objAttachments.Item(i).SaveAsFile strFile
' Delete the attachment.
objAttachments.Item(i).Delete
'write the save as path to a string to add to the message
'check for html and use html tags in link
If objMsg.BodyFormat <> olFormatHTML Then
strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
Else
strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
strFile & "'>" & strFile & "</a>"
End If
'Use the MsgBox command to troubleshoot. Remove it from the final code.
'MsgBox strDeletedFiles
Next i
' Adds the filename string to the message body and save it
' Check for HTML body
If objMsg.BodyFormat <> olFormatHTML Then
objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body
Else
objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody
End If
objMsg.Save
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Thank you in advance for your help!!
Use objMsg not itm.
' StrDate = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
StrDate = Format(objMsg.ReceivedTime, "yyyy-mm-dd Hmm ")
Additionally drop other code with itm and as well objOL
' Set itm = Application.CreateItem(olMailItem)
' Dim CurrentMsg As Outlook.MailItem
' On Error Resume Next
' Instantiate an Outlook Application object.
' Set objOL = CreateObject("Outlook.Application")
Do not use On Error Resume Next until you know what you are doing.
im sorry i am a little new here. I have been spending days trying to incorporate my current code which works to send an email based on information in a form. Like a "send email" button. It prefils with the correct information however, my record set has attachments that i cant seem to code properly. ive been reading attachment code for the last 5 days i cant seem to understand how to incorporate it in my current code. I would just like the attachment that is saved in my record to be included in my email. Here is my current code, could someone walk me through how to include an attachment code in there? Thank you so much in advance!!
Private Sub btnEmail_Click()
Dim objOutlook As Object
Dim objOutlookMsg As Object
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
objOutlookRecip.Type = olTo
' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Michael Suyama")
objOutlookRecip.Type = olCC
' Add the BCC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
objOutlookRecip.Type = olBCC
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message."
.Importance = olImportanceHigh 'High importance
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
.Display
' .Save
' .Send
End With
Set objOutlook = Nothing
End Sub
Function SaveAttachment()
Dim db As DAO.Database
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
Dim intz As Integer
Set db = CurrentDb
Set rst = db.OpenRecordset("site inspections table", dbOpenDynaset)
rst.FindFirst "ID = " & Me!ID
Set rstAttachment = rst.Fields("Photos").Value
Set fld = rstAttachment.Fields("Filedata")
strPath = CurrentProject.Path & "\Attach\" _
& rstAttachment.Fields("Filename")
On Error Resume Next
Kill strPath & "\Attach\"
On Error GoTo 0
fld.SaveToFile strPath
rstAttachment.Close
rst.Close
Set rstAttachment = Nothing
Set rst = Nothing
Set db = Nothing
End Function
Private Sub cmdEmail_Click()
Dim outlookApp As Outlook.Application
Dim outlookNamespace As NameSpace
Dim objMailItem As MailItem
Dim objFolder As MAPIFolder
Dim strAttachementPath As String
Dim rst As DAO.Recordset2
Dim rstAttachment As DAO.Recordset2
Dim db As DAO.Database
Dim strHTML
'Call SaveAttachment
Set outlookApp = CreateObject("Outlook.Application")
Set outlookNamespace = outlookApp.GetNamespace("mapi")
Set objFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
Set objMailItem = objFolder.Items.Add(olMailItem)
Set db = CurrentDb
Set rst = db.OpenRecordset("site inspections table", dbOpenDynaset)
rst.FindFirst "ID = " & Me!ID
Set rstAttachment = rst.Fields("Photos").Value
'strAttachementPath = CurrentProject.Path & "\Attach\" _
' & rstAttachment.Fields("Filename")
' Build HTML for message body.
strHTML = "<HTML><HEAD>"
strHTML = "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>ID: </b></br>" & [ID] & "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Date: </b></br>" & [Date] & "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Time: </b></br>" & [Time] & "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Technician: </b></br>" & [Technician] & "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Area: </b></br>" & [Area] & "<br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Blast No.: </b></br>" & [shot number] & "<br><br>"
strHTML = strHTML & "<FONT Face=Calibri><b>Comments: </b></br>" & [Comments] & "<br>"
strHTML = strHTML & "</FONT></br><BODY>"
'strHTML = strHTML & "<FONT Face=Arial Color=#ff0000 Size=5>Job #: 123456</FONT></br>"
'strHTML = strHTML & "<FONT Size=3>For: <FONT Size=2></B>a name here</br>"
'strHTML = strHTML & "<FONT Size=3><B>Description: </B><FONT Size=2>description of work to be
strHTML = strHTML & "</BODY></HTML>"
' Build the Email to be sent
With objMailItem
.BodyFormat = olFormatHTML
.To = "EMAIL ADDRESS HERE"
.Subject = "Site Inspection for " & [Area] & " At " & [Date]
' .Body = "Some text here"
.HTMLBody = strHTML
' Grab Attachments for Email if there are any
If rstAttachment.RecordCount > 0 Then
Call SaveAttachment
strAttachementPath = CurrentProject.Path & "\Attach\" _
& rstAttachment.Fields("Filename")
.Attachments.Add (strAttachementPath)
End If
.Display
End With
outlookApp.ActiveWindow
'SendKeys ("%s")
MsgBox "Mail Sent!", vbOKOnly, "Mail Sent"
objOutlookMsg.Attachments.Add("c:\temp\MyTestFile.txt")
is all it takes.