Онлайн кредиты займы Казахстан онлайн кредиты усть-каманеногорск кредиты онлайн алматы взять онлайн займ в Казахстане гта5 играть на компьютере Pole Dance алматы играть онлайн форсаж 8 pokemon go играть вот ссылка гороскоп совместимости любовный гороскоп на 2017 рак девушка сексуальный гороскоп он телец она рыбы гороскопы близнецов любовный одиночные любовный любовный гороскоп гороскоп совместимости совместимость знаков в любви любовный гороскоп для рыб на сегодня и на завтра любовный гороскоп знака водолей гороскоп совместимости парень козерог девушка весы гороскоп совместимость гороскоп на месяц любовный рак основываясь на этих данных гороскоп женщина рыба мужчина весы совместимость гороскоп совместимости смотрите подробнее гороскоп на эту неделю стрелец любовный гороскоп дева любовный на сегодня и завтра гороскоп любви весы на завтра вот ссылка сексуальный гороскоп девы и овна гороскоп на совместимость телец и рыбы рак на сегодня гороскоп любовь гороскоп весы гороскоп совместимости для рыб на 2017 гороскоп семейный и любовный на сегодня гороскоп рак любовный совместимость по гороскопу женщина телец мужчина рак совместимость гороскоп секс гороскоп совместимости гороскоп телец мужчина женщина скорпион совместимость гороскоп любовный гороскоп любовный узнать больше перейти гороскоп совместимости любовный гороскоп двух львов гороскоп на неделю телец любовный гороскоп стрелец женщина и весы мужчина совместимость в браке гороскоп совместимости весы жен овен муж гороскоп совместимости сексуальный гороскоп совместимости гороскоп сегодня совместимость гороскопу источник статьи гороскоп козы ссылка на страницу гороскоп весы и лев любовный гороскоп совместимость совместимость по гороскопу рыба и дева гороскоп для женщины рак на сегодня любовь читать больше гороскоп пифагора совместимости знаков зодиака совместимость овен и лев по гороскопу подробнее на этой странице гороскоп гороскоп сексуальный любовный гороскоп ссылка совместимость свиньи и петуха по восточному гороскопу гороскоп совместимости гороскоп совместимости гороскоп на совместимость женщина телец любовный гороскоп гороскоп дева совместимость гороскопов лев скорпион гороскоп гороскоп гороскоп совместимости рыба тигр любовный гороскоп женщина козерог 2017 любовный гороскоп козерог на сегодня женщина любовный гороскоп для девы на сегодня и завтра гороскоп стрелец гороскоп на тельца на совместимость гороскоп на сегодня дева на оракул любовный гороскоп совместимости по знакам зодиака овен и водолей
Rambler's Top100
Российский фонд помощи
Навигация
Главная
MS ACCESS
VB
ASP
PHP
Наши друзья
Поиск
Форум
Лента новостей
Новый сайт

Online
Сейчас на сайте находятся:
1 гость
Рассылки 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

Просмотров: 10392

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

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



Код:* Code

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