tomcruisew
asked on
VB60 and E-Mail
How can I send a E-mail from an VB60 application ?
Thanks in advance for any help
Thanks in advance for any help
Also if you have a web server you can use CDONTS to do this as well. A lot less hassle then using MAPIMessages.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Create a module with the code below. Then use the SendMail function.
Option Explicit
Const MAPI_Err_FAILURE = 2
Const MAPI_Err_LOGIN_FAILURE = 3
Const MAPI_Err_DISK_FULL = 4
Const MAPI_Err_INSUFFICIENT_MEMO RY = 5
Const MAPI_Err_BLK_TOO_SMALL = 6
Const MAPI_Err_TOO_MANY_SESSIONS = 8
Const MAPI_Err_TOO_MANY_FILES = 9
Const MAPI_Err_TOO_MANY_RECIPIEN TS = 10
Const MAPI_Err_ATTACHMENT_NOT_FO UND = 11
Const MAPI_Err_ATTACHMENT_OPEN_F AILURE = 12
Const MAPI_Err_ATTACHMENT_WRITE_ FAILURE = 13
Const MAPI_Err_UNKNOWN_RECIPIENT = 14
Const MAPI_Err_BAD_RECIPTYPE = 15
Const MAPI_Err_NO_MESSAGES = 16
Const MAPI_Err_INVALID_MESSAGE = 17
Const MAPI_Err_TEXT_TOO_LARGE = 18
Const MAPI_Err_INVALID_SESSION = 19
Const MAPI_Err_TYPE_NOT_SUPPORTE D = 20
Const MAPI_Err_AMBIGUOUS_RECIPIE NT = 21
Const MAPI_Err_MESSAGE_IN_USE = 22
Const MAPI_Err_NETWORK_FAILURE = 23
Const MAPI_Err_INVALID_EDITFIELD S = 24
Const MAPI_Err_INVALID_RECIPS = 25
Const MAPI_Err_NOT_SUPPORTED = 26
Type MapiMessage
Reserved As Long
Subject As String
NoteText As String
MessageType As String
DateReceived As String
ConversationID As String
Flags As Long
RecipCount As Long
FileCount As Long
End Type
Type MapiRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Type MapiFile
Reserved As Long
Flags As Long
Position As Long
PathName As String
FileName As String
FileType As String
End Type
Declare Function MAPISendMail32 Lib "MAPI32.DLL" Alias "BMAPISendMail" _
(ByVal Session&, ByVal UIParam&, Message As MapiMessage, _
Recipient() As MapiRecip, File() As MapiFile, ByVal Flags&, _
ByVal Reserved&) As Long
Declare Function MAPISendMail Lib "MAPI.DLL" Alias "BMAPISendMail" ( _
ByVal Session&, ByVal UIParam&, _
Message As MapiMessage, _
Recipient As MapiRecip, File As MapiFile, ByVal Flags&, ByVal Reserved&) As Long
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_LOGON_UI = &H1
Global DebugVariable As Integer
Sub TestMail()
DebugVariable = DebugVariable + 1
Dim TheMessage As String
Dim Result
TheMessage = "This is a test of the message field"
Result = SendMail("Test number " + Str(DebugVariable), "test@gamemenu.com" _
, "cc@gamemenu.com", "c:\Autoexec.bat", TheMessage)
' Test the result for any errors
If Result <> SUCCESS_SUCCESS Then
MsgBox "Error sending mail: " & Result, 16, "Mail"
Else
MsgBox "Message sent successfully!", 64, "Mail"
End If
End Sub
Sub Mail()
Dim F As Form, Result
Set F = Screen.ActiveForm
' Make sure user has something in the To: box
If IsNull(F!To) Or F!To = "" Then Exit Sub
' Make sure no Null values are in the other boxes
If IsNull(F!Subject) Then F!Subject = ""
If IsNull(F!CC) Then F!CC = ""
If IsNull(F!Attach) Then F!Attach = ""
If IsNull(F!Message) Then F!Message = ""
' Send the message, passing information from the form
Result = SendMail((F!Subject), (F!To), (F!CC), (F!Attach), (F!Message))
' Test the result for any errors
If Result <> SUCCESS_SUCCESS Then
MsgBox "Error sending mail: " & Result, 16, "Mail"
Else
MsgBox "Message sent successfully!", 64, "Mail"
End If
End Sub
Function SendMail(sSubject As String, sTo As String, sCC As String, sAttach As String, sMessage As String)
Dim i, cTo, cCC, cAttach ' variables holding counts
Dim MAPI_Message As MapiMessage
' Count the number of items in each piece of the mail message
cTo = CountTokens(sTo, ";")
cCC = CountTokens(sCC, ";")
cAttach = CountTokens(sAttach, ";")
' Create arrays to store the semicolon delimited mailing
' .. information after it is parsed
ReDim rTo(0 To cTo) As String
ReDim rCC(0 To cCC) As String
ReDim rAttach(0 To cAttach) As String
' Parse the semicolon delimited information into the arrays.
ParseTokens rTo(), sTo, ";"
ParseTokens rCC(), sCC, ";"
ParseTokens rAttach(), sAttach, ";"
' Create the MAPI Recip structure to store all the To and CC
' .. information to be passed to the MAPISendMail function
ReDim MAPI_Recip(0 To cTo + cCC) As MapiRecip
' Setup the "TO:" recipient structures
For i = 0 To cTo - 1
MAPI_Recip(i).Name = rTo(i)
MAPI_Recip(i).RecipClass = MAPI_TO
Next i
' Setup the "CC:" recipient structures
For i = 0 To cCC - 1
MAPI_Recip(cTo + i).Name = rCC(i)
MAPI_Recip(cTo + i).RecipClass = MAPI_CC
Next i
' Create the MAPI File structure to store all the file attachment
' .. information to be passed to the MAPISendMail function
ReDim MAPI_File(0 To cAttach - 1) As MapiFile
' Setup the file attachment structures
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_File(i).Position = 0 'Gives an error if set to -1
MAPI_File(i).PathName = rAttach(i)
MAPI_File(i).FileName = rAttach(i)
Next i
' Set the mail message fields
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = " " + Chr(13) + Chr(10) + sMessage
MAPI_Message.RecipCount = cTo + cCC
' Send the mail message
' Use MAPISendMail for MAPI.DLL
' Use MAPISendMail32 for MAPI32.DLL
SendMail = MAPISendMail32(0&, 0&, MAPI_Message, MAPI_Recip, MAPI_File, MAPI_LOGON_UI, 0&)
End Function
Function CountTokens(ByVal sSource As String, ByVal sDelim As String)
Dim iDelimPos As Integer
Dim iCount As Integer
' Number of tokens = 0 if the source string is empty
If sSource = "" Then
CountTokens = 0
' Otherwise number of tokens = number of delimiters + 1
Else
iDelimPos = InStr(1, sSource, sDelim)
Do Until iDelimPos = 0
iCount = iCount + 1
iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
Loop
CountTokens = iCount + 1
End If
End Function
Function GetToken(sSource As String, ByVal sDelim As String) As String
Dim iDelimPos As Integer
' Find the first delimiter
iDelimPos = InStr(1, sSource, sDelim)
' If no delimiter was found, return the existing string and set
' .. the source to an empty string.
If (iDelimPos = 0) Then
GetToken = Trim$(sSource)
sSource = ""
' Otherwise, return everything to the left of the delimiter and
' .. return the source string with it removed.
Else
GetToken = Trim$(Left$(sSource, iDelimPos - 1))
sSource = Mid$(sSource, iDelimPos + 1)
End If
End Function
Sub ParseTokens(MyArray() As String, ByVal sTokens As String, ByValsDelim As String)
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
'Had the sDelim as a variable instead of ByValsDelim
'You should always use "Option Explicit" to avoid this kind of error
MyArray(i) = GetToken(sTokens, ByValsDelim)
Next
End Sub
Option Explicit
Const MAPI_Err_FAILURE = 2
Const MAPI_Err_LOGIN_FAILURE = 3
Const MAPI_Err_DISK_FULL = 4
Const MAPI_Err_INSUFFICIENT_MEMO
Const MAPI_Err_BLK_TOO_SMALL = 6
Const MAPI_Err_TOO_MANY_SESSIONS
Const MAPI_Err_TOO_MANY_FILES = 9
Const MAPI_Err_TOO_MANY_RECIPIEN
Const MAPI_Err_ATTACHMENT_NOT_FO
Const MAPI_Err_ATTACHMENT_OPEN_F
Const MAPI_Err_ATTACHMENT_WRITE_
Const MAPI_Err_UNKNOWN_RECIPIENT
Const MAPI_Err_BAD_RECIPTYPE = 15
Const MAPI_Err_NO_MESSAGES = 16
Const MAPI_Err_INVALID_MESSAGE = 17
Const MAPI_Err_TEXT_TOO_LARGE = 18
Const MAPI_Err_INVALID_SESSION = 19
Const MAPI_Err_TYPE_NOT_SUPPORTE
Const MAPI_Err_AMBIGUOUS_RECIPIE
Const MAPI_Err_MESSAGE_IN_USE = 22
Const MAPI_Err_NETWORK_FAILURE = 23
Const MAPI_Err_INVALID_EDITFIELD
Const MAPI_Err_INVALID_RECIPS = 25
Const MAPI_Err_NOT_SUPPORTED = 26
Type MapiMessage
Reserved As Long
Subject As String
NoteText As String
MessageType As String
DateReceived As String
ConversationID As String
Flags As Long
RecipCount As Long
FileCount As Long
End Type
Type MapiRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Type MapiFile
Reserved As Long
Flags As Long
Position As Long
PathName As String
FileName As String
FileType As String
End Type
Declare Function MAPISendMail32 Lib "MAPI32.DLL" Alias "BMAPISendMail" _
(ByVal Session&, ByVal UIParam&, Message As MapiMessage, _
Recipient() As MapiRecip, File() As MapiFile, ByVal Flags&, _
ByVal Reserved&) As Long
Declare Function MAPISendMail Lib "MAPI.DLL" Alias "BMAPISendMail" ( _
ByVal Session&, ByVal UIParam&, _
Message As MapiMessage, _
Recipient As MapiRecip, File As MapiFile, ByVal Flags&, ByVal Reserved&) As Long
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_LOGON_UI = &H1
Global DebugVariable As Integer
Sub TestMail()
DebugVariable = DebugVariable + 1
Dim TheMessage As String
Dim Result
TheMessage = "This is a test of the message field"
Result = SendMail("Test number " + Str(DebugVariable), "test@gamemenu.com" _
, "cc@gamemenu.com", "c:\Autoexec.bat", TheMessage)
' Test the result for any errors
If Result <> SUCCESS_SUCCESS Then
MsgBox "Error sending mail: " & Result, 16, "Mail"
Else
MsgBox "Message sent successfully!", 64, "Mail"
End If
End Sub
Sub Mail()
Dim F As Form, Result
Set F = Screen.ActiveForm
' Make sure user has something in the To: box
If IsNull(F!To) Or F!To = "" Then Exit Sub
' Make sure no Null values are in the other boxes
If IsNull(F!Subject) Then F!Subject = ""
If IsNull(F!CC) Then F!CC = ""
If IsNull(F!Attach) Then F!Attach = ""
If IsNull(F!Message) Then F!Message = ""
' Send the message, passing information from the form
Result = SendMail((F!Subject), (F!To), (F!CC), (F!Attach), (F!Message))
' Test the result for any errors
If Result <> SUCCESS_SUCCESS Then
MsgBox "Error sending mail: " & Result, 16, "Mail"
Else
MsgBox "Message sent successfully!", 64, "Mail"
End If
End Sub
Function SendMail(sSubject As String, sTo As String, sCC As String, sAttach As String, sMessage As String)
Dim i, cTo, cCC, cAttach ' variables holding counts
Dim MAPI_Message As MapiMessage
' Count the number of items in each piece of the mail message
cTo = CountTokens(sTo, ";")
cCC = CountTokens(sCC, ";")
cAttach = CountTokens(sAttach, ";")
' Create arrays to store the semicolon delimited mailing
' .. information after it is parsed
ReDim rTo(0 To cTo) As String
ReDim rCC(0 To cCC) As String
ReDim rAttach(0 To cAttach) As String
' Parse the semicolon delimited information into the arrays.
ParseTokens rTo(), sTo, ";"
ParseTokens rCC(), sCC, ";"
ParseTokens rAttach(), sAttach, ";"
' Create the MAPI Recip structure to store all the To and CC
' .. information to be passed to the MAPISendMail function
ReDim MAPI_Recip(0 To cTo + cCC) As MapiRecip
' Setup the "TO:" recipient structures
For i = 0 To cTo - 1
MAPI_Recip(i).Name = rTo(i)
MAPI_Recip(i).RecipClass = MAPI_TO
Next i
' Setup the "CC:" recipient structures
For i = 0 To cCC - 1
MAPI_Recip(cTo + i).Name = rCC(i)
MAPI_Recip(cTo + i).RecipClass = MAPI_CC
Next i
' Create the MAPI File structure to store all the file attachment
' .. information to be passed to the MAPISendMail function
ReDim MAPI_File(0 To cAttach - 1) As MapiFile
' Setup the file attachment structures
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_File(i).Position = 0 'Gives an error if set to -1
MAPI_File(i).PathName = rAttach(i)
MAPI_File(i).FileName = rAttach(i)
Next i
' Set the mail message fields
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = " " + Chr(13) + Chr(10) + sMessage
MAPI_Message.RecipCount = cTo + cCC
' Send the mail message
' Use MAPISendMail for MAPI.DLL
' Use MAPISendMail32 for MAPI32.DLL
SendMail = MAPISendMail32(0&, 0&, MAPI_Message, MAPI_Recip, MAPI_File, MAPI_LOGON_UI, 0&)
End Function
Function CountTokens(ByVal sSource As String, ByVal sDelim As String)
Dim iDelimPos As Integer
Dim iCount As Integer
' Number of tokens = 0 if the source string is empty
If sSource = "" Then
CountTokens = 0
' Otherwise number of tokens = number of delimiters + 1
Else
iDelimPos = InStr(1, sSource, sDelim)
Do Until iDelimPos = 0
iCount = iCount + 1
iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
Loop
CountTokens = iCount + 1
End If
End Function
Function GetToken(sSource As String, ByVal sDelim As String) As String
Dim iDelimPos As Integer
' Find the first delimiter
iDelimPos = InStr(1, sSource, sDelim)
' If no delimiter was found, return the existing string and set
' .. the source to an empty string.
If (iDelimPos = 0) Then
GetToken = Trim$(sSource)
sSource = ""
' Otherwise, return everything to the left of the delimiter and
' .. return the source string with it removed.
Else
GetToken = Trim$(Left$(sSource, iDelimPos - 1))
sSource = Mid$(sSource, iDelimPos + 1)
End If
End Function
Sub ParseTokens(MyArray() As String, ByVal sTokens As String, ByValsDelim As String)
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
'Had the sDelim as a variable instead of ByValsDelim
'You should always use "Option Explicit" to avoid this kind of error
MyArray(i) = GetToken(sTokens, ByValsDelim)
Next
End Sub
Best Regards,
- Tom