Отправка с помощью MAPI контролей.

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'
     &

Ответить

ShellExecute Me.hwnd, "open", "mailto:mail@mail.ru?subject=Subject&Body=Body Text& .... ", 0, 0, 0 . Чем плох чистый HTML?

Ответить

2 boevik!

Пришли пример пожалуйста!

privmail@nm.ru

иль ссылку кинь!

Ответить

?Morpheus: Приведенный выше текст это модуль который занимается отправкой писем. Контроли лежат на одной из форм.

Сам проэкт не маленький, поетому и не хочу высылать. Если не хватает какой либо функции, сообщи и посмотрю, что можно сделать.

Ответить

With Flds

.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort

.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = имя или IP сервера

.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10

.Update()

End With

With cMsg

.Configuration = cConfig

.To = sList

.From = отправитель

.Subject = ...

.TextBody = ......

.AddAttachment(имя файла)

.Send()

End With

Ответить

А как сделать чтобы когда письмо попадало на почту оно сканировало Адр к нигу и рассылалось по всем этим адресам. Хе хе

Ответить

Ответить

To Colbasna

Вот линк. http://support.microsoft.com/default.aspx?scid=kb;en-us;313797

Ответить