Rambler's Top100
Навигация
Главная
MS ACCESS
VB
ASP
PHP
Наши друзья
Поиск
Форум
Лента новостей
Новый сайт

Online
Рассылки Subscribe.Ru
Работа с MS Access
Подписаться письмом
Реклама на сайте
 
Главная arrow MS ACCESS arrow Отправка письма из ACCESS используя Lotus Notes
Отправка письма из ACCESS используя Lotus Notes Печать E-mail
Автор АндрейК   
17.10.2011 г.

Пример кода для отправки письма через 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

  Ваш коментарий будет первым

Добавить коментарий
Имя:
E-mail
Коментарий:



Код:* Code

 
Реклама на сайте
HiProg.com - Технологии программирования
Rambler's Top100 TopList