Пример кода для отправки письма через Lotus Notes
Public opt_strLotusLocalBase As String 'адрес локальной базы Лотуса
'Public opt_strFrom As String 'поле "от" ''Public strSubject As String 'заголовок письма Public opt_intImportance As Integer 'важность док-та(Высокая = 1, Обычная = 2, Низкая = 3) Public opt_strPriority As String 'приоритет доставки(Высокий = "H",Обычный = "N",Низкий = "L")
Public opt_strLetter As String 'текст письма Public opt_strFile As String 'адрес прикрепленного файла
Public opt_strFolderName As String 'адрес папки с прикрепляемыми файлами ''Public blnSend As Boolean 'флаг отправки ''Public blnDraft As Boolean 'флаг черновика ''Public rstSendTo As DAO.Recordset 'набор адресов получателей Public opt_strSenderTag As String 'иконка в теле письма ("G")
Public opt_intViewIcon As Integer 'иконка в столбце "Кто" (85)
Public Function InLotusFromAccess(strSubject As String, rstSendTo As DAO.Recordset, blnSend As Boolean, intMessage As Integer, Optional rstCopyTo As DAO.Recordset = Nothing) As Boolean
On Error GoTo Err_InLotusFromAccess Dim objLotusApp As Object, objDb As Object, objDoc As Object, objRtitem As Object, objTextStyle As Object
Dim strAdr() As String, strAdrCopy() As String, objEmbed As Object, intI As Integer
Dim fs As Scripting.FileSystemObject Dim fl As Scripting.File Dim fldr As Scripting.Folder
If IsNull(opt_intImportance) Or opt_intImportance = 0 Then opt_intImportance = 2 If IsNull(opt_strPriority) Or opt_strPriority = "" Then opt_strPriority = "N"
Set objLotusApp = CreateObject("notes.notesSession") If opt_strLotusLocalBase <> "" Then 'отправка из локальной почты
Set objDb = objLotusApp.getDatabase("", opt_strLotusLocalBase) Else 'отправка из почты по умолчанию Set objDb = objLotusApp.getDatabase(objLotusApp.GetEnvironmentString("mailserver", True), objLotusApp.GetEnvironmentString("MailFile", True))
End If DoEvents 'массив адресов получателей If rstSendTo.RecordCount > 0 Then rstSendTo.MoveLast rstSendTo.MoveFirst For intI = 0 To rstSendTo.RecordCount - 1
ReDim Preserve strAdr(intI) strAdr(intI) = IIf(IsNull(rstSendTo.Fields(0)), "", rstSendTo.Fields(0)) rstSendTo.MoveNext Next intI Else ReDim Preserve strAdr(0) strAdr(intI) = ""
blnSend = False End If If Not rstCopyTo Is Nothing Then
If rstCopyTo.RecordCount > 0 Then rstCopyTo.MoveLast rstCopyTo.MoveFirst For intI = 0 To rstCopyTo.RecordCount - 1
ReDim Preserve strAdrCopy(intI) strAdrCopy(intI) = IIf(IsNull(rstCopyTo.Fields(0)), "", rstCopyTo.Fields(0)) rstCopyTo.MoveNext Next intI Else ReDim Preserve strAdrCopy(0) strAdrCopy(intI) = ""
End If End If Set objDoc = objDb.CREATEDOCUMENT() 'важность док-та objDoc.Importance = CStr(opt_intImportance) 'приоритет доставки
objDoc.DeliveryPriority = opt_strPriority 'подписывать objDoc.SignOnSend = True 'шифровать objDoc.EncryptOnSend = True objDoc.Form = "Memo" objDoc.Subject = strSubject objDoc.SendTo = strAdr objDoc.CopyTo = strAdrCopy 'objDoc.From = opt_strFrom 'в черновики или в отправленные If blnSend Then
objDoc.PosteDdate = Now() End If 'значок в теле письма Call objDoc.AppendItemValue("SenderTag", opt_strSenderTag) 'значок в столбце "Кто" Call objDoc.AppendItemValue("_ViewIcon", opt_intViewIcon)
'создать поле "Body" типа RichText Set objRtitem = objDoc.createRichtextItem("Body") If opt_strLetter <> "" Then
Call objRtitem.AppendText(opt_strLetter) End If If opt_strFile <> "" Then 'вложение конкретного файла
Set objEmbed = objRtitem.EmbedObject(1454, "", opt_strFile) ElseIf opt_strFolderName <> "" Then Set fs = CreateObject("Scripting.FileSystemObject") Set fldr = fs.GetFolder(opt_strFolderName) For Each fl In fldr.Files Set objEmbed = objRtitem.EmbedObject(1454, "", opt_strFolderName & "\" & IIf(IsNull(fl.Name), "", fl.Name)) Call objRtitem.AddNewLine(1) 'перевод строки
Next fl Set fs = Nothing Set fl = Nothing Set fldr = Nothing
End If 'сохранить док-т Call objDoc.Save(True, True) 'отправлять? If blnSend Then Call objLotusApp.SETENVIRONMENTVAR("MAIL_SKIP_NOKEY_DIALOG", CStr(intMessage), True)
'отправить без сохранения в документе формы Call objDoc.SEND(False) Call objLotusApp.SETENVIRONMENTVAR("MAIL_SKIP_NOKEY_DIALOG", "0", True) End If
InLotusFromAccess = True objLotusApp.Close
Exit_InLotusFromAccess: Set objEmbed = Nothing Set objRtitem = Nothing
Set objDoc = Nothing Set objDb = Nothing Set objLotusApp = Nothing
Exit Function
Err_InLotusFromAccess: Select Case Err.Number Case 7000 'отмена отправки письма
Case 9999 MsgBox "Ошибка при доступе к базе LOTUS @ Запустите LOTUS, разблокируйте учетную запись" Case Else
If Err.Number <> 429 Then objLotusApp.Close End If
MsgBox Err.Number & " " & Err.Description End Select InLotusFromAccess = False Resume Exit_InLotusFromAccess
End Function Просмотров: 13529
Ваш коментарий будет первым | | |