Как послать из VB по почте письмо с аттачем?

[Павел]

Пробовал разные варианты контролов, но они все умеют посылать только письма без аттачей. Посоветуйте, что делать?

[boevik]

Используя MAPI контроли

Код: Выделить всё

Option Explicit

Private Const SESSION_SIGNON = 1
Private Const MESSAGE_COMPOSE = 6
Private Const ATTACHTYPE_DATA = 0
Private Const RECIPTYPE_TO = 1
Private Const RECIPTYPE_CC = 2
Private Const MESSAGE_RESOLVENAME = 13
Private Const MESSAGE_SEND = 3
Private Const SESSION_SIGNOFF = 2

Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_SZ = 1
Private Const KEY_QUERY_VALUE = &H1
Private Const BUFFER_SIZE = 255
Private Const RESERVED_VALUE As Long = 0

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Any, ByRef lpcbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long


Public Sub SendEmail()
    Dim oldValue As Byte
    Dim msTo As String
    Dim msSubject As String
    Dim msFile As String
    Dim msBody As String
   
    LoadMessageDefinitions msTo, msSubject, msFile, msBody
   
    On Error GoTo Err_MAPIUse
         'Open up a MAPI session:
         oldValue = SetSendImmediatly
         With frmMain.MAPISession1
             .LogonUI = False
             .UserName = ReadDefaultProfile
             .DownLoadMail = False
             .Action = SESSION_SIGNON
         End With
         'Point the MAPI messages control to the open MAPI session:
         With frmMain.MAPIMessages1
             .SessionID = frmMain.MAPISession1.SessionID
             .Compose                         'Start a new message
             .MsgSubject = msSubject         'Set the subject of the message:
             'Set the message content:
             .MsgNoteText = msBody
             .AttachmentPathName = msFile
             'Set the recipients
             .RecipIndex = 0                    'First recipient
             .RecipType = RECIPTYPE_TO          'Recipient in TO line
             .RecipDisplayName = msTo          'e-mail name
             'MESSAGE_RESOLVENAME checks to ensure the recipient is valid and puts
             'the recipient address in MapiMessages1.RecipAddress
             'If the E-Mail name is not valid, a trappable error will occur.
             .ResolveName
             'Send the message:
             .Send
         End With
         'Close MAPI mail session:
         frmMain.MAPISession1.Action = SESSION_SIGNOFF
         'restore old value
         If oldValue = 0 Then SetSendImmediatly (False)
         Exit Sub
   
Err_MAPIUse:
   
    If frmMain.MAPIMessages1.SessionID <> 0 Then frmMain.MAPISession1.Action = SESSION_SIGNOFF
    Err.Raise Err.Number, "SendMail.modSendMessage.SendEmail " & _
        "Version: " & App.Major & "." & App.Minor & "." & App.Revision & _
        " At line: " & Erl & vbNewLine & Err.Source, Err.Description
   
End Sub

Private Function ReadDefaultProfile() As String
    Dim ret  As Long
    Dim pKey As Long
    Dim strVal As String
    Dim lLen As Long
    Dim lType As Long
   
    ret = RegOpenKeyEx(HKEY_CURRENT_USER, "Software\Microsoft\Windows Messaging Subsystem\Profiles", RESERVED_VALUE, KEY_QUERY_VALUE, pKey)
    strVal = Space(BUFFER_SIZE)
    lLen = BUFFER_SIZE
    ret = RegQueryValueEx(pKey, "DefaultProfile", RESERVED_VALUE, lType, strVal, lLen)
    ReadDefaultProfile = Left(strVal, lLen - 1)
    RegCloseKey pKey
End Function


Private Function SetSendImmediatly(Optional ByVal bImmediatly As Boolean = True) As Byte
         'This function set Outlook Express option 'Send Mail Immediately'
         'return:
         '   0 or 1  - previous value
         '   2       - it isn't defined
   
    Const KEYIDENTITY As String = "Identities"
    Const DEFAULTUSERID As String = "Default User ID"
    Const KEYMAIL As String = "\Software\Microsoft\Outlook Express\5.0\Mail"
   
    Dim bSuccess As Boolean
    Dim sIdentity As String
    Dim sFullKeyMail As String
    Dim btSendImmediately As Byte
    Dim sTmp As String
    Dim oReg As New RegAPI
   
    sIdentity = oReg.GetRegValue(HKEY_CURRENT_USER, KEYIDENTITY, DEFAULTUSERID, bSuccess)
    sFullKeyMail = KEYIDENTITY & "\" & sIdentity & KEYMAIL
    sTmp = oReg.GetRegValue(HKEY_CURRENT_USER, sFullKeyMail, "Send Mail Immediately", bSuccess)
    If Not bSuccess Then
        SetSendImmediatly = 2
        Exit Function
    End If
    btSendImmediately = Asc(Left(sTmp, 1))
         'set to false and current setting is true
         If bImmediatly = False And btSendImmediately = 1 Then Call oReg.SetRegValueEx(HKEY_CURRENT_USER, sFullKeyMail, "Send Mail Immediately", REG_DWORD, Chr(0))
         'set to true and current setting is false
         If bImmediatly = True And btSendImmediately = 0 Then Call oReg.SetRegValueEx(HKEY_CURRENT_USER, sFullKeyMail, "Send Mail Immediately", REG_DWORD, Chr(1))
         SetSendImmediatly = btSendImmediately
End Function


[v-adix]

лучше качай готовый исходник
ftp://v-adix@ftp.narod.ru/files2/messager.rar
www.v-adix.narod.ru/files2/messager.rar