I'm trying to pull in data that is set up like a table from my email. Does anyone know how I can loop through the email contents to check for tables, and if there is to export the data to columns in Excel? Right now the code I have just returns the subject, sender and time sent.
Sub GetMCInboxLeads()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim n As Long
Dim rh As Double
Dim objOwner As Outlook.Recipient
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set objOwner = ns.CreateRecipient("xx#xxx.com")
objOwner.Resolve
If objOwner.Resolved Then
Set fol = ns.GetSharedDefaultFolder(objOwner, olFolderInbox)
End If
Worksheets.Add
rh = Range("A1").RowHeight
'i = 1
For Each i In fol.Items
If i.Class = olMail Then
n = n + 1
Set mi = i
'Debug.Print mi.Subject, mi.SenderName, mi.ReceivedTime
Cells(n, 1).Value = mi.SenderName
Cells(n, 2).Value = mi.Subject
Cells(n, 3).Value = mi.ReceivedTime
Cells(n, 4).Value = mi.Body
End If
Next i
Range("A1").CurrentRegion.EntireColumn.AutoFit
Range("A1").CurrentRegion.EntireRow.RowHeight = rh
Related
I'd like to create an Outlook calendar meeting request each time a workbook is saved.
The meeting requests need to be added to a shared mailbox so that all users that have access see the meeting invite.
So far it adds an entry to my personal calendar.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olApp.CreateItem(olAppointmentItem)
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Update:
I managed to get this. The problem now is that it'll only create the calendar entry for the last line.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
Dim olApp As Object 'create outlook application
Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object 'get namespace
Set olNS = olApp.GetNamespace("MAPI")
Dim olAppItem As Outlook.AppointmentItem
Dim myRequiredAttendee As Outlook.Recipient
'define constants if using late binding
Const olFolderCalendar As Long = 9
Const olAppointmentItem As Long = 1
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
Set olAppItem = olRecItems.Items.Add(olAppointmentItem)
Dim strFilter As String 'filter for appointments
Dim olFilterRecItems As Object 'filtered appointments
Dim iRow As Long
iRow = 3
Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
If olFilterRecItems.Count = 0 Then 'if subject does not exist
With olAppItem
Set myRequiredAttendee = .Recipients.Add("email address")
myRequiredAttendee.Type = olRequired
.MeetingStatus = olMeeting
.ReminderMinutesBeforeStart = 30
.Subject = ws.Cells(iRow, 4).Value
.Start = ws.Cells(iRow, 3).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Send
End With
ws.Cells(iRow, 3).Interior.ColorIndex = 50
End If
iRow = iRow + 1
Loop
End Sub
Instead of the following code:
Dim olRecItems As Object 'get all appointments
Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
You need to use the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. This method is used in a delegation scenario, where one user has delegated access to another user for one or more of their default folders (for example, their shared Calendar folder). For example:
Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
I am trying output a list of everyone that has emailed me, and the count of emails they sent.
I have two email accounts set up on Outlook (account A and account B). The below VBA outputs a count of users from the inbox folder for account A.
Is there a way to retrieve this data from a folder called 'Done' for Account B?
Sub CountInboxEmailsbySender()
Dim objDictionary As Object
Dim objInbox As Outlook.Folder
Dim i As Long
Dim objMail As Outlook.MailItem
Dim strSender As String
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Dim varSenders As Variant
Dim varItemCounts As Variant
Dim nLastRow As Integer
Set objDictionary = CreateObject("Scripting.Dictionary")
Set objInbox = Outlook.Application.Session.Accounts.Item("edr.hub#bt.com")
For i = objInbox.Items.Count To 1 Step -1
If objInbox.Items(i).Class = olMail Then
Set objMail = objInbox.Items(i)
strSender = objMail.SenderEmailAddress
If objDictionary.Exists(strSender) Then
objDictionary.Item(strSender) = objDictionary.Item(strSender) + 1
Else
objDictionary.Add strSender, 1
End If
End If
Next
Set objExcelApp = CreateObject("Excel.Application")
objExcelApp.Visible = True
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets(1)
With objExcelWorksheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Count"
End With
varSenders = objDictionary.Keys
varItemCounts = objDictionary.Items
For i = LBound(varSenders) To UBound(varSenders)
nLastRow = objExcelWorksheet.Range("A" & objExcelWorksheet.Rows.Count).End(xlUp).Row + 1
With objExcelWorksheet
.Cells(nLastRow, 1) = varSenders(i)
.Cells(nLastRow, 2) = varItemCounts(i)
End With
Next
objExcelWorksheet.Columns("A:B").AutoFit
End Sub
I want to import the appointments in a shared group Outlook calendar to Excel.
I used the GetSharedDefaultFolder but I received the following error:
You can not open the mailbox because this address book entry does not match an email user.
Sub ResolveName()
' déclaration des variables
Dim outlookApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.folder
Dim calendarApp As Outlook.AppointmentItem
Dim calendarItem As Outlook.Items
Dim i As Long
Set outlookApp = New Outlook.Application
Set myNamespace = outlookApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("dp-TECCR-FormationdesrepartiteursCCRediteurs#hydro.qc.ca")
i = 2
myRecipient.Resolve
Range("A1:D1").Value = Array("Subject", "from", "date", "location")
If myRecipient.Resolved Then
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
For Each calendarApp In CalendarFolder.Items
Cells(i, 1).Value = calendarItem.Subject
Cells(i, 2).Value = calendarItem.Start
Cells(i, 3).Value = calendarItem.End
Cells(i, 4).Value = calendarItem.Location
Cells(i, 5).Value = calendarItem.MeetingStatus
i = i + 1
Next
End If
Set outlookApp = Nothing
Set myNamespace = Nothing
Set myRecipient = Nothing
Set CalendarFolder = Nothing
Set calendarItem = Nothing
End Sub
Resolve does nothing when you use an email address.
Use display name / other name property in CreateRecipient if you want to follow up with a useful If myRecipient.Resolved Then.
Option Explicit
Sub ResolveName()
' déclaration des variables
Dim outlookApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder
Dim calendarApp As Outlook.AppointmentItem
Dim calendarItem As Outlook.Items
Dim i As Long
Set outlookApp = New Outlook.Application
Set myNamespace = outlookApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("nothingvalid#hydro.qc.ca")
i = 2
myRecipient.Resolve
'Range("A1:D1").Value = Array("Subject", "from", "date", "location")
If myRecipient.Resolved Then
Debug.Print "Anything that looks like an email address will Resolve."
Debug.Print "Use display name / other name property."
'Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
'For Each calendarApp In CalendarFolder.Items
' Cells(i, 1).Value = calendarItem.Subject
' Cells(i, 2).Value = calendarItem.Start
' Cells(i, 3).Value = calendarItem.End
' Cells(i, 4).Value = calendarItem.Location
' Cells(i, 5).Value = calendarItem.MeetingStatus
' i = i + 1
' Next
End If
Set outlookApp = Nothing
Set myNamespace = Nothing
Set myRecipient = Nothing
Set CalendarFolder = Nothing
Set calendarItem = Nothing
End Sub
I loop through information in an Excel sheet to create appointments in Outlook. It was working when I sent it to my default folder.
I made changes to upload the data to a specific folder (shared by coworkers).
Since then, as I F8 through my code, it saves the appointment for the row being looped through. However, when I go to the next row, the new appointment replaces the old instead of both being saved.
Sub ExportToOutlook
Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _
r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count,1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("Insert the ID").Items.Add(olAppointmentItem)
For i = 2 to r
With oFolder
.Subject = ES.Cells(i,1).Value
.Start = ES.Cells(i,2).Value
.End = ES.Cells(i,3).Value
.Location = ES.Cells(i,4).Value
.AllDayEvent = ES.Cells(i,5).Value
.Categories = ES.Cells(i,6).Value & " Category"
.Save
End With
Next i
Set OL = Nothing
End Sub
You seem to be reupdating the same folder at each row iteration. Try the following:
Sub ExportToOutlook
Dim OL as Outlook.Application, Appoint as Outlook.AppointmentItem, ES as Worksheet, _
r as Long, i as Long, WB as ThisWorkook, oFolder as Object, o NameSpace as Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count,1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("Insert the ID")
For i = 2 to r
Dim appt as MailItem
Set appt = oFolder.Items.Add(olAppointmentItem)
With appt
.Subject = ES.Cells(i,1).Value
.Start = ES.Cells(i,2).Value
.End = ES.Cells(i,3).Value
.Location = ES.Cells(i,4).Value
.AllDayEvent = ES.Cells(i,5).Value
.Categories = ES.Cells(i,6).Value & " Category"
.Save
End With
Next i
Set OL = Nothing
End Sub
Dim appt as Outlook.AppointmentItem was the fix for me!
Sub ExportToOutlook2()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook, oFolder As Object, oNameSpace As Namespace
Set WB = ThisWorkbook
Set ES = WB.Sheets("Export Sheet")
r = ES.Cells(Rows.count, 1).End(xlUp).Row
Set OL = New Outlook.Application
Set oNameSpace = OL.GetNamespace("MAPI")
Set oFolder = oNameSpace.GetFolderFromID("00000000579E67EAD9C2C94591E62A3CF21135F801001241364BFDA9AF49A3D3384A976997C50036FCD700060000")
For i = 2 To r
Dim appt As Outlook.AppointmentItem
Set appt = oFolder.Items.Add(olAppointmentItem)
With appt
.Subject = ES.Cells(i, 1).Value
.Start = ES.Cells(i, 2).Value
.End = ES.Cells(i, 3).Value
.Location = ES.Cells(i, 4).Value
.AllDayEvent = ES.Cells(i, 5).Value
.Categories = ES.Cells(i, 6).Value
.Save
End With
Next i
Set OL = Nothing
End Sub
How can I send mails automatically based on criteria?
I want to open the mail based on the subject provided in column A, add default content and forward this mail to the email address provided in Column B.
I know how to open an Outlook mail based on the subject.
Sub Test()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
Subject (column A) Send to (Column B)
SP12345667 aaa#gmail.com
SP12345668 bbb#gmail.com
SP12345669 xxx#abc.com
SP12345670 yyy#abc.com
SP12345671 mmm#abc.com
SP12345672 nnn#abc.com
SP12345673 yyy#abc.com
Here is an Example on how to loop...
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As MailItem
Dim MsgFwd As MailItem
Dim Items As Outlook.Items
Dim Recip As Recipient
Dim Email As String
Dim ItemSubject As String
Dim lngCount As Long
Dim i As Long
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
i = 2 ' i = Row 2
With Worksheets("Sheet1") ' Sheet Name
Do Until IsEmpty(.Cells(i, 1))
ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1)
Email = .Cells(i, 2).Value '(i, 2) = (Row 2,Column 2)
'// Loop through Inbox Items backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
If Item.Subject = ItemSubject Then ' if Subject found then
Set MsgFwd = Item.Forward
Set Recip = MsgFwd.Recipients.Add(Email) ' add Recipient
Recip.Type = olTo
MsgFwd.Display
End If
Next ' exit loop
i = i + 1 ' = Row 2 + 1 = Row 3
Loop
End With
Set olApp = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set Item = Nothing
Set MsgFwd = Nothing
Set Items = Nothing
End Sub