%REM
Sub SendInvition
Description: создает и отправляет приглашение в календарь outlook
idoc - Документ приглашение из БД заседания
lst - готовый список получателей
lst2 - готовый список получателей замов\секретарей
%END REM
Sub SendInvition ( idoc As NotesDocument, lst As Variant, lst2 As Variant)
On Error GoTo Handler
Dim invitation As NotesDocument
Dim item As NotesItem
Dim startdttm As NotesDateTime
Dim startdt As NotesDateTime ' стартовая дата
Dim starttm As NotesDateTime ' стартовое время
Dim enddttm As NotesDateTime
Dim rtitem As NotesRichTextItem
Dim prompt As String
Dim language As String
Dim tasktype As String
Dim line1 As String
Dim tmpItem As NotesItem
Dim db As NotesDatabase
Dim ses As New NotesSession
Dim frm As String
frm = "КомпаниМедиа <CM@firma.ru>"
'Dim nn As New NotesName(frm)
'Compute SendTo and CopyTo items
Dim SendTo$, CopyTo$
SendTo$ = " <SV@firma.ru>"
Set db= ses.currentdatabase
Set invitation = New NotesDocument( db )
With invitation
.ReplaceItemValue "$altPrincipal", frm
.ReplaceItemValue "$CSVersion", "2"
.ReplaceItemValue "$EncryptionStatus", "0"
.ReplaceItemValue "$PublicAccess", "1"
.ReplaceItemValue "$SignatureStatus", "0"
.ReplaceItemValue "$SMTPKeepNotesItems", "1"
.ReplaceItemValue "AppointmentType", "3" '3
.ReplaceItemValue "Broadcast", "1"
.ReplaceItemValue "Encrypt", "0"
.ReplaceItemValue "Form", "Notice"
.ReplaceItemValue "PreventCounter", "1"
.ReplaceItemValue "PreventDelegate", "1"
.ReplaceItemValue "Principal", frm
.ReplaceItemValue "From", frm
.ReplaceItemValue "InetFrom", frm
.ReplaceItemValue "SendTo", lst 'SendTo$
.ReplaceItemValue "Recipients", lst
.ReplaceItemValue "RequiredAttendees", lst
.ReplaceItemValue "CopyTo", lst2
.ReplaceItemValue "SequenceNum", 1
Set tmpItem = New NotesItem(invitation, "StorageRequiredNames", "1", NAMES)
tmpItem.IsSummary = True
.ReplaceItemValue "UpdateSeq", 1
.ReplaceItemValue "$CSWISL", Evaluate({@Explode("$S:1;$L:1;$B:1;$R:1;$E:1;$W:1;$O:1;$M:1;RequiredAttendees:1;INetRequiredNames:1;AltRequiredNames:1;StorageRequiredNames:1;OptionalAttendees:1;INetOptionalNames:1;AltOptionalNames:1;StorageOptionalNames:1"; ";")})
.ReplaceItemValue "$HFFlags", "1"
.ReplaceItemValue "$IconSwitcher", "Meeting"
.ReplaceItemValue "$StorageCc", ""
.ReplaceItemValue "$StorageTo", "1"
.ReplaceItemValue "$TableSwitcher", "FindAvailTimes"
.ReplaceItemValue "$WatchedItems", Evaluate({@Explode("$S;$L;$B;$R;$E;$W;$O;$M;RequiredAttendees;INetRequiredNames;AltRequiredNames;StorageRequiredNames
;OptionalAttendees;INetOptionalNames;AltOptionalNames;StorageOptionalNames"; ";")})
.ReplaceItemValue "ApptUNID", .UniversalID
.ReplaceItemValue "IsBroadcast", "0"
.ReplaceItemValue "Logo", "StdNotesLtr25"
.ReplaceItemValue "NoticeType", "I"
.ReplaceItemValue "OrgTable", "C0"
.ReplaceItemValue "SchedulerSwitcher", "1"
.ReplaceItemValue "Sign", ""
.ReplaceItemValue "Subject", "Приглашение на заседание " + idoc.SDof(0)
.ReplaceItemValue "_ViewIcon", 133
.Replaceitemvalue "Location", idoc.SovetAddr(0)
End With
'Set the Body RT field
Set rtitem = New NotesRichTextItem(invitation, "Body" )
Call rtitem.Appendrtitem(idoc.Getfirstitem("Text"))
Call rtitem.Addnewline(2)
'устанавливаем поля даты и времени , продолжительность 1 час
Dim dtitem As NotesItem
Dim tmitem As NotesItem
Set dtitem = idoc.Getfirstitem("SovetDate")
Set tmitem = idoc.Getfirstitem("SovetTime")
Set Startdt = dtitem.Datetimevalue
Set Starttm = tmitem.Datetimevalue
Set startdttm = New NotesDateTime( Startdt.Dateonly +" "+ Starttm.Timeonly)
'Print "ДАТА1: " startdttm.Dateonly +" "+ startdttm.Timeonly
Set enddttm = New NotesDateTime( Startdt.Dateonly +" "+ Starttm.Timeonly)
Call enddttm.Adjusthour(1)
'Print "ДАТА2: " enddttm.Dateonly +" "+ enddttm.Timeonly
Set invitation.StartDateTime = startdttm '.LocalTime
invitation.StartDate = startdttm.Dateonly 'startdttm '.LocalTime
invitation.StartTime = startdttm.Timeonly 'startdttm '.LocalTime
invitation.StartTimeZone = Evaluate({@GetCurrentTimeZone})
Set invitation.EndDateTime = enddttm '.LocalTime
invitation.EndDate = enddttm.Dateonly'enddttm '.LocalTime
invitation.EndTime = enddttm.Timeonly 'enddttm '.LocalTime
invitation.EndTimeZone = Evaluate({@GetCurrentTimeZone})
On Error 4294 Resume next
Invitation.Send(False)
Exit sub
Handler:
Print "Ошибка в Agent Отправить приглашение в календарь в Sub SendInvition: " & Error & +Str(Err)+" в строке " & CStr(Erl())
Exit sub
End Sub
