by GuRu (1 Submission)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sun 30th September 2007
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Code to send email
VBcoders
Dim strSubURL As String
Dim strAlias As String
Dim strUserName As String
Dim strPassWord As String
Dim strExchSvrName As String
Dim strFrom As String
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim bResult As Boolean
' Exchange Server Name.
strExchSvrName = "ExchangeServerName"
' Alias of the sender.
strAlias = "user1"
' User Name of the sender.
strUserName = "DomainName\user1"
' Password of the sender.
strPassWord = "password"
' Email address of the sender.
strFrom = "[email protected]"
' Email address of recipient.
strTo = "[email protected]"
' Subject of the mail.
strSubject = "Mail Subject"
' Text body of the mail.
strBody = "Mail Body"
strSubURL = FindSubmissionURL(strExchSvrName, _
strAlias, _
strUserName, _
strPassWord)
If strSubURL <> "" Then
bResult = False
bResult = SendMail(strSubURL, _
strFrom, _
strTo, _
strSubject, _
strBody, _
strUserName, _
strPassWord)
If bResult Then
MsgBox "Successfully send mail via WebDAV!"
End If
End If
End Sub
Function FindSubmissionURL(strExchSvr, _
strAlias, _
strUserName, _
strPassWord) As String
Dim query As String
Dim strURL As String
Dim xmlRoot As IXMLDOMElement
Dim xmlNode As IXMLDOMNode
Dim baseName As String
'To use MSXML 2.0 use the following Dim statements
Dim xmlReq As MSXML.XMLHTTPRequest
Dim xmldom As MSXML.DOMDocument
Dim xmlAttr As MSXML.IXMLDOMAttribute
'To use MSXML 4.0 use the following Dim statements
'Dim xmlReq As MSXML2.XMLHTTP40
'Dim xmldom As MSXML2.DOMDocument40
'Dim xmlAttr As MSXML2.IXMLDOMAttribute
'namespacemanager.declarePrefix "d", "urn:schemas:httpmail:"
'On Error GoTo ErrHandler
' Create the DAV PROPFIND request.
Set xmlReq = CreateObject("Microsoft.XMLHTTP")
'To use MSXML 4.0 use the following set statement
' Set xmlReq = CreateObject("Msxml2.XMLHTTP.4.0")
strURL = "http://" & strExchSvr & "/exchange/" & strAlias
xmlReq.Open "PROPFIND", strURL, False, strUserName, strPassWord
xmlReq.setRequestHeader "Content-Type", "text/xml"
xmlReq.setRequestHeader "Depth", "0"
query = "<?xml version='1.0'?>"
query = query + "<a:propfind xmlns:a='DAV:'>"
query = query + "<a:prop xmlns:m='urn:schemas:httpmail:'>"
query = query + "<m:sendmsg/>"
query = query + "</a:prop>"
query = query + "</a:propfind>"
xmlReq.send (query)
MsgBox xmlReq.Status
' process the result
If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
' MsgBox "Success! " & "PROPFIND Results = " & xmlReq.Status & _
' ": " & xmlReq.statusText
Set xmldom = xmlReq.responseXML
Set xmlRoot = xmldom.documentElement '.documentElement
'To use MSXML 2.0 use the following code to get the Submission URL
For Each xmlAttr In xmlRoot.Attributes
If xmlAttr.Text = "urn:schemas:httpmail:" Then
baseName = xmlAttr.baseName
Exit For
End If
Next
Set xmlNode = xmlRoot.selectSingleNode("//" & baseName & ":sendmsg")
FindSubmissionURL = xmlNode.Text
' To use MSXML 4.0 use the following lines of code to get the Submission URL
' Dim objNodeList As IXMLDOMNodeList
' Set objNodeList = xmlRoot.getElementsByTagName("d:sendmsg")
' For i = 0 To (objNodeList.length - 1)
' FindSubmissionURL = objNodeList.Item(i).Text
' Next
Else
MsgBox "Failed to find mail submission URL"
FindSubmissionURL = ""
End If
ErrExit:
Set xmlReq = Nothing
Set xmldom = Nothing
Set xmlRoot = Nothing
Set xmlNode = Nothing
Set xmlAttr = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
FindSubmissionURL = ""
End Function
'Also change the function...
'Function SendMail(strSubURL, _
'strFrom, _
'strTo, _
'strSubject, _
'strBody, _
'strUserName, _
'strPassWord) As Boolean
'...to the following to accomodate the comments for its use with MSXML 4.0:
' Function SendMail(strSubURL, _
' strFrom, _
' strTo, _
' strSubject, _
' strBody, _
' strUserName, _
' strPassWord) As Boolean
' Dim strText
' Dim xmlReq As MSXML.XMLHTTPRequest
' Set xmlReq = CreateObject("Microsoft.XMLHTTP")
' To use MSXML 4.0 use the followinf DIM/SET statements
' Dim xmlReq As MSXML2.XMLHTTP40
' Set xmlReq = CreateObject("Msxml2.XMLHTTP.4.0")
' On Error GoTo ErrHandler
' Construct the text of the PUT request
' strText = "From: " & strFrom & vbNewLine & _
' "To: " & strTo & vbNewLine & _
' "Subject: " & strSubject & vbNewLine & _
' "Date: " & Now & _
' "X-Mailer: test mailer" & vbNewLine & _
' "MIME-Version: 1.0" & vbNewLine & _
' "Content-Type: text/plain;" & vbNewLine & _
' "Charset = ""iso-8859-1""" & vbNewLine & _
' "Content-Transfer-Encoding: 7bit" & vbNewLine & _
' vbNewLine & _
' strBody
' Create the DAV PUT request.
' xmlReq.Open "PUT", strSubURL, False, strUserName, strPassWord
' If strText <> "" Then
' xmlReq.setRequestHeader "Content-Type", "message/rfc822"
' xmlReq.send strText
' End If
'Process the results.
' If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
' MsgBox "Success! " & "PUT Results = " & xmlReq.Status & _
' ": " & xmlReq.statusText
' SendMail = True
' ElseIf xmlReq.Status = 401 Then
' MsgBox "You don't have permission to do the job! " & _
' "Please check your permissions on this item."
' SendMail = False
' Else
' MsgBox "Request Failed. Results = " & xmlReq.Status & _
' ": " & objRequest.statusText
' SendMail = False
' End If
' ErrExit:
' Set xmlReq = Nothing
' Exit Function
' ErrHandler:
' MsgBox Err.Number & ": " & Err.Description
' SendMail = False
' End Function
Function SendMail(strSubURL, _
strFrom, _
strTo, _
strSubject, _
strBody, _
strUserName, _
strPassWord) As Boolean
Dim xmlReq As MSXML.XMLHTTPRequest
Dim strText
On Error GoTo ErrHandler
' Construct the text of the PUT request.
strText = "From: " & strFrom & vbNewLine & _
"To: " & strTo & vbNewLine & _
"Subject: " & strSubject & vbNewLine & _
"Date: " & Now & _
"X-Mailer: test mailer" & vbNewLine & _
"MIME-Version: 1.0" & vbNewLine & _
"Content-Type: text/plain;" & vbNewLine & _
"Charset = ""iso-8859-1""" & vbNewLine & _
"Content-Transfer-Encoding: 7bit" & vbNewLine & _
vbNewLine & _
strBody
' Create the DAV PUT request.
Set xmlReq = CreateObject("Microsoft.XMLHTTP")
xmlReq.Open "PUT", strSubURL, False, strUserName, strPassWord
If strText <> "" Then
xmlReq.setRequestHeader "Content-Type", "message/rfc822"
xmlReq.send strText
End If
'Process the results.
If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
MsgBox "Success! " & "PUT Results = " & xmlReq.Status & _
": " & xmlReq.statusText
SendMail = True
ElseIf xmlReq.Status = 401 Then
MsgBox "You don't have permission to do the job! " & _
"Please check your permissions on this item."
SendMail = False
Else
MsgBox "Request Failed. Results = " & xmlReq.Status & _
": " & objRequest.statusText
SendMail = False
End If
ErrExit:
Set xmlReq = Nothing
Exit Function
ErrHandler:
MsgBox Err.Number & ": " & Err.Description
SendMail = False
End Function
