Create Shared Calendar Appointment from Clipboard

[dkoester77]

Here's the use case: User copies text/tables from a webpage, then creates an appointment on a shared calendar with information pasted into the body. Pasted text needs to retain formatting. I found a script that creates the appointment with the pasted text, but only works with personal calendar. I found another that creates the shared calendar appointment, but won't paste the text. When I combined them (or attempted to) I found that both scripts have "Set objAppt = ..." with different properties. As you'd expect, if I remove either of them, the code does half of what it's supposed too. This is obviously the problem, but the solution is not so obvious to me!

If someone could point me in the right direction, I would really appreciate it. I'm good at copy/pasting, but definately not a coder...

-Doug

Sub CreateAppt()

Dim objAppt As Outlook.AppointmentItem
Dim objWord As Word.Application
Dim objInsp As Inspector
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim strMsg As String
Dim strName As String


On Error Resume Next

strName = "Troy-PublicSafetyDemo"

Set objAppt = Application.CreateItem(olAppointmentItem)
Set objInsp = objAppt.GetInspector
Set objDoc = objInsp.WordEditor
Set objSel = objDoc.Windows(1).Selection
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)

On Error Resume Next

Set objFolder = _
objNS.GetSharedDefaultFolder(objRecip, _
olFolderCalendar)

Set objAppt = objFolder.Items.Add

With objAppt
.Subject = "??- TENTATIVE"
.Start = Date
.AllDayEvent = True
.ReminderSet = False
.BusyStatus = olBusy
objSel.PasteAndFormat (wdFormatOriginalFormatting)
.Display
End With

Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing
Set objAppt = Nothing
Set objSel = Nothing
Set objInsp = Nothing
Set objWord = Nothing

End Sub

[skatonni]

You could try moving the appointment from the default calendar to the shared calendar.

[dkoester77]

You could try moving the appointment from the default calendar to the shared calendar.

I thought of that, but I'm not sure how to do that. I looked for sample code that I could borrow and learn from, but I haven't found anything that made sense. Perhaps you could point me to something or help get me started?

Thanks for taking time to reply. I really appreciate it!!

[dkoester77]

Any other thoughts? I'm still unable to get this to work. I would really appreciate any help I can get!!

[skatonni]

On Error Resume Next is likely the cause of the problem. Sometimes the code you copy uses this when it is too much trouble to have error checking. The first action when debugging is to remove this so you see the errors.


Sub CreateAppt2()

Dim objAppt As AppointmentItem
Dim objWord As Word.Application
Dim objInsp As Inspector
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objApp As Outlook.Application
Dim objNS As NameSpace
Dim objFolder As MAPIFolder
Dim objDummy As mailItem
Dim objRecip As Recipient
'Dim strMsg As String
Dim strName As String

' On Error Resume Next
' Use this for a specific purpose then turn off with
' On Error GoTo 0

strName = "Troy-PublicSafetyDemo"
Set objAppt = Application.CreateItem(olAppointmentItem)
Set objInsp = objAppt.GetInspector
Set objDoc = objInsp.WordEditor
Set objSel = objDoc.Windows(1).Selection
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objDummy = objApp.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)

'On Error Resume Next
objRecip.Resolve
If Not objRecip.Resolved Then
MsgBox "Account " & strName & " not resolved."
GoTo ExitRoutine
Else
Set objFolder = objNS.GetSharedDefaultFolder(objRecip, olFolderCalendar)
End If

' Set objAppt = objFolder.Items.Add

With objAppt
.Subject = "??- TENTATIVE"
.Start = Date
.AllDayEvent = True
.ReminderSet = False
.BusyStatus = olBusy
objSel.PasteAndFormat (wdFormatOriginalFormatting)
.Display
.Move objFolder
End With

Set ActiveExplorer.CurrentFolder = objFolder

ExitRoutine:
Set objApp = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing
Set objAppt = Nothing
Set objSel = Nothing
Set objInsp = Nothing
Set objWord = Nothing
End Sub

[dkoester77]

Thank you, this works great! One question though. Is there a simple way to re-open (display so user can modify) the appointment after the ".Move objFolder" line? Thanks again!

[skatonni]

Something like this:


Dim movedAppt As AppointmentItem

With objAppt
.Subject = "??- TENTATIVE"
.start = Date
.AllDayEvent = True
.ReminderSet = False
.BusyStatus = olBusy
objSel.PasteAndFormat (wdFormatOriginalFormatting)
.Display
'.Move objFolder
Set movedAppt = .Move(objFolder)
End With

Set ActiveExplorer.CurrentFolder = objFolder
movedAppt.Display

[dkoester77]

Perfect. Thank you again... I really appreciate your help!!