Разработка баз данныхРазработка баз данных

Application.FollowHyperlink "mailto:kozin@mail.ru?subject=для проверки не забудь сменить адресата на свой &body=текст сообщения ", , True

только подготовка письма к отправке

3. Использование MAPI

Позволяет прикреплять несколько файлов
Работает через почтовую программу, назначенную почтовым клиентом по умолчанию:
(например MSOutlookExpress или MSOutlook)

Public Sub testSengMultyattach()
      Const SESSION_SIGNON = 1
      Const MESSAGE_COMPOSE = 6
      Const ATTACHTYPE_DATA = 0
      Const RECIPTYPE_TO = 1
      Const RECIPTYPE_CC = 2
      Const MESSAGE_RESOLVENAME = 13
      Const MESSAGE_SEND = 3
      Const SESSION_SIGNOFF = 2
Dim MS 'MAPI Session
Dim Msgs
Set MS = CreateObject("MSMAPI.mapiSession.1")
Set Msgs = CreateObject("MSMAPI.mapiMessages.1")
MS.signon
Msgs.sessionid = MS.sessionid
Msgs.compose
Msgs.msgsubject = "I test you sample "
Msgs.msgnotetext = "This works"
Msgs.RecipIndex = 0                    'First recipient
Msgs.RecipType = RECIPTYPE_TO
Msgs.RecipDisplayName = "kozin@mail.ru"         'Recipient in TO line. this my mail :))

Msgs.AttachmentType = 0
Msgs.AttachmentIndex = 0
Msgs.AttachmentPathName = "c:\CONFIG.SYS"
Msgs.AttachmentPosition = 0

Msgs.AttachmentIndex = 1  'next number !!!
Msgs.AttachmentPathName = "c:\autoexec.bat"
Msgs.AttachmentPosition = 1

'ask to commit
Msgs.send ("1")
'or send auto
'Msgs.Action = MESSAGE_SEND

'Close MAPI mail session:
MS.Action = SESSION_SIGNOFF
End Sub

4. Использование CDO

Private Sub SendCDOmail()
Dim Msg 'As CDO.Message
Set Msg = CreateObject("CDO.Message")
Dim mailaddress As String
Dim Msghtml As String
mailaddress = "kozin@mail.ru"
Msghtml = "<HTML><h2>См. вложения</h2></HTML>"
With Msg
   .HTMLBody = Msghtml
   .AddAttachment ("c:\autoexec.bat")
   .To = """Administratior"" <" & mailaddress & ">"
   .FROM = """Робомэйл"" <mailservice@mailserver.ru>"
   .Send
End With
Set Msg = Nothing
End Sub

Для использования CDO должна быть установлена библиотека "Microsoft CDO for Exchange 2000" (c оперционными системами начиная с Windows 2000 установка не требуется т.к. устанавливается при установки OS)

Преимущество CDO перед вышеупомянутыми способами - не требуется наличие установленной и настроеннй для конкретного пользователя почтовой программы.

Дополнительные материалы:

Отправка со специфичными параметрами сервера.

Private Function SendCDOmail(mailaddress As String, filename) As String
'Возвращает пустую строку если отправка удалась иначе описание ошибки
     On Error GoTo errh:
     Dim Msg 'As CDO.Message
     Set Msg = CreateObject("CDO.Message")

     Dim Msghtml As String
     Msghtml = "<HTML><h2>См. вложения</h2></HTML>"
     Msg.HTMLBody = Msghtml
     Msg.AddAttachment (filename)


'конфигурация отправки по SMTP, для использования дефолтных
'настроек системы можно не указывать
'Константы не менять!!!!

With Msg.Configuration.Fields
Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSendUsingPort = 2
  .Item(cdoSendUsingMethod) = cdoSendUsingPort
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
  .Item(cdoSMTPServer) = "192.168.2.3" 'IP адрес вашего SMTP сервера
Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
  .Item(cdoSMTPConnectionTimeout) = 360 'Секунды
Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
'Const cdoBasic = 1
Const cdoAnonymous = 0
  .Item(cdoSMTPAuthenticate) = cdoAnonymous
End With
Msg.Configuration.Fields.Update
With Msg
    .To = """ Кому "" <" & mailaddress & ">"
    .FROM = """Робомэйл"" <имя@домен.ru>"
    .Send
End With
Exit Function
errh:
SendCDOmail = Err.Description
End Function

Архивация файла перед отправкой

Private Function MoveFileToARC(filename As String)
'Для архивации используется консольное приложение rar
'используется путь установки WinRaR по умолчанию
'Возвращает имя файла - архива
    Dim rarfile As String
    rarfile = Environ("tmp") & "\" & Fix(Timer) & Replace(filename, ".xls", ".rar", , , vbTextCompare)

    On Error Resume Next
    Kill rarfile
    On Error GoTo 0

    If Trim(filename) = "" Then MsgBox "Необходимо имя файла": Exit Function

    ' RAR <команда> -<ключ 1> -<ключ N> <архив> <файлы...>
    Dim OShell
    Set OShell = CreateObject("WScript.Shell")
    Dim DosCommand
    DosCommand = Chr(34) & Environ("programfiles") & "\winrar\rar.exe ""  a  -ep " & rarfile & " " & Environ("tmp") & "\" & filename
    'Debug.Print DosCommand
    DoEvents
    Call OShell.Run(DosCommand, 2, True)
    DoEvents
    On Error Resume Next
    Kill Environ("tmp") & "\" & filename
    On Error GoTo 0
    If Dir(rarfile) <> "" Then MoveFileToARC = rarfile
End Function

Пример использования:

Private Sub sendmail_Click()
If Nz(Me.mailaddress, "") = "" Then MsgBox "Не указан почтовый адрес": Exit Sub
    Dim ARCfile, srcfile As String
    DoCmd.Hourglass True
    srcfile = "c:\autoexec.bat"
    ARCfile = MoveFileToARC(srcfile)
    If ARCfile = "" Then MsgBox "Ошибка архивации файла ": Exit Sub
    Dim sendresult
    sendresult = SendCDOmail(Me.mailaddress, ARCfile)
    Kill ARCfile
    DoCmd.Hourglass False

    If sendresult <> "" Then
        MsgBox "Ошибка отправки файла по email:" & sendresult
    Else
        DoCmd.Close acForm, Me.name
        MsgBox "Файл " & srcfile & " Успешно отправлен."
    End If

End Sub

эта вебстраница является зеркалом сайта www.msdatabase.ru