HOWTO: Send Email With Attachment Using VB and WebDAV

To send an email with WebDAV, you will you will need to create/recreate the item with a WEBDAV PUT using the MIME of the message.  It gets tricky when working with attachments.  To get around the complexity of sending an email with an attachment, you may want to look at using CDOSYS to build the message to send, then extract the MIME stream (MIME of the message in a string) of the resulting message. 
For sending the message, you would use a PUT statement to write the stream to a file in the Drafts folder of the sending person’s mail box.  If you need to set specific properties not set by the MIME, you should do a PROPPATCH against the message in the Drafts folder.  Next, the code should use a WebDAV MOVE in order to place the message into the mailbox’s submission URL.  The Submission URL is a special url used for sending messages.  “/##DavMailSubmissionURI##" off of the root of the mailbox is the Submission URL. 

' TODO:
'  Create a VB Windows program.
'  Add a button to the form
'  Add references to:
'      Active X Data Objectes
'      Microsoft CDO for Windows 2000 Library
'      Microsoft XML, 3.0
'  Paste-in the code below.
'  Do the TODO sections in the code.

Option Explicit

Private Sub Command1_Click()
    CreateMessageAndWebDAVSubmit
End Sub

'-----------------------------------------------------------------------------------
' CreateMessageAndWebDAVSubmit - Main method for generating message and using WEBDAV
' to send the message.
'-----------------------------------------------------------------------------------
Private Sub CreateMessageAndWebDAVSubmit()
    Dim sDraftsFolder As String
    Dim sSubmissionURL As String
    Dim strAttendeeItem As String
    Dim dateNow As Date
    Dim strMIMEStream As String
    Dim bRet As Boolean
   
    Dim sUser As String
    Dim sPassword As String
   
    ' TODO: Change username and password or set to "" if using windows authentication
    sUser = "Administrator"         ' TODO: Change
    sPassword = "testpassword"     ' TODO: Change
   
    ' TODO: Change the Drafts folder and submission URLs
    sDraftsFolder = "https://myexserver/exchange/Administrator/Drafts/SubmittedMail" & GetUniqueString & ".EML" ' TODO: Change this
    sSubmissionURL = "https://myexserver/exchange/Administrator/##DavMailSubmissionURI##" ' TODO: Change this

    ' Use CDOSYS to generate the message body parts and such
    strMIMEStream = BuildMessageAndGenerateMIMEStream()
   
    bRet = DoWebdavPut(sDraftsFolder, strMIMEStream, sUser, sPassword)
    If (bRet = True) Then
        ' NOTE:
        '   At this point, the email is in the drafts folder.  If you don't want it sent
        '   automatically, you can comment out the line below.  If the line below does not
        '   execute, you can load the message from Outlook or OWA and send it from there.
        DoWebdavCopyMove sDraftsFolder, sSubmissionURL, False, sUser, sPassword  ' MOVE IT TO SUBMISSION !!!
    End If
 
End Sub

'-----------------------------------------------------------------------------------
' BuildMessageAndGenerateMIMEStream - This will create a CDOSYS message, attach a file
' and return the Mime stream for use with webdav.
'-----------------------------------------------------------------------------------
Private Function BuildMessageAndGenerateMIMEStream() As String
    Dim oBodyPart As CDO.IBodyPart
    Dim oMessage As CDO.Message
    Dim oConfig As CDO.Configuration
    Dim oFields As ADODB.Fields
    Dim sFile   As String
    Dim strMIMEStream As String
    Dim oAttachStream As ADODB.Stream
    Dim oMIMEStream As ADODB.Stream
   
    Set oMessage = New CDO.Message
    Set oConfig = New CDO.Configuration
    Set oFields = oConfig.Fields

    With oMessage
        Set .Configuration = oConfig
        .To = "Administrator@mydomain.extest.microsoft.com"       ' TODO: Change to the name of the sender
        .From = "Administrator@mydomain.extest.microsoft.com"     ' TODO: Change to the name the person the mail is going to
        .Subject = "Test"                                               ' TODO: Change to the subject of the message.
        .TextBody = "Test adding icon"                                  ' TODO: Change to the body of the message.

        .Fields.Update
    End With

    ' The File I'm attaching
    sFile = "C:\output.txt"                                    ' TODO: Change to the name of the file being sent.
    Set oBodyPart = oMessage.AddAttachment(sFile, "", "")      ' Do Attatchment
   
    ' NOTE: For your reference...
    'With oBodyPart
    '    ' Set the content class appropriately
    '    '.ContentMediaType = "mage/x-icon" '"text/html"
    '    ' Get the decoded content stream so we can use it
    '    Set oAttachStream = .GetDecodedContentStream()
    'End With
   
    ' Now get the entire message stream
    Set oMIMEStream = oMessage.GetStream()
   
    ' Read the text out of it
    strMIMEStream = oMIMEStream.ReadText()
   
    Set oMIMEStream = Nothing
    Set oAttachStream = Nothing
    Set oBodyPart = Nothing
    Set oMessage = Nothing
   
    ' And return it
    BuildMessageAndGenerateMIMEStream = strMIMEStream

End Function

'-----------------------------------------------------------------------------------
' GetUniqueString - Used to generate a fairly unique string... used in making a
' Unique file name.  This is: Datetime + random + serial value
'-----------------------------------------------------------------------------------
Private Function GetUniqueString() As String
    ' I'm in EST, which is GMT - 5, but it's Daylight Savings, to it becomes GMT - 4
    Const TimeZoneOffset As Long = 4
    Dim sString As String
    Dim dateNow As Date
    Dim iRnd As Single
    Dim lNum As Long
    Static lVal As Long
   
    lVal = lVal + 1
    If lVal > 50000 Then lVal = 1
    
    iRnd = Rnd(CLng(Format(Now, "mmhhmmss")))
    lNum = CLng(iRnd * 10000000)
    
    dateNow = DateAdd("h", TimeZoneOffset, Now())
    sString = Format(dateNow, "yyyyMMdd") & "T" & Format(dateNow, "HHmmss") & "Z"
    GetUniqueString = sString & CStr(lNum) & lVal ' Datetime + random + serial value
End Function

'-----------------------------------------------------------------------------------
' DoCopyMove - Used to PUT (write) an item to a file in a folder.
'  sFolder          - The complete URI to PUT the item (includes item name).
'  sText            - The contents to write in the file.
'  sUser            - User ID for logging in.  Set to "" if using windows authentication
'  sPassword        - Password for logging in.  Set to "" if using windows authentication
'-----------------------------------------------------------------------------------
Private Function DoWebdavPut(sFolder As String, sText As String, sUser As String, sPassword As String) As Boolean
    Dim oXMLHttp As New MSXML2.XMLHTTP30
    Dim bSucess As Boolean
    Dim iStatus As Integer
    Dim sStatus As String
    Dim sResponse As String
   
    If sUser <> "" Then
        oXMLHttp.Open "PUT", sFolder, False, sUser, sPassword   ' TODO: Change username and password
    Else
         oXMLHttp.Open "PUT", sFolder, False ', sUser, sPassword   ' TODO: Change username and password
    End If
    oXMLHttp.setRequestHeader "translate", "f" ' Set this header to prevent DAV from trying to munge our stream
    oXMLHttp.Send sText ' Send the stream across
   
    bSucess = False
   
    iStatus = oXMLHttp.Status
    sStatus = oXMLHttp.statusText
    If (iStatus >= 200 And iStatus < 300) Then
        Debug.Print "PUT: Success!   " & "Results = " & iStatus & ": " & sStatus
        bSucess = True
    ElseIf iStatus = 401 Then
        Debug.Print "PUT: You don't have permission to do the job! Please check your permissions on this item."
    Else
        Debug.Print "PUT: Request Failed.  Results = " & iStatus & ": " & sStatus
    End If
   
    Set oXMLHttp = Nothing
   
    DoWebdavPut = bSucess
End Function

'-----------------------------------------------------------------------------------
' DoCopyMove - Used to move an item from one folder to another in the same store.
'  sSourceURL       - item being moved/copied
'  sDestinationURL  - the URL it is going to
'  bCopy            - TRUE if copying or FALSE if moving
'  sUser            - User ID for logging in.  Set to "" if using windows authentication
'  sPassword        - Password for logging in.  Set to "" if using windows authentication
'-----------------------------------------------------------------------------------
Private Sub DoWebdavCopyMove(ByVal sSourceURL As String, ByVal sDestinationURL As String, ByVal bCopy As Boolean, sUser As String, sPassword As String)
    Dim oXMLHttp As New MSXML2.XMLHTTP30
    Dim sVerb As String
   
    If bCopy Then
        sVerb = "COPY"
    Else
        sVerb = "MOVE"
    End If
   
    If sUser <> "" Then
        oXMLHttp.Open sVerb, sSourceURL, False, sUser, sPassword   ' TODO: Change username and password
    Else
        oXMLHttp.Open sVerb, sSourceURL, False ', sUser, sPassword   ' TODO: Change username and password
    End If
 
    oXMLHttp.setRequestHeader "Destination", sDestinationURL

    ' Send the stream across
    oXMLHttp.Send
   
    If (oXMLHttp.Status >= 200 And oXMLHttp.Status < 300) Then
          Debug.Print "Success!   " & "Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
        ElseIf oXMLHttp.Status = 401 Then
          Debug.Print "You don't have permission to do the job!
        Else
          Debug.Print "Request Failed.  Results = " & oXMLHttp.Status & ": " & oXMLHttp.statusText
    End If

    Set oXMLHttp = Nothing
 
End Sub