Excel to Shared Outlook Calendar

[Alex Dickey]

I created a pop up tool using an excel user form. Employees will enter days off and the information pushes to an outlook calendar. I am unable to push it to a shared calendar I have created on the exchange server.

\\Ops.Svc.Shared.Calendar@cfins.com- The file path for the shared cal.

Code below:

Private Sub ComboBox1_Change()
End Sub

Private Sub ComboBox2_Change()

End Sub

Private Sub DTPicker1_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)

End Sub

Private Sub Label3_Click()

End Sub

Private Sub TextBox2_Change()

End Sub

Sub UserForm_Initialize()
ComboBox1.List = Array("P.T.O.", "Buisness Travel", "Half Day", "Maternity Leave", "Paternity Leave", "Family Leave", "Other")
End Sub

'Calendar end date
Private Sub btnEndDateCal_Click()
Cal.lblCtrlName = "tbEndDate"
Cal.lblUF = "UserForm2"
Cal.Show
End Sub
Private Sub tbEndDate_Change()

End Sub

'Calender start date
Private Sub btnStDateCal_Click()
Cal.lblCtrlName = "tbStDate"
Cal.lblUF = "UserForm2"
Cal.Show
End Sub
Private Sub tbStDate_Change()

End Sub

Private Sub CommandButton2_Click()


Call security
Call AddAppointments
Sheets("sheet1").Range("J1").Value = DTPicker1
End Sub

Sub AddAppointments()

'Finds User Name
Const lpnLength As Integer = 255
Dim status As Integer
Dim lpName, lpUserName As String
lpUserName = Space$(lpnLength + 1)
status = WNetGetUser(lpName, lpUserName, lpnLength)
If status = NoError Then
lpUserName = Left$(lpUserName, InStr(lpUserName, Chr(0)) - 1)
Else
MsgBox "Unable to get the name."
End
End If


' Create the Outlook session
Set Myoutlook = CreateObject("Outlook.Application")



' Start at row 1
r = 1

Do Until Trim(Cells(r, 1).Value) = ""
' Create the AppointmentItem
Set myApt = Myoutlook.CreateItem(1)




' Set the appointment properties
myApt.Subject = lpUserName & "-" & Hour(Now) & ":" & Minute(Now) & "-" & DateValue(Now) & "-" & UserForm2.ComboBox1.Value & "-" & UserForm2.TextBox2.Value
myApt.Start = UserForm2.tbStDate.Value
myApt.End = UserForm2.tbEndDate.Value
'myApt.TimeValue(Item.Start) = UserForm.DTPicker1

' 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 = False
End If
myApt.Body = Cells(r, 7).Value
myApt.Save
r = r + 1
Loop
End Sub

Private Sub Application_Startup()
Dim NS As Outlook.Namespace
Set NS = Application.GetNamespace("\\Ops.Svc.Shared.Calendar@cfins.com")
Set curCal = NS.GetSharedFolder("\\Ops.Svc.Shared.Calendar@cfins.com").Items
Set NS = Nothing
End Sub

Private Sub curCal_ItemAdd(ByVal Item As Object)
Dim cAppt As AppointmentItem
Dim moveCal As AppointmentItem
' On Error Resume Next
Set newCalFolder = oFolder.Folders("\\Ops.Svc.Shared.Calendar@cfins.com")

If Item.BusyStatus = olBusy Then

Set cAppt = Application.CreateItem(olAppointmentItem)

With cAppt
.Subject = "Copied: " & Item.Subject
.Start = Item.Start
.End = Item.End
.Location = Item.Location
.Body = Item.Body
End With

 

[Forum Admin]

Well, this is wrong:
Set newCalFolder = oFolder.Folders("\\Ops.Svc.Shared.Calendar@cfins.com")
it should be
Set newCalFolder = oFolder.Folders("Ops.Svc.Shared.Calendar@cfins.com")

You are using the same path twice:
Set curCal = NS.GetSharedFolder("\\Ops.Svc.Shared.Calendar@cfins.com").Items

Set newCalFolder = oFolder.Folders("\\Ops.Svc.Shared.Calendar@cfins.com")

if you aren't moving to a new calendar, you don't need the newcalfolder or the move code.