I am trying to import an appointment calendar in Excel with Excel VBA with the following format:
Subject Start End Location
Breakfast 8/7/17 9:00 AM 8/7/17 9:30 AM Cafe
I am encountering a "Run-time Error 438: Object doesn't support this property or method" at .Start = ThisWorkbook.Sheets(1).Cells(NextRow, 2) when I run this macro:
Sub TestCalendar()
Dim OLApp As Object
Dim OLName As Object
Dim OLFolder As Object
Dim OLAppt As Object
Dim NextRow As Long
Set OLApp = CreateObject("Outlook.Application")
Set OLName = OLApp.GetNamespace("MAPI")
Set OLFolder = OLName.GetDefaultFolder(9).Folders("Test")
NextRow = 2
Do Until Trim(ThisWorkbook.Sheets(1).Cells(NextRow, 1)) = ""
Set OLAppt = OLApp.CreateItem(olAppointmentItem)
With OLAppt
.Subject = ThisWorkbook.Sheets(1).Cells(NextRow, 1)
.Start = ThisWorkbook.Sheets(1).Cells(NextRow, 2)
.End = ThisWorkbook.Sheets(1).Cells(NextRow, 3)
.Location = ThisWorkbook.Sheets(1).Cells(NextRow, 4)
.Save
End With
NextRow = NextRow + 1
Loop
Set OLAppt = Nothing
Set OLFolder = Nothing
Set OLName = Nothing
Set OLApp = Nothing
End Sub
The following script worked for me.
Sub AddAppointments()
' Create the Outlook session
Set myOutlook = CreateObject("Outlook.Application")
' Start at row 2
r = 2
Do Until Trim(Cells(r, 1).Value) = ""
' Create the AppointmentItem
Set myApt = myOutlook.CreateItem(1)
' Set the appointment properties
myApt.Subject = Cells(r, 1).Value
myApt.Location = Cells(r, 2).Value
myApt.Start = Cells(r, 3).Value
myApt.Duration = Cells(r, 4).Value
' If Busy Status is not specified, default to 2 (Busy)
If Trim(Cells(r, 5).Value) = "" Then
myApt.BusyStatus = 2
Else
myApt.BusyStatus = Cells(r, 5).Value
End If
If Cells(r, 6).Value > 0 Then
myApt.ReminderSet = True
myApt.ReminderMinutesBeforeStart = Cells(r, 6).Value
Else
myApt.ReminderSet = True
End If
myApt.Body = Cells(r, 7).Value
myApt.Save
r = r + 1
Loop
End Sub
Here's a view of my setup.
Related
I'm trying to access calendar entries from 2 custom Outlook calendars using Excel VBA.
I've obtained some code which gives me what I want from the default calendar but I cannot see how to change the location to my own calendars.
The code I'm using is
Sub ListAppointments()
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim nextrow As Long
Dim FromDate As Date
Dim ToDate As Date
FromDate = CDate("30/11/2021")
ToDate = CDate("20/12/2021")
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = 2
With Sheets("Cal-Ext")
.Range("A1:E1").Value = Array("Date", "Start Time", "End Time", "Subject", "Location")
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
Set olFolder = olNS.GetDefaultFolder(9)
nextrow = nextrow + 5
For Each olApt In olFolder.Items
If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
.Cells(nextrow, "A").Value = CDate(olApt.Start)
.Cells(nextrow, "A").NumberFormat = "DD/MM/YYYY"
.Cells(nextrow, "B").Value = olApt.Start
.Cells(nextrow, "B").NumberFormat = "HH:MM"
.Cells(nextrow, "C").Value = olApt.End
.Cells(nextrow, "C").NumberFormat = "HH:MM"
.Cells(nextrow, "D").Value = olApt.Subject
.Cells(nextrow, "E").Value = olApt.Location
nextrow = nextrow + 1
Else
End If
Next olApt
.Columns.AutoFit
End With
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
I need to change the set olfolder command before the second loop to select my own calendar but nothing I've tried works.
Outlook calendar
Current excel result
Here is a quick code that I wrote to loop through all the navigation folders of My Calendars
This code was tested in MS Outlook. You may have to edit it for it to work in MS Excel.
Option Explicit
Sub Sample()
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = Outlook.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
Screenshot
Code from Excel
Option Explicit
Sub ListAppointments()
Dim OutApp As Object
Set OutApp = CreateObject("Outlook.Application")
Dim oNameSpace As Object
Dim oExplorer As Object
Dim oMainFolder As Object
Dim oCalModule As Object
Dim oSubFolder As Object
Dim oCalNavFolders As Object
Dim i As Long
Dim objitem As Object
Set oNameSpace = OutApp.GetNamespace("MAPI")
Set oExplorer = oNameSpace.GetDefaultFolder(9).GetExplorer
Set oCalModule = oExplorer.NavigationPane.Modules.GetNavigationModule(1)
Set oCalNavFolders = oCalModule.NavigationGroups.Item("My Calendars").NavigationFolders
For i = 1 To oCalNavFolders.Count
Set objitem = oCalNavFolders(i)
On Error Resume Next
Set oSubFolder = objitem.Folder
On Error GoTo 0
If Not oSubFolder Is Nothing Then
Debug.Print oSubFolder.Name
If oSubFolder.Name = "Area1" Then
With oSubFolder
'
'~~> Do what you want
'
End With
Exit For
End If
Set oSubFolder = Nothing
End If
Next i
End Sub
I am trying to make appointments from a given date.
To avoid duplicates I tried coloring the cells but that does not seem viable.
Now I am trying to check if an appointment with the same "subject" as the cell exists and if so go to the next line.
I get the error
Object required
Private Sub Workbook_Open()
Set myOutlook = CreateObject("Outlook.Application")
r = 2
Do Until Trim(Cells(r, 8).Value) = ""
If Cells(r, 9).Value = myapt.Subject = Cells(r, 9).Value Then
r = r + 1
Else
Set myapt = myOutlook.createitem(1)
myapt.Subject = Cells(r, 9).Value
myapt.Start = Cells(r, 8).Value
myapt.AllDayEvent = True
myapt.BusyStatus = 5
myapt.ReminderSet = True
'myapt.Body = ""
myapt.Save
Cells(r, 8).Interior.ColorIndex = 4
r = r + 1
End If
Loop
End Sub
To check if an item exists you need to filter the existing items:
Option Explicit
Public Sub CreateItemsIfNotExist()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") '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 = 2
Do Until Trim$(ws.Cells(iRow, 8).Value) = vbNullString
'filter appointments for subject
strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 9).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, 9).Value
.Start = ws.Cells(iRow, 8).Value
.AllDayEvent = True
.BusyStatus = 5
.ReminderSet = True
.Save
End With
ws.Cells(iRow, 8).Interior.ColorIndex = 4
End If
iRow = iRow + 1
Loop
End Sub
Note that maybe you want to quit outlook in the end olApp.Quit.
I have some code working to import data from Excel when a cell contains the word "Yes". I would like to include code to ignore any entries that have previously been imported when I run the code again.
Sub Permits()
Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook
Set WB = ThisWorkbook
Set ES = WB.Sheets("Permits")
r = ES.Cells(Rows.Count, 1).End(xlUp).Row
Set OL = New Outlook.Application
For i = 2 To r
If ES.Cells(i, 10) = "Yes" Then
Set Appoint = OL.CreateItem(olAppointmentItem)
With Appoint
.Subject = ES.Cells(i, 3).Value
.Start = ES.Cells(i, 7) + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 6).Value
.Save
End With
End If
Next i
Set OL = Nothing
End Sub
You can mark processed rows with a green colour for example:
(edited as req, it looks for "Yes" in cell 11)
Option Explicit
Option Compare Text 'ignore case sensitivity when comparing strings
Sub Permits()
Dim OL As Outlook.Application, ES As Worksheet, _
r As Long, i As Long, WB As ThisWorkbook
Set WB = ThisWorkbook
Set ES = WB.Sheets("Permits")
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 = "Yes" And .Offset(0, 1).Value <> "Yes" Then
.Offset(0, 1).Value = "Yes"
With OL.CreateItem(olAppointmentItem)
.Subject = ES.Cells(i, 3).Value
.Start = ES.Cells(i, 7) + ES.Cells(i, 8).Value
.ReminderSet = True
.ReminderMinutesBeforeStart = 60
.Body = "£" & ES.Cells(i, 6).Value
.Save
End With
End If
End With
Next i
Set OL = Nothing
Set WB = Nothing
Set ES = Nothing
End Sub
You could also create a separate column to mark them etc, edit as needed. Alternatively, you can keep the spreadsheet 'clean' and search for existing reminders with the same data.
I have a macro that will get all emails that contains "HAPPY", "NEUTRAL" and "SAD" in the subject and copy it to a new sheet of the workbook. I want to add functionality to only display mood based on the date defined by a user.
Also, code below read emails in the inbox. I need it to read all the folders in my mailbox (e.g. Outbox and subfolders).
Sub GetMood()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
Dim ws As Worksheet
Dim iRow As Variant
Dim d As Date
x = 2
d = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
For Each olMail In myTasks
If (InStr(1, olMail.Subject, "HAPPY") > 0) Then
ThisWorkbook.Sheets("Report").Cells(1, 1) = "Sender"
ThisWorkbook.Sheets("Report").Cells(1, 2) = "Mood"
ThisWorkbook.Sheets("Report").Cells(1, 3) = "Date"
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "NEUTRAL") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
ElseIf (InStr(1, olMail.Subject, "SAD") > 0) Then
ThisWorkbook.Sheets("Report").Cells(x, 1) = olMail.SenderName
ThisWorkbook.Sheets("Report").Cells(x, 2) = olMail.Subject
ThisWorkbook.Sheets("Report").Cells(x, 3) = olMail.ReceivedTime
x = x + 1
'MsgBox "Report Generated", vbOKOnly
'Else
'olMail.Display
Exit For
End If
Next
End Sub
Private Sub Workbook_Open()
Worksheets("StartSheet").Activate
End Sub
This will look into every folders in Outlook and gather the information in mInfo to create a list in sheet Report.
I've modified the structure so that it'll detect if Outlook is already open, add a column with the detected mood and improve performances! ;)
Sub GetMood()
Dim wS As Excel.Worksheet
Dim outlookApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Outlook.MailItem
'Dim sir() As String
'Dim iRow As Variant
'Dim d As Date
Dim RgPaste As Excel.Range
Dim mSubj As String
Dim mInfo() As Variant
Dim nbInfos As Integer
ReDim mInfo(1 To 1, 1 To 3)
nbInfos = UBound(mInfo, 2)
'd = ThisWorkbook.Sheets("Main").Cells(11, 7).Value
Set wS = ThisWorkbook.Sheets("Report")
With wS
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Mood"
.Cells(1, 3) = "Date"
Set RgPaste = .Cells(2, 1)
End With 'wS
Set outlookApp = GetObject(, "Outlook.Application")
If outlookApp Is Nothing Then Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
For Each Fldr In olNs.Folders
For Each olMail In Fldr.Items
With olMail
mSubj = .Subject
mInfo(1, 1) = .SenderName
mInfo(1, 2) = mSubj
mInfo(1, 3) = .ReceivedTime
'.Display
End With 'olMail
With RgPaste
If (InStr(1, mSubj, "HAPPY") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "HAPPY"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "NEUTRAL") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "NEUTRAL"
Set RgPaste = .Offset(1, 0)
ElseIf (InStr(1, mSubj, "SAD") > 0) Then
.Resize(1, nbInfos).Value = mInfo
.Offset(0, nbInfos) = "SAD"
Set RgPaste = .Offset(1, 0)
End If
End With 'RgPaste
Next olMail
Next Fldr
'MsgBox "Report Generated", vbOKOnly
End Sub
I am trying to import dates in column "E" to my Outlook calendar.
I have code started, but it is only adding certain dates to my calendar and not adding what it seems to me like multiple dates for ex. The date of 6/2 is being added to my calendar with correct subject date and body, but for dates for 6/1 I have an empty slot.
Option Explicit
Public Sub CreateOutlookApptz()
Sheets("Sheet2").Select
On Error GoTo Err_Execute
Dim olApp As OUtlook.Application
Dim olAppt As OUtlook.AppointmentItem
Dim blnCreated As Boolean
Dim olNs As OUtlook.Namespace
Dim CalFolder As OUtlook.MAPIFolder
Dim subFolder As OUtlook.MAPIFolder
Dim arrCal As String
Dim i As Long
On Error Resume Next
Set olApp = OUtlook.Application
If olApp Is Nothing Then
Set olApp = OUtlook.Application
blnCreated = True
Err.Clear
Else
blnCreated = False
End If
On Error GoTo 0
Set olNs = olApp.GetNamespace("MAPI")
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
i = 2
Do Until Trim(Cells(i, 1).Value) = ""
Set subFolder = CalFolder
Set olAppt = subFolder.Items.Add(olAppointmentItem)
MsgBox Cells(i, 6) + Cells(i, 7)
'MsgBox subFolder, vbOKCancel, "Folder Name"
With olAppt
'Define calendar item properties
.Start = Cells(i, 6) + Cells(i, 7)
.End = Cells(i, 8) + Cells(i, 9)
.Subject = Cells(i, 2)
.Location = Cells(i, 3)
.Body = Cells(i, 4)
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = Cells(i, 10)
.ReminderSet = True
.Categories = Cells(i, 5)
.Save
End With
i = i + 1
Loop
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub
Try it this way.
Private Sub Add_Appointments_To_Outlook_Calendar()
'Include Microsoft Outlook nn.nn Object Library from Tools -> References
Dim oAppt As AppointmentItem
Dim Remind_Time As Double
i = 2
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
'Loop through entire list of Reminders to be added
While Subj <> ""
Set oAppt = Outlook.Application.CreateItem(olAppointmentItem)
oAppt.Subject = Subj
oAppt.Location = ThisWorkbook.Sheets(1).Cells(i, 2)
oAppt.Start = ThisWorkbook.Sheets(1).Cells(i, 3)
Remind_Time = ThisWorkbook.Sheets(1).Cells(i, 4) * 1 * 60
oAppt.ReminderMinutesBeforeStart = Remind_Time
oAppt.AllDayEvent = True
oAppt.Save
i = i + 1
Subj = ThisWorkbook.Sheets(1).Cells(i, 1)
Wend
MsgBox "Reminder(s) Added To Outlook Calendar"
End Sub
Your setup will look something like this.
I talk about this concept, and many other similar, but different, things in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC?ie=UTF8&keywords=ryan%20shuell&qid=1464361126&ref_=sr_1_1&sr=8-1