add appointment to shared outlook calendar

[zoog25]

Hello all,

Here is my situation, through the help of this board, I was guided on how to code to add appointments into an outlook calendar. Now I've been trying to see how to add an appointment to a shared calendar. The shared calendar is titled NOC Calendar. Here is the code I'm working with and want to see if I can adjust it to instead of putting it on my personal calendar, it gets added to the shared calendar.

Sub OlLM(rw As Long)

'Declare Object Variables
Dim OL As Object

'Declare Outlook Variables
Dim olAppt As Outlook.AppointmentItem
Dim oFolder As Outlook.Folder
Dim sSubject As String, sBody As String, sLocation As String
Dim dDate As Date, dStartTime As Date, dEndTime As Date
Dim bOLOpen As Boolean

'Declare Other Variables
Dim TPws As Worksheet, Datws As Worksheet
Dim LMd As Long
Dim Items As Long, Tech As String, TechR As Long

Set TPws = ThisWorkbook.Worksheets("Tract Parcels")
Set Datws = ThisWorkbook.Worksheets("DATA")

'Checks to see if Outlook is open and either open and closes it or leaves it open
On Error Resume Next
    Set OL = GetObject(, "Outlook.Application")
    bOLOpen = True

If OL Is Nothing Then
    Set OL = CreateObject("Outlook.Application")
    bOLOpen = False
End If

'Tech Personal
Tech = TPws.Cells(rw, "B").Value
TechR = TechFD(Tech)
Tech = Datws.Cells(TechR, "C").Value

'Appointment info setting
Select Case IsNumeric(TPws.Cells(rw, "G"))
    Case True
        Select Case TPws.Cells(rw, "H")
            Case Empty, "", "N/A"
                sSubject = "Tract " & TPws.Cells(rw, "G").Value & " Labor & Materials " & TPws.Cells(rw, "M").Value & " Release"
                sBody = Tech & "," & Chr(10) & "Please release the Labor & Materials " & TPws.Cells(rw, "M").Value & " for Tract " & TPws.Cells(rw, "G").Value & "."
            Case Else
                sSubject = "Tract " & TPws.Cells(rw, "G").Value & " " & TPws.Cells(rw, "H").Value & " " & TPws.Cells(rw, "I").Value & " Labor & Materials " & TPws.Cells(rw, "M").Value & " Release"
                sBody = Tech & "," & Chr(10) & "Please release the Labor & Materials " & TPws.Cells(rw, "M").Value & " for Tract " & TPws.Cells(rw, "G").Value & " " & TPws.Cells(rw, "H").Value & " " & TPws.Cells(rw, "I").Value & "."
        End Select
    Case False
        Select Case TPws.Cells(rw, "H")
            Case Empty, "", "N/A"
                sSubject = "Parcel Map " & Mid(TPws.Cells(rw, "G").Value, 3) & " Labor & Materials " & TPws.Cells(rw, "L").Value & " Release"
                sBody = Tech & "," & Chr(10) & "Please release the Labor & Materials " & TPws.Cells(rw, "M").Value & " for Parcel Map " & TPws.Cells(rw, "G").Value & "."
            Case Else
                sSubject = "Parcel Map " & Mid(TPws.Cells(rw, "G").Value, 3) & " " & TPws.Cells(rw, "H").Value & " " & TPws.Cells(rw, "I").Value & " Labor & Materials " & TPws.Cells(rw, "M").Value & " Release"
                sBody = Tech & "," & Chr(10) & "Please release the Labor & Materials " & TPws.Cells(rw, "M").Value & " for Parcel Map " & Mid(TPws.Cells(rw, "G").Value, 3) & " " & TPws.Cells(rw, "H").Value & " " & TPws.Cells(rw, "I").Value & "."
        End Select
End Select

sLocation = "Desk"

dDate = TPws.Cells(rw, "AB").Value + 90
If Weekday(dDate, vbMonday) = 6 Then
    dStartTime = (dDate + 2) + #8:00:00 AM#
    dEndTime = (dDate + 2) + #8:30:00 AM#
ElseIf Weekday(dDate, vbMonday) = 7 Then
    dStartTime = (dDate + 1) + #8:00:00 AM#
    dEndTime = (dDate + 1) + #8:30:00 AM#
Else
    dStartTime = dDate + #8:00:00 AM#
    dEndTime = dDate + #8:30:00 AM#
End If

Set olAppt = OL.CreateItem(olAppointmentItem)
    olAppt.Subject = sSubject
    olAppt.Location = sLocation
    olAppt.Start = dStartTime
    olAppt.End = dEndTime
    olAppt.Body = sBody
    olAppt.ReminderSet = True
    olAppt.MeetingStatus = olNonMeeting
    olAppt.Send
    olAppt.Close olSave
    
If bOLOpen = False Then OL.Quit

End Sub

Thank you for any assistance.

 

[John_w]

See if you can follow the posts starting at this post and incorporate the code into your macro:

Creating an Outlook Appointment in a shared calendar

Hi all, I am trying to write a VBA to create an Outlook Appointment in a shared calendar. The below code creates an appointment, but in my own default calendar. I would appreciate any help anyone can provide, as I am struggle to find an answer. Sub CalendarEntry() Dim OutApp As Object Dim...

www.mrexcel.com

The final solution is my last post in that thread.

 

[zoog25]

Thank you John_w. The thread you added as the last post i believe will help me with doing the shared folder.