Create Lotus appointment from Excel

[lks55]

Hi,

I am trying to write a code which takes entries of my Excel Calendar and transfers it to LotusNotes. I found this code:


'Public Sub SendNotesAppointment(Username as string, Subject as string, attachment as string,
'recipient as string, Body as string, AppDate as Date, Duration as integer)
'This public sub will write an appointment to a persons diary
'Please specify person as first name lastname
'also change the servername to reflect the notes server name

Public Sub SendNotesAppointment(UserName As String, Subject As String, Body As String, AppDate As Date, Duration As Integer)
'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim MailDbName As String 'The persons notes mail database name
Dim CalenDoc As Object 'The calendar entry itself
Dim WorkSpace As Object
Set WorkSpace = CreateObject("Notes.NOTESUIWORKSPACE")
'Get the engineer username and then calculate the mail file name
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " ")))
MailDbName = "mail\" & Left$(MailDbName, 8) & ".nsf"
'Create a new calender appointment based on template and set the attributes.
Set CalenDoc = WorkSpace.COMPOSEDOCUMENT("SERVERNAME", MailDbName, "Appointment")
CalenDoc.FIELDSETTEXT "AppointmentType", "2"
CalenDoc.FIELDSETTEXT "StartDate", CStr(Format(Date, "dd/mm/yy"))
CalenDoc.FIELDSETTEXT "Duration", CStr(Duration)
CalenDoc.FIELDSETTEXT "Subject", Subject
CalenDoc.FIELDSETTEXT "Body", Body
CalenDoc.Save False, False, False
CalenDoc.Close
Set Maildb = Nothing
Set CalenDoc = Nothing
Set WorkSpace = Nothing
End Sub

The problem is that it doesn't seem to be a full finished code. Has anybody a completed code, which sends Excel entries to Lotus to create appointments or other calendar entries?

[lks55]

I found out that this code was already updated. So i posted the code below into an empty module in Excel VBA editor. I tried to start it to figure out how it works, but nothing happens. Can anybody give me a small guideline how to change to code to make it work?


'Public Sub SendNotesAppointment(Username as string, Subject as string,
'Body as string, AppDate as Date, StartTime as Date, MinsDuration as
integer)
'This public sub will write an appointment to a persons diary
'You must have write privleges to the calendar of the user you are going to add an appointment for
'Username is the name of the user's mail database, used to get database
'Also change the servername to reflect the notes server name

Public Sub SendNotesAppointment(UserName As String, Subject As String, Body As String, AppDate As Date, StartTime As Date, MinsDuration As Integer)
'Set up the objects required for Automation into lotus notes
Dim MailDbName As String 'The persons notes mail database name
Dim strSTime As String
Dim strETime As String
Dim CalenDoc As Object 'The calendar entry itself
Dim WorkSpace As Object
Dim ErrCnt As Integer
Set WorkSpace = CreateObject("Notes.NOTESUIWORKSPACE")

'Change this to fit your particular db naming convention based on UserName if necessary
MailDbName = "mail\" + UserName + ".nsf"

strSTime = CStr(FormatDateTime(StartTime, vbShortTime))
strETime = CStr(FormatDateTime(DateAdd("n", MinsDuration, StartTime), vbShortTime))

'MAKE SURE TO SET SERVER NAME BELOW
Set CalenDoc = WorkSpace.COMPOSEDOCUMENT("***SERVERNAME***", MailDbName, "Appointment")

CalenDoc.FIELDSETTEXT "AppointmentType", "0"
CalenDoc.Refresh

'Each loop is used to write the value to the field until the field is changed to that value

Do Until (CDate(Right(CalenDoc.fieldgettext("StartDate"), 10)) = CDate(AppDate)) Or ErrCnt = 1000
CalenDoc.FIELDSETTEXT "StartDate", CStr(FormatDateTime(AppDate, vbShortDate))
CalenDoc.Refresh
'ErrCnt is used to prevent an endless loop
ErrCnt = ErrCnt + 1
Loop
ErrCnt = 0
Do Until (CDate(CalenDoc.fieldgettext("StartTime")) = CDate(strSTime)) Or ErrCnt = 1000
CalenDoc.FIELDSETTEXT "StartTime", strSTime
CalenDoc.Refresh
ErrCnt = ErrCnt + 1
Loop
ErrCnt = 0
Do Until (CDate(Right(CalenDoc.fieldgettext("EndDate"), 10)) = CDate(AppDate)) Or ErrCnt = 1000
CalenDoc.FIELDSETTEXT "EndDate", CStr(FormatDateTime(AppDate, vbShortDate))
CalenDoc.Refresh
ErrCnt = ErrCnt + 1
Loop
ErrCnt = 0
Do Until (CDate(CalenDoc.fieldgettext("EndTime")) = CDate(strETime)) Or ErrCnt = 1000
CalenDoc.FIELDSETTEXT "EndTime", strETime
CalenDoc.Refresh
ErrCnt = ErrCnt + 1
Loop
CalenDoc.FIELDSETTEXT "Subject", Subject
CalenDoc.FIELDSETTEXT "Body", Body
CalenDoc.Refresh
CalenDoc.Save
CalenDoc.Close
Set CalenDoc = Nothing
Set WorkSpace = Nothing
End Sub