Per VBA Meeting in Notes Kalender eintragen und Einladungen senden

Domino 9 und frühere Versionen > ND7: Entwicklung

<< < (2/5) > >>

etofi:
Wir haben jetzt Notes 8.5.2 das hat leichte Anpassungen erforderlich gemacht.
Anbei der neue Code

--- Code: ---Public Function SendNotesTermin(pstrSubject As String, _
pstrRecipient As String, _
pstrMailBody As String, _
AppDate As Date, _
StartTime As Date, _
MinsDuration As Integer, _
pstrLocation As String, _
pstrCategories As String, _
AppointmentType As String) As String

'Aufgabe: Sendet Termine via Notes
'Rückgabe: String mit Fehlermeldung bei auftretendem Fehler, sonst Leerstring
'
'pstrSubject: Betreff
'pstrRecipient: Empfänger mit Komma getrennt
'pstrMailBody: Text
'AppDate: Datum Termin
'StartTime: Uhrzeit Termin
'MinsDuration: Dauer in Minuten
'pstrLocation: Ort
'pstrCategories: Kategorie
'AppointmentType: 0=Termin, 1=Jahrestag, 2=Ganztägige Veranstaltung, 3=Meeting, 4=Erinnerung
'
'WICHTIG: Damit die Funktion "Status der eingeladenen Personen prüfen" sauber funktioniert
' müssen die internen Aderssen im Notes Format "Max Muster/Intern/xxxx" übergeben werden.

On Error GoTo proc_error

Dim objNotesSession As Object
Dim objNotesDatabase As Object
Dim objNotesDocument As Object
Dim objItem As Object
Dim strServerName As String
Dim strServerEinzelname() As String
Dim strMailDbName As String
Dim strUserName As String
Dim strUserEinzelname() As String
Dim strUserMail As String
Dim datStart As Date
Dim datEnde As Date
Dim intZaehler As Integer
Dim dblAnzahlTage As Double
Dim strCSTrack(2) As String
Dim intAnzahlEmpfaenger As Integer
Dim strStorageRequiredNames() As String

SendNotesTermin = ""

'Bei ganztägige Veranstaltung auf 4 Uhr Starttag und 22 Uhr Endtage setzen
If AppointmentType = 2 Then
datStart = CDate(AppDate & " " & "04:00")
dblAnzahlTage = fktAufrunden(MinsDuration / 60 / 24, 0) ' Berechnung Tage
datEnde = CDate(Format(DateAdd("d", dblAnzahlTage - 1, datStart), "dd.mm.yyyy") & " 22:00")
Else
datStart = CDate(AppDate & " " & Format(StartTime, "hh:mm"))
datEnde = DateAdd("n", MinsDuration, datStart)
End If

Set objNotesSession = CreateObject("Notes.NotesSession")

strUserName = objNotesSession.UserName
strUserMail = Replace(Replace(Replace(strUserName, "CN=", ""), "OU=", ""), "O=", "")
strServerName = objNotesSession.GETENVIRONMENTSTRING("MailServer", True)
strMailDbName = objNotesSession.GETENVIRONMENTSTRING("MailFile", True)

strServerEinzelname = Split(Replace(Replace(Replace(strServerName, "CN=", ""), "OU=", ""), "O=", ""), "/")
strUserEinzelname = Split(Replace(Replace(Replace(strUserName, "CN=", ""), "OU=", ""), "O=", ""), "/")

Set objNotesDatabase = objNotesSession.GETDATABASE(strServerName, strMailDbName)
Set objNotesDocument = objNotesDatabase.CREATEDOCUMENT

With objNotesDocument

'Universal ID eintragen
.APPTUNID = objNotesDocument.UNIVERSALID

'Appointment Type
.REPLACEITEMVALUE "Form", "Appointment"
.REPLACEITEMVALUE "AppointmentType", AppointmentType

'Was, wo und warum
.REPLACEITEMVALUE "Categories", pstrCategories
.REPLACEITEMVALUE "Location", pstrLocation
.REPLACEITEMVALUE "Subject", pstrSubject
.REPLACEITEMVALUE "Body", pstrMailBody

'Eigentümer
.REPLACEITEMVALUE "Chair", objNotesSession.UserName
.REPLACEITEMVALUE "AltChair", objNotesSession.UserName
.REPLACEITEMVALUE "From", objNotesSession.UserName
Set objItem = .GETFIRSTITEM("From")
objItem.ISNAMES = True
objItem.ISAUTHORS = True
Set objItem = Nothing
.REPLACEITEMVALUE "Principal", objNotesSession.UserName
.REPLACEITEMVALUE "$AltPrincipal", objNotesSession.UserName

'Einstellung einer Erinnerung in Minuten
.REPLACEITEMVALUE "$Alarm", 1
.REPLACEITEMVALUE "$AlarmOffset", -15
.REPLACEITEMVALUE "Alarms", "1"

'Welches Icon soll angezeigt werden
Select Case AppointmentType
Case 0 'Appointment
.REPLACEITEMVALUE "_ViewIcon", 160
.REPLACEITEMVALUE "$IconSwitcher", "Appointment"
Case 1 'Anniversary
.REPLACEITEMVALUE "_ViewIcon", 63
.REPLACEITEMVALUE "$IconSwitcher", "Anniversary"
Case 2 'AllDayEvent
.REPLACEITEMVALUE "_ViewIcon", 9
.REPLACEITEMVALUE "$IconSwitcher", "AllDayEvent"
Case 3 'Meeting
.REPLACEITEMVALUE "_ViewIcon", 158
.REPLACEITEMVALUE "$IconSwitcher", "Meeting"
Case 4 'Reminder
.REPLACEITEMVALUE "_ViewIcon", 10
.REPLACEITEMVALUE "$IconSwitcher", "Reminder"
End Select

'Zeit und Datum
.REPLACEITEMVALUE "StartDateTime", datStart
.REPLACEITEMVALUE "EndDateTime", datEnde
.REPLACEITEMVALUE "StartDate", datStart
.REPLACEITEMVALUE "StartTime", datStart
.REPLACEITEMVALUE "EndDate", datEnde
.REPLACEITEMVALUE "EndTime", datEnde
.REPLACEITEMVALUE "$NoPurge", datEnde

If AppointmentType = 2 Then 'Bei ganztägige Veranstaltung je Tag Ein Arrayeintag erforderlich

Dim arrCalenderDateTime() As Date
ReDim arrCalenderDateTime(dblAnzahlTage - 1)
For intZaehler = 0 To dblAnzahlTage - 1
arrCalenderDateTime(intZaehler) = DateAdd("d", intZaehler, datStart)
Next
.REPLACEITEMVALUE "CalendarDateTime", arrCalenderDateTime

Else

.REPLACEITEMVALUE "CalendarDateTime", datStart

End If

'## Attendee-related data
If AppointmentType = 3 Then 'Meeting

Dim arrRequiredAttendeeName() As String
arrRequiredAttendeeName = Split(pstrRecipient, ",")

For intZaehler = 0 To UBound(arrRequiredAttendeeName)
'Bei den Empfängern darf der Absender nicht enthalten sein!!
If Trim(arrRequiredAttendeeName(intZaehler)) = strUserMail Then
arrRequiredAttendeeName(intZaehler) = vbNullString
Else
arrRequiredAttendeeName(intZaehler) = Trim(arrRequiredAttendeeName(intZaehler))
End If
Next

.REPLACEITEMVALUE "Recipients", arrRequiredAttendeeName
.REPLACEITEMVALUE "RequiredAttendees", arrRequiredAttendeeName
'.REPLACEITEMVALUE "AltRequiredNames", arrRequiredAttendeeName
.REPLACEITEMVALUE "SendTo", arrRequiredAttendeeName
Set objItem = .GETFIRSTITEM("SendTo")
objItem.ISNAMES = True
objItem.ISSIGNED = True
Set objItem = Nothing
'.REPLACEITEMVALUE "INetRequiredNames", arrRequiredAttendeeNameAndEmail

intAnzahlEmpfaenger = UBound(arrRequiredAttendeeName)
ReDim strStorageRequiredNames(intAnzahlEmpfaenger)

For intZaehler = 0 To intAnzahlEmpfaenger
strStorageRequiredNames(intZaehler) = "1"
Next
.REPLACEITEMVALUE "StorageRequiredNames", strStorageRequiredNames
Set objItem = .GETFIRSTITEM("StorageRequiredNames")
objItem.ISNAMES = True
Set objItem = Nothing

.REPLACEITEMVALUE "$CSVersion", "2"
.REPLACEITEMVALUE "$CSWISL", Array("$S:1", "$L:1", "$B:1", "$R:1", "$E:1", "$W:1", "$O:1", "$M:1")
.REPLACEITEMVALUE "$WatchedItems", Array("$S", "$L", "$B", "$R", "$E", "$W", "$O", "$M")

strCSTrack(0) = "Send[" & strServerEinzelname(0) & "] by Notes on " & strUserEinzelname(0) & "(" & objNotesSession.NOTESVERSION & ") at " & Format(Now(), "DD.MM.YYYY HH:MM:SS")
strCSTrack(1) = "PrepareToSend[" & strServerEinzelname(0) & "] by Notes on " & strUserEinzelname(0) & "(" & objNotesSession.NOTESVERSION & ") at " & Format(Now(), "DD.MM.YYYY HH:MM:SS")
strCSTrack(2) = "Restore[" & strServerEinzelname(0) & "] by Notes on " & strUserEinzelname(0) & "(" & objNotesSession.NOTESVERSION & ") at " & Format(Now(), "DD.MM.YYYY HH:MM:SS")
.REPLACEITEMVALUE "$CSTrack", strCSTrack

.REPLACEITEMVALUE "$TableSwitcher", "Description"
.REPLACEITEMVALUE "NoticeType", "I"

End If

'## BusyTime Items
.REPLACEITEMVALUE "$BusyName", strUserName
Set objItem = .GETFIRSTITEM("$BusyName")
objItem.ISNAMES = True
Set objItem = Nothing
.REPLACEITEMVALUE "BookFreeTime", ""
.REPLACEITEMVALUE "$BusyPriority", "1"

'## System variables
.REPLACEITEMVALUE "$UpdatedBy", objNotesSession.UserName
.REPLACEITEMVALUE "OrgTable", "C0"
.REPLACEITEMVALUE "$PublicAccess", "1"
.REPLACEITEMVALUE "StartTimeZone", "Z=-1$DO=1$DL=3 -1 1 10 -1 1$ZX=86$ZN=W. Europe"
.REPLACEITEMVALUE "$ExpandGroups", "3"

.REPLACEITEMVALUE "$FromPreferredLanguage", "de"
.REPLACEITEMVALUE "$LangChair", ""
.REPLACEITEMVALUE "$SMTPKeepNotesItem", "1"

.REPLACEITEMVALUE "UpdateSeq", 1
.REPLACEITEMVALUE "WebDateTimeInit", "1"

.REPLACEITEMVALUE "ExcludeFromView", Array("S", "D")
.REPLACEITEMVALUE "MailOptions", ""

.REPLACEITEMVALUE "Resources", ""
.REPLACEITEMVALUE "Repeats", ""
.REPLACEITEMVALUE "RoomToReserve", ""

'Überprüfen vor dem Speichern bzw. Versand
If .COMPUTEWITHFORM(True, False) = False Then
MsgBox "Bei der Erstellung des Termins ist ein Fehler aufgetreten!"
GoTo proc_exit
End If

'Wenn Meeting dann Einladungen senden
If AppointmentType = 3 Then
.SAVEMESSAGEONSEND = False ' bei True wird ein Exemplar in Notes in Gesendet gestellt
.SIGNONSEND = True

'Bereinigungen damit Einladung optisch richtig ankommt
.REPLACEITEMVALUE "Form", "Notice"
.REPLACEITEMVALUE "_ViewIcon", 133 'Invitation
.REPLACEITEMVALUE "ExcludeFromView", Array("A")
Set objItem = .GETFIRSTITEM("$BusyPriority")
objItem.Remove
Set objItem = Nothing
Set objItem = .GETFIRSTITEM("CalendarDateTime")
objItem.Remove
Set objItem = Nothing

'senden
.SEND False

'Bereinigungen wieder zurück
.REPLACEITEMVALUE "Form", "Appointment" 'Meeting
.REPLACEITEMVALUE "_ViewIcon", 158
.REPLACEITEMVALUE "ExcludeFromView", Array("S", "D")
.REPLACEITEMVALUE "$BusyPriority", "1"
.REPLACEITEMVALUE "CalendarDateTime", datStart

'Bereinigungend damit Meeting richtig gespeichert wird und es keine Fehlermeldungen bei Änderung gibt
Set objItem = .GETFIRSTITEM("SendTo")
objItem.Remove
Set objItem = Nothing
Set objItem = .GETFIRSTITEM("NoticeType")
objItem.Remove
Set objItem = Nothing

End If

'Im Kalender speichern
.Save True, False

'Damit der Alarm auch funtioniert
.PUTINFOLDER "$Alarms", True

End With

proc_exit:
Set objNotesDocument = Nothing
Set objNotesDatabase = Nothing
Set objNotesSession = Nothing
Exit Function

proc_error:
SendNotesTermin = Err.Description
Resume proc_exit

End Function

Public Function fktAufrunden(Zahl As Double, Stellen As Integer) As Double

If IsNull(Zahl) = True Then
fktAufrunden = 0
Else
Zahl = CDec(Zahl)
If ((Zahl - Int(Zahl)) * 10 ^ Stellen) = 0 Then
fktAufrunden = Int(Zahl) + (Int(((Zahl - Int(Zahl)) * 10 ^ Stellen)) / 10 ^ Stellen)
Else
fktAufrunden = Int(Zahl) + (Int(((Zahl - Int(Zahl)) * 10 ^ Stellen) + 1) / 10 ^ Stellen)
End If
End If

End Function

--- Ende Code ---

Grüße
Eric Trösch

Jenny85:
Hallo zusammen,

ich habe diesen Code gesehen, und denke er könnte ziemlich genau das sein was ich suche. Kann mir jemand sagen wie der Sub zu dieser Funktion ausehen müsste??

Vielen Dank vorab!

Grüße aus dem sonnigen Allgäu

Jenny

etofi:

--- Zitat von: Jenny85 am 29.08.12 - 08:35:20 ---Kann mir jemand sagen wie der Sub zu dieser Funktion ausehen müsste??

--- Ende Zitat ---

Hmm - die Frage verstehe ich jetzt nicht wirklich.
Man macht in vba ein Codemudule, packc die Funktion rein und ruft dann von beliebiger Stelle die Funktion mit

Call SendNotesTermin("Betreff","Empfängermail","Termintext",01.01.2013,[Dauer in Minuten],"Ort","Kategorie",[Terminart])

auf.

Grüße
etofi

Jenny85:
So wollt ichs auch probieren, da kommt dann immer die Fehlermeldung "Argument ist nicht optional" mit Markierung auf "Call SendNotesTermin" ....

etofi:

--- Zitat von: Jenny85 am 29.08.12 - 09:39:45 ---So wollt ichs auch probieren, da kommt dann immer die Fehlermeldung "Argument ist nicht optional" mit Markierung auf "Call SendNotesTermin" ....

--- Ende Zitat ---

Poste mal den Code, dann wird es evtl einfacher...
Oder schicke mir die Datei per PN dann schau ich mir das mal an.

Navigation

[0] Themen-Index

[#] Nächste Seite

[*] Vorherige Sete

Zur normalen Ansicht wechseln