I want to select the body of a specific email, copy it and paste it into Outlook.
I know that it would be easier to just press Ctrl + A and then Ctrl + C in the spreadsheet but this is part of a much larger process that involves automation of a report.
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace(”MAPI”)
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
olItms.Sort “Subject”
i = 1
For Each olMail In olItms
If InStr(olMail.Subject, “Criteria") > 0 Then
ThisWorkbook.Sheets("YourSheet").Cells(i, 1).Value = outMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I get a syntax error on:
If InStr(olMail.Subject, “Criteria") > 0 Then
I'd look at two things. First, is the sheet you want to paste the mail body to actually called "YourSheet" and secondly, you're referencing outMail.Body where outMail has never been dimensioned or set. Try this (assuming the sheet to paste to is called "Sheet1").
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = olFldr.Items
olItms.Sort "Subject"
i = 1
For Each olMail In olItms
If InStr(1, olMail.Subject, "Criteria") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Related
The VBA code does not move all emails with a certain words in the Subject "has been updated" and "Item" from the inbox to the subfolder "Neu". Emails should be already read. After 5-6 iterations , all emails will be moved. But why doesn't it work immediately after the first time of code running? Maybe you have faced the same problem? Out of 46 emails, 26 of them are moved firstly, then 39, then 44 and then 46.
Thank you very much in advance!
Sub Emails_Outlook_Transport()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNS As Outlook.Namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olFldr As Outlook.MAPIFolder
Set olFldr = olNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Set Items = olFldr.Items
Dim newFldr As Outlook.MAPIFolder
Set newFldr = olFldr.Folders("Neu")
Dim msg As Object
Dim olMailItem As MailItem
Dim Found As Boolean
On Error Resume Next
For Each msg In Items
If TypeOf msg Is MailItem And msg.UnRead = False Then
Set olMailItem = msg
If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
olMailItem.Move newFldr
End If
End If
Next
End Sub
No error messages, just not a proper work of the code
Problem:
Apparently when the items are moved around, it messes with the item being referred in the loop in case of For Each loop
Solution:
Work a Loop after counting the Items and Backwards.So that each item is referred by an Index.
Try this:
Sub Emails_Outlook_Transport()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNS As Outlook.NameSpace
Set olNS = olApp.GetNamespace("MAPI")
Dim olFldr As Outlook.MAPIFolder
Set olFldr = olNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Set Items = olFldr.Items
Dim newFldr As Outlook.MAPIFolder
Set newFldr = olFldr.Folders("Neu")
Dim msg As Object
Dim olMailItem As MailItem
Dim Found As Boolean
Dim i As Integer
For i = Items.Count To 1 Step -1
If TypeOf Items(i) Is MailItem And Items(i).UnRead = False Then
Set olMailItem = Items(i)
If InStr(olMailItem.Subject, "has been updated") > 0 And InStr(olMailItem.Subject, "Item") > 0 Then
olMailItem.Move newFldr
End If
End If
Next
End Sub
I want to retrieve the content of an email with a certain subject which is linked to a cell value in a different column.
Code from If Outlook Subject and Date Received works with the exception of range.
Instead of one cell value (ex. A1) I want to retrieve from the full column A. So that for each value in column A (which is in this case the date) the content of the e-mail which contains as subject "always the same title" & "date of cells in column A".
Example
A1 = 16/08/2019 ==> e-mail subject = 16/08Title ==> B2 = content of said e-mail
A2 = 20/08/2019 ==> e-mail subject = 20/08Title ==> B2 = content of said e-mail
Sub GetFromInbox ()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = OlFldr.Items
olItms.Sort "Subject"
i =1
For Each olMail In olItms
If InStr (1, olMail.Subject, "Subject" & Range ("A1") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I tried changing Range ("A1") to range ("A:A").
This gives
runtime error 13: Type mismatch
I tried different ways to offset.
Sub GetFromInbox ()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olItms As Outlook.Items
Dim olMail As Variant
Dim i As Long
Set olApp = New Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set olItms = OlFldr.Items
olItms.Sort "Subject"
i =1
For Each olMail In olItms
If InStr (1, olMail.Subject, "Subject" & Range ("A1") > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next olMail
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Create a for loop that will loop through all of the rows of column A.
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
'Finding the last row in Column A
For Each olMail In olItms
For j = 1 To LastRow
If InStr (1, olMail.Subject, "Subject" & Range ("A" & j) > 0 Then
ThisWorkbook.Sheets("Sheet1").Cells(i,2).Value = olMail.Body
i = i + 1
End If
Next j
Next olMail
I want to delete items that are more than 1 day old in a folder, DSP Reports, in Outlook, and I am asked to do this task using vba codes.
Right now, the codes run smoothly and no errors, but nothing is deleted, mails that came in yesterday and today after I ran the code. I used F8 to trouble shoot but still no errors.
Sub DSP_Report_Deletion()
'''''''''''''''''''''''''''''''''''''''''''''
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim i
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("DSP Reports")
Set oItems = olFolder.Items
For i = oItems.Count To 1 Step -1
If DateDiff("d", oItems.Item(i).SentOn, Now) > 1 Then
oItems.Item(i).Delete
End If
Next
'tidy up Outlook
Set olFolder = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Sub
Sub DSP_Report_Deletion()
'''''''''''''''''''''''''''''''''''''''''''''
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim oItems As Outlook.Items
Dim i
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("DSP Reports")
Set oItems = olFolder.Items
For i = oItems.Count To 1 Step -1
If DateDiff("d", oItems.Item(i).SentOn, Now) >= 1 Then
oItems.Item(i).Delete
End If
Next
'tidy up Outlook
Set olFolder = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Sub
I'm trying to get the .To email address from my sent box using Excel-VBA. However, To only returns the name not the email address. After some search found that the recipient should be what I'm looking for. Tried by following the msdn guide, but the code does not seem to work.
Sub test()
Dim objoutlook As Object
Dim objNamespace As Object
Dim olFolder As Object
Dim OutlookMail As outlook.MailItem
Set objoutlook = CreateObject("Outlook.Application")
Set objNamespace = objoutlook.GetNamespace("MAPI")
Set olFolder = objNamespace.GetDefaultFolder(olFolderSentMail)
Set OutlookMail = objoutlook.CreateItem(olMailItem)
Dim recips As outlook.Recipients
Dim recip As outlook.Recipient
Dim pa As outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = OutlookMail.Recipients
For Each recip In recips 'Something is wrong here
Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
Next
Set olFolder = Nothing
Set objNamespace = Nothing
Set objoutlook = Nothing
End Sub
I'm not really familiar with VBA, please guide along.
You can try this:
Private Sub GetRecipientSMTP(objAllRecip As Outlook.Recipients)
Dim objRecip As Outlook.Recipient
Dim objExUser As Outlook.ExchangeUser
Dim objExDisUser As Outlook.ExchangeDistributionList
For Each objRecip In objAllRecip
Select Case objRecip.AddressEntry.AddressEntryUserType
Case 0, 10
Set objExUser = objRecip.AddressEntry.GetExchangeUser
If Not objExUser Is Nothing Then _
Debug.Print objExUser.PrimarySmtpAddress '/* or copy somewhere */
Case 1
Set objExDisUser = objRecip.AddressEntry.GetExchangeDistributionList
If Not objExDisUser Is Nothing Then _
Debug.Print objExDisUser.PrimarySmtpAddress '/* or copy somewhere */
Case Else
'/* Do nothing, recipient not recognized */
End Select
Next
End Sub
You can run it in your sub like below using recips from your code (or see sample usage).
GetRecipientSMTP recips
Basically, this will check on the each Recipient on Recipients you supplied. Then will check if it is an ExchangeUser type or ExchangeDistributionList before returning the PrimartSMTPAddress. HTH.
Sample Usage:
Sub marine()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olMail As Outlook.MailItem
Dim i As Integer
Set olApp = GetObject(, "Outlook.Application") '/* assuming OL is running */
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox)
With olFolder
For i = .Items.Count To 1 Step -1
If TypeOf .Items(i) Is MailItem Then
Set olMail = .Items(i)
GetRecipientSMTP olMail.Recipients
End If
Exit For '/* I just want to process the first mail */
Next
End With
End Sub
Note: I used early binding and set reference to Outlook Object Library.
Quick Example
Option Explicit
Public Sub Example()
Dim OUTLOOK_APP As Outlook.Application
Dim olNs As Outlook.Namespace
Dim SENT_FLDR As MAPIFolder
Dim Items As Outlook.Items
Dim olRecip As Outlook.Recipient
Dim olRecipAddress As String
Dim i As Long
Set OUTLOOK_APP = New Outlook.Application
Set olNs = OUTLOOK_APP.GetNamespace("MAPI")
Set SENT_FLDR = olNs.GetDefaultFolder(olFolderSentMail)
Set Items = SENT_FLDR.Items
For i = Items.Count To 1 Step -1
DoEvents
If Items(i).Class = olMail Then
For Each olRecip In Items(i).Recipients
olRecipAddress = olRecip.Address
Debug.Print olRecipAddress
Next
End If
Next
End Sub
this is my way of getting Recipient email Address. I hope it would help you.
Sub CopyCurrentContact()
Dim objRcp As Outlook.Recipient
Dim objRcpS As Outlook.Recipients
Dim rcpStr As String
Set outLookObj = CreateObject("Outlook.Application")
Set InspectorObj = outLookObj.ActiveInspector
Set ItemObj = InspectorObj.CurrentItem
Set objRcpS = ItemObj.Recipients
For Each objRcp In objRcpS
rcpStr = objRcp.Address & "; " & rcpStr
Debug.Print rcpStr
Next objRcp
End Sub
The code found in this thread works fine for single email results: Excel VBA for searching in mails of Outlook, But it only returns the latest email.
Is it possible to adjust the code to display more than 1 result?
The code that I have from the thread is:
Option Explicit
Public Sub search_outlook()
Dim outlookapp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim projIDsearch As String
projIDsearch = ActiveCell.Cells(1, 4)
Set outlookapp = CreateObject("Outlook.Application")
'Set outlookapp = New Outlook.Application
Set olNs = outlookapp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("ExemptionReview")
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Display
Exit For
End If
Next
End Sub
Remove the Exit For. This drops out of the loop when a match is found:
olMail.Display
Exit For '<Remove this