Jetzt klappt es auch mit dem Nachbarn.
Hier die komplette Lösung:
Const APP_FORM = "Appointment"
Const DD_SERVER = "Mail01"
Const SEPERATOR = "!!"
Class CEntry
Public Sub new()
End Sub
Private startdttm As NotesDateTime
Private enddttm As NotesDateTime
Private moddttm As NotesDateTime
Public Property Set StartDT As NotesdateTime
Set startdttm = StartDT
End Property
Public Property Set EndDT As NotesdateTime
Set enddttm = EndDT
End Property
Private strLocation As String
Public Property Set Location As String
Me.strLocation = Location
End Property
Private varCategories As Variant
Public Property Set Categories As String
Me.varCategories = Split(Categories,";")
End Property
Private strType As String
Public Property Set AppType As String
Me.strType = AppType
End Property
Private varRoom As String
Public Property Set Room As String
Me.varRoom = Room
End Property
Public Property Get AppType As String
Select Case Ucase (Me.StrType)
Case "APPOINTMENT", "TERMIN"
AppType = "0"
Case "ANNIVERSARY", "JAHRESTAG"
AppType = "1"
Case "EVENT", "GANZTAEGIGE VERANSTALTUNG"
AppType = "2"
Case "MEETING", "BESPRECHUNG"
AppType = "3"
Case "REMINDER", "ERINNERUNG"
AppType = "4"
Case Else
AppType = "0"
End Select
End Property
Private strsubject As String
Public Property Get subject As String
subject = Me.strsubject
End Property
Public Property Set subject As String
Me.strsubject = subject
End Property
Private struser As String
Public Property Get user As String
user = Me.struser
End Property
Public Property Set user As String
Me.struser = user
End Property
Public Property Get MailFile As String
Dim s As New NotesSession
If Me.struser = "" Then
MailFIle = ""
Else ' Notes Version is < 8.x
If s.NotesBuildVersion < 307 Then
Dim db As New NotesDatabase ( DD_SERVER, "names.nsf" )
Dim v As NotesView
Dim doc As NotesDocument
If db.IsOpen() Then
Set v = db.GetView("($Users)")
If Not ( v Is Nothing ) Then
Set doc = v.GetDocumentByKey (Me.user)
If Not ( doc Is Nothing ) Then
MailFIle = doc.MailServer(0) & SEPERATOR & doc.MailFile(0)
Else
Goto ERR_USER_NOT_FOUND
End If
Else
Goto ERR_USER_NOT_FOUND
End If
Else
Goto ERR_USER_NOT_FOUND
End If
'Else ' we are running at least Notes Version 8
' On Error 4731 Goto ERR_USER_NOT_FOUND
' Dim notesdir As NotesDbDirectory
' Set notesdir = s.getDbDirectory(DD_SERVER)
' Dim homeserver As Variant
' homeserver = notesdir.GetMailInfo(Me.struser, False, False)
' mailfile = Cstr(homeserver(0)) & SEPERATOR & Cstr(homeserver(3))
End If
EXIT_PROPERTY:
Exit Property
ERR_USER_NOT_FOUND:
mailfile = ""
Resume EXIT_PROPERTY
End If
End Property
Public Function CreateSingleEntry As Integer
CreateSingleEntry = 0 ' no error
If Trim(Me.strSubject) = "" Then
CreateSingleEntry = 3 ' Subject missing
Exit Function
End If
If Me.startdttm.TimeDifference (Me.enddttm) > 0 Then
CreateSingleEntry = 4 ' EndDT before StartDT
Exit Function
End If
If Me.MailFile = "" Then
CreateSingleEntry = 1 'No MailFile or User not found
Exit Function
End If
Dim db As New NotesDatabase ( _
Strtoken (Me.Mailfile,SEPERATOR,1), Strtoken (Me.Mailfile,SEPERATOR,2))
If db.IsOpen () Then
Dim session As New NotesSession
Dim nam As NotesName
Dim cEntry As New NotesDocument (db)
Dim rtitem As Variant
Dim itemIcon As NotesItem
Dim item As NotesItem
Dim ret As Variant
Set nam = session.CreateName(Me.struser)
'----------- Set User and Description ----------------
cEntry.Form = APP_FORM
cEntry.~$Programmatically = "1"
'cEntry.tmpOwnerHW = "0"
Set item = New NotesItem(cEntry, "From", nam.canonical)
item.IsAuthors = True
Set item = New NotesItem(cEntry, "Principal", nam.canonical)
'Set item = New NotesItem(cEntry, "Chair", nam.canonical)
Set item = New NotesItem(cEntry, "$BusyName", nam.canonical)
item.IsNames = True
Set item = New NotesItem(cEntry, "RoomTReserve", nam.canonical)
item.IsNames = True
cEntry.AppointmentType = Me.AppType
Select Case Me.AppType
Case 0
Set itemIcon = New NotesItem(cEntry, "_ViewIcon", 160)
Case 1
Set itemIcon = New NotesItem(cEntry, "_ViewIcon", 63)
Case 2
Set itemIcon = New NotesItem(cEntry, "_ViewIcon", 168)
Case 3
Set itemIcon = New NotesItem(cEntry, "_ViewIcon", 9)
Case 4
Set itemIcon = New NotesItem(cEntry, "_ViewIcon", 158)
End Select
itemIcon.IsSummary = True
cEntry.~$BusyPriority = "1"
cEntry.Subject = Me.subject
'----------- Set Date and Times ----------------
cEntry.StartDateTime = Me.startdttm.LSLocalTime
cEntry.StartDate = Me.startdttm.LSLocalTime
cEntry.StartTime = Me.startdttm.LSLocalTime
cEntry.EndDateTime = Me.enddttm.LSLocalTime
cEntry.EndDate = Me.enddttm.LSLocalTime
cEntry.EndTime = Me.enddttm.LSLocalTime
cEntry.calendarDateTime = Me.startdttm.LSLocalTime
'----------- Set Other Fields ----------------
cEntry.~$NoPurge = Me.enddttm.LSLocalTime
cEntry.~$PublicAccess = "1"
cEntry.MailOptions=""
cEntry.tmpWhichList = ""
Set item = New NotesItem(cEntry, "ExcludeFromView", "D")
Call item.AppendToTextList ("S")
cEntry.OrgTable = "C0"
cEntry.Location = Me.strLocation
cEntry.RoomToReserve = Me.varRoom
Set item = New NotesItem(cEntry, "Categories", varCategories)
'cEntry.Categories = "Test"
cEntry.Logo = "stdNotesLtr0"
cEntry.OrgState = "x"
cEntry.Repeats = ""
cEntry.Resources = ""
cEntry.SaveOptions = ""
cEntry.SequenceNum = "1"
cEntry.APPTUNID = cEntry.UniversalID
'//Call cEntry.ComputeWithForm (False,True)
Call cEntry.save(False, True)
Else
CreateSingleEntry = 2 'MalFile cannot be opened
End If
End Function
End Class
Und die Schaltfläche:
Sub Click(Source As Button)
Dim session As New NotesSession
Dim UiWs As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim user As String
Dim CEntry As New CEntry()
Set uidoc = UiWs.CurrentDocument
Set doc = uidoc.Document
CEntry.AppType = "BESPRECHUNG"
CEntry.User = uidoc.FieldGetText("CPerson")
CEntry.Subject = uidoc.FieldGetText("thema")
CEntry.Location = uidoc.FieldGetText("auswahlraum")
CEntry.Room = uidoc.FieldGetText("auswahlraum")
CEntry.Categories = uidoc.FieldGetText("thema")
Set CEntry.StartDT = New NotesDateTime("20.11.2008 14:00:00")
Set CEntry.EndDT = New NotesDateTime("20.11.2008 15:00:00")
Msgbox CEntry.CreateSingleEntry
End Sub
Vielen Dank an alle
