I'm trying to add appointments to a non default calendar in Outlook through Excel.
All is okay when I add the appointment to the default calendar.
Code for default calendar:
Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
Set OLAppointment = OLApp.Item.Add(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("C3").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub
I'm trying to use the "Folders" object to set the non default calendar but Excel returns a compile error.
Sub Appointments()
Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object
Dim miCalendario As Object
On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0
If Not OLApp Is Nothing Then
Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon
Set miCalendario = OLApp.Session.GetDefaultFolder(9).Folders("a")
Set OLAppointment = miCalendario.Item.Add(olAppointmentItem)
OLAppointment.Subject = Range("A1").Value
OLAppointment.Start = Range("C3").Value
OLAppointment.Duration = Range("C1").Value
OLAppointment.ReminderMinutesBeforeStart = Range("D1").Value
OLAppointment.Save
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing
End If
End Sub
I made this script for Outlook. I'm trying to modify for Excel.
Sub AddContactsFolder()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderCalendar).Folders("aa")
MsgBox myFolder
Set myNewFolder = myFolder.Items.Add(olAppointmentItem)
With myNewFolder
.Subject = "aaaaa"
.Start = "10/11/2013"
.ReminderMinutesBeforeStart = "20"
.Save
End With
End Sub
The line
Set OLAppointment = miCalendario.Item.Add(olAppointmentItem)
must be
Set OLAppointment = miCalendario.Items.Add(olAppointmentItem)
Related
I am using a modified code I found online, and I am having issues finding a shared calendar in outlook.
Sub SharedCalendarEventCreator()
Dim olApp As Outlook.Application
Dim outNameSpace As Namespace
Dim outSharedName As Outlook.Recipient
Dim outCalendarFolder As MAPIFolder
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
Dim eduSheet As Worksheet
On Error Resume Next
Worksheets("Schedule").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)
r = 7
Do Until Trim$(Cells(r, 1).Value) = ""
With olAppItem
.Subject = "SOF " & Cells(1, 2).Value & " " & Cells(2, 2).Value & " " & Cells(3, 2).Value & " " & Cells(r, 2).Value
.Start = Cells(r, 1).Value
vArray = Split(Cells(4, 2).Value2, ";")
For Each vElement In vArray
'.Recipients.Add .Recipients.Add(vElement)
Next vElement
.MeetingStatus = olMeeting
.AllDayEvent = True
.Body = Cells(r, 3).Value
.ResponseRequested = False
.Send
r = r + 1
End With
Loop
Set olAppItem = Nothing
Set outCalendarFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
End Sub
Picture of the Calendar location:
I believe the issue is within these lines, but I have tried to change them without any luck:
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outCalendarFolder = outNameSpace.Folders("Lunch Calendar")
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)
The error I received:
When I hit debug, this is the line it highlights:
Any help is greatly appreciated.
Navigate the folder tree from "janedoe#gmail" to "Calendar" to "Lunch Calendar".
Option Explicit
Sub SharedCalendarEventCreator()
' Early binding - Set reference to Outlook XX.X Object Library
Dim olApp As Outlook.Application
Dim outNameSpace As Outlook.Namespace
Dim outMailboxFolder As Outlook.Folder
Dim outCalendarFolder As Outlook.Folder
Dim outCalendarSubFolder As Outlook.Folder
Dim olAppItem As Outlook.AppointmentItem
On Error Resume Next
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
Set outNameSpace = olApp.GetNamespace("MAPI")
Set outMailboxFolder = outNameSpace.Folders("janedoe#gmail")
Set outCalendarFolder = outMailboxFolder.Folders("Calendar")
Set outCalendarSubFolder = outCalendarFolder.Folders("Lunch Calendar")
'Set ActiveExplorer.CurrentFolder = outCalendarSubFolder
Set olAppItem = outCalendarSubFolder.Items.Add(olAppointmentItem)
olAppItem.Display
Set olAppItem = Nothing
Set outCalendarSubFolder = Nothing
Set outCalendarFolder = Nothing
Set outMailboxFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
End Sub
Now I'm export Global contact list in outlook 2016. to Excel file. This's my code:
Sub ExportOutlookAddressBook()
Application.ScreenUpdating = False
Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olAL As Outlook.AddressList
Dim olEntry As Outlook.AddressEntry
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olAL = olNS.AddressLists("Global Address List") 'Change name if different contacts list name
ActiveWorkbook.ActiveSheet.Range("a1").Select
For Each olEntry In olAL.AddressEntries
'ActiveCell.Value = olEntry.GetContact.FullName
ActiveCell.Offset(0, 0).Value = olEntry.Name
ActiveCell.Offset(1, 0).Select
Next olEntry
Set olApp = Nothing
Set olNS = Nothing
Set olAL = Nothing
Application.ScreenUpdating = True
End Sub
It have Runtime Error 91!.How can I Fix this Error? >/\<
Use GetExchangeUser istead of GetContact.
For example:
Dim olExUser As Outlook.ExchangeUser
Set olExUser = Nothing
Set olExUser = olEntry.GetExchangeUser
If Not olExUser Is Nothing Then
With olExUser
ActiveCell.Value = .FirstName & " " & .LastName
End With
End If
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
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