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
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'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
I have the following code set up to create appointments in Outlook from data on my Excel spreadsheet. What I would like to do id make the appointment in a shared calendar rather than my own default one.
The calendar I want to add it to is the DTS Streetworks one as shown here - https://ibb.co/tKXKSPX, but I have no idea how to go about it.
Sub CoringAdd()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Coring")
Set OL = New Outlook.Application
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To r
With ES.Cells(i, 10)
If .Value = "No" And ES.Cells(i, 7) <> "Yes" Then
ES.Cells(i, 7) = "Yes"
With OL.CreateItem(olAppointmentItem)
.Subject = "Send reminder email - LBRuT " + ES.Cells(i, 2).Value
.Start = ES.Cells(i, 6) + 1 + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set wb = Nothing
Set ES = Nothing
End Sub
UPDATE:
Latest code below, still goes to default calendar.
Sub ResolveName()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, wb As ThisWorkbook
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Set OL = New Outlook.Application
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If myRecipient.Resolved And .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
With OL.CreateItem(olAppointmentItem)
.Subject = "Test " + ES.Cells(i, 4).Value
.Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
End Sub
Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.MAPIFolder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
You can get the shared calendar by using the NameSpace.GetSharedDefaultFolder method which returns a Folder object that represents the specified default folder for the specified user. For example:
Sub ResolveName()
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.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.MAPIFolder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
CalendarFolder.Display
End Sub
When you get a shared calendar folder you may use the Items.Add method which creates a new Outlook item in the Items collection for the folder. You just need to pass an item type you need to create, for example, olAppointmentItem.
Set myItem = mySharedCalendarFolder.Items.Add olAppointmentItem
So, your code should look like this:
Set wb = ThisWorkbook
Set ES = wb.Sheets("Licences")
Dim myOlApp As Outlook.Application
Dim myNamespace As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.MAPIFolder
Dim olAppItem as Outlook.AppointmentItem
Set myOlApp = CreateObject("Outlook.Application")
Set myNamespace = myOlApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("DTS Streetworks")
myRecipient.Resolve
If myRecipient.Resolved Then
Set CalendarFolder = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
r = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To r
With Cells(i, 5)
If .Value = "Mobile Plant" And Cells(i, 6) <> "" Then
Set olAppItem = CalendarFolder.Items.Add olAppointmentItem
With olAppItem
.Subject = "Test " + ES.Cells(i, 4).Value
.Start = ES.Cells(i, 14) + ES.Cells(i, 15).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = ES.Cells(i, 5).Value
.Save
End With
End If
End With
Next i
End Sub
How do I get the top 50 emails from Outlook using Excel VBA from new to old?
I am using the code below, however this is fetching the emails from last to first.
Sub GetFromInbox()
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
x = Date
For Each olMail In Fldr.Items
ActiveSheet.Cells(i, 1).Value = olMail.Subject
ActiveSheet.Cells(i, 2).Value = olMail.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olMail.SenderName
i = i + 1
Next olMail
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Sort a collection of the items in the folder.
Option Explicit
Sub GetFromInbox()
Dim olApp As outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim sortItems As Items
Dim olObj As Object
Dim i As Long
Dim maxIter As Long
Set olApp = New outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
' Sort a collection of items, not Fldr.Items
Set sortItems = Fldr.Items
sortItems.Sort "[Received]", True
If sortItems.count > 50 Then
maxIter = 50
Else
maxIter = sortItems.count
End If
For i = 1 To maxIter
Set olObj = sortItems(i)
If olObj.Class = olMail Then
ActiveSheet.Cells(i, 1).Value = olObj.subject
ActiveSheet.Cells(i, 2).Value = olObj.ReceivedTime
ActiveSheet.Cells(i, 3).Value = olObj.senderName
End If
Next
Set olObj = Nothing
Set sortItems = Nothing
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
If this grabs the wrong 50 emails you can try stepping through items the opposite way like:
For i = Fldr.Items.Count To Fldr.Items.Count - 50 Step -1
ActiveSheet.Cells(i, 1).Value = Fldr.Items(i).Subject
etc...
Add an exit once you hit 50, for ex:
If counter = 50 Then Exit For
Also, you can alternatively keep your existing code, then add a function to sort the emails by received date and only keep the top 50
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