Отправка
почты с аттачментом из VB-приложения
'***************************************************************
'Windows API/Global Declarations for :SendMail
'***************************************************************
Source Code:
Note:This code is formatted to be pasted directly into VB.
Pasting it into other editors may or may not work.
'***************************************************************
' Name: SendMail
' Description:This routine Sends mail with attachment to anybody
' you specify
' By: Whatever
'
'
' Inputs:From : Sender (your profile)
To: Recipient
Subject:
Text: Text Body
UI: 0=open Mail User Interfase
Atta: Attachment (separated by ;)
'
' Returns:None
'
'Assumes:None
'
'Side Effects:Be aware of passing all the parameters with data
'(atta is aptional)
'
'Code provided by Planet Source Code(tm) (http://www.PlanetSource
' Code.com) 'as is', without warranties as to performance, fitness,
' merchantability,and any other warranty (whether expressed or
' implied).
'***************************************************************
Sub MSnAB(FromName As String, ToName As String, Subject As String, _
Text As String, UI As Integer, Atta As String)
Dim Count As Integer
Static Address(0 To 30) As String
On Error Goto MAILERROR
MAPIAUX.MSESS.UserName = FromName
MAPIAUX.MSESS.SignOn
MAPIAUX.MMSG.SessionID = MAPIAUX.MSESS.SessionID
MAPIAUX.MMSG.Compose
Call ParseAddress(ToName, Count, Address())
For I = 0 To Count - 1
MAPIAUX.MMSG.RecipIndex = I
MAPIAUX.MMSG.RecipType = mapToList
MAPIAUX.MMSG.RecipDisplayName = Address(I)
MAPIAUX.MMSG.ResolveName
Next I
MAPIAUX.MMSG.MsgSubject = Subject
MAPIAUX.MMSG.MsgNoteText = Text & Chr$(13)
If Trim$(Atta)<> "" And Dir(Trim$(Atta)) <>"" Then
MAPIAUX.MMSG.AttachmentIndex =MAPIAUX.MMSG.AttachmentCount
MAPIAUX.MMSG.AttachmentType = 0
MAPIAUX.MMSG.AttachmentPathName = Trim$(Atta)
MAPIAUX.MMSG.AttachmentPosition = Len(Text)
End If
If UI <> 0 Then
MAPIAUX.MMSG.Send
Else
MAPIAUX.MMSG.Send True
End If
MAPIAUX.MSESS.SignOff
Exit Sub
MAILERROR:
c = Err
B = Error$
MsgBox " Mail Function Error " & Error$
MAPIAUX.MSESS.SignOff
End Sub
Sub ParseAddress (ANames As String, Count As Integer, Addrs() As String)
Dim CPos As Integer
Dim VPos As Integer
Dim SPos As Integer
I = 0
SPos = 1
CPos = 0
Do
CPos = InStr(ANames, ";")
If CPos = 0 Then VPos = Len(ANames) + 1 Else VPos = CPos
Addrs(I) = Mid$(ANames, SPos, VPos - SPos)
I = I + 1
ANames = Right$(ANames, Len(ANames) - CPos)
Loop While CPos > 0
Count = I
End Sub
|