Outlook 2003 Meeting Requests, Part 2: CDO

In a previous post I discussed the structure of Outlook 2003 Meeting requests. It turned out to be surprisingly hard to get incoming meeting requests show an Accept/Decline -dialog. This post continues from where the previous one left. The focus is on sending email with Microsoft Collaborative Object or CDO.

Below is a .NET 1.1 module to send email. As you can see, its design is old, but it does what it says. I think I found the function template from MSDN. 

Meeting request related code begins at comment 

'iCalendar -attachements

You can control body part encodings and MIME types much better than in System.Web.Mail. In order to get Accept/Decline dialog working I needed two IBodyPart objects. One for the iCalendar in message body and one for the same iCalendar object as attachment.

Imports System.IO
Imports CDO

Public Module CDOMail

Public Function Send(ByVal fromName As String, _
ByVal fromAddress As String, _
ByVal replyToAddress As String, _
ByVal toAddress As String, _
ByVal ccAddress As String, _
ByVal bccAddress As String, _
ByVal header As String, _
ByVal body As String, _
ByVal format As String, _
ByVal importance As String, _
ByVal smtpServer As String, _
ByVal attachments As ArrayList) As String

Dim ErrorMsg As String = ""

' Variable which will send the mail
Dim oMsg As CDO.Message = New CDO.Message

Try

Dim Counter As Integer = 0

' Set configuration.
Dim iConfg As CDO.Configuration = New CDO.Configuration

'CDO SMTP config fields
Const cdoSendUsingMethod As String = _
"http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSendUsingPort As Integer = 2
Const cdoSMTPServer As String = _
"http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cdoSMTPConnectionTimeout As String = _
"http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"

' Other available settings 
'Const cdoSMTPServerPort As String = _
'"http://schemas.microsoft.com/cdo/configuration/smtpserverport"
'Const cdoSMTPAuthenticate As String = _
'"http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
''Const cdoBasic = 1
'Const cdoSendUserName As String = _
'"http://schemas.microsoft.com/cdo/configuration/sendusername"
'Const cdoSendPassword As String = _
'"http://schemas.microsoft.com/cdo/configuration/sendpassword"


' Get a handle on the config object and it's fields

' Set necessary config fields
With iConfg.Fields
.Item(cdoSendUsingMethod).Value = cdoSendUsingPort
.Item(cdoSMTPServer).Value = smtpServer
.Item(cdoSMTPConnectionTimeout).Value = 10
.Update()
End With
oMsg.Configuration = iConfg

If smtpServer = "" Then Return "SMTP server is missing"

'Multiple recepients can be specified using ; as the delimeter
'Address of the recipient
oMsg.To = toAddress
oMsg.CC = ccAddress
oMsg.BCC = bccAddress

If toAddress = "" And ccAddress = "" And bccAddress = "" Then
ErrorMsg = "Recipient missing"
GoTo problem
End If

'Your From Address
'You can also use a custom header Reply-To for a different replyto address
If fromName <> "" Then
oMsg.From = "\" & fromName & "\ <" & fromAddress & ">"
Else
oMsg.From = fromAddress
End If
If oMsg.From = "" Then
ErrorMsg = "No sender"
GoTo problem
End If

'Specify the body format
If UCase(format) = "HTML" Then
oMsg.HTMLBody = body 'Send the mail in HTML Format
Else
oMsg.TextBody = body
End If

'If you want you can add a reply to header
If replyToAddress <> "" Then
oMsg.ReplyTo = replyToAddress
End If

' Message importance
Const cdoHigh As Integer = 2
'Const cdoNormal As Integer = 1
Const cdoLow As Integer = 0
If UCase(importance) = "HIGH" Then oMsg.Fields("urn:schemas:httpmail:importance").Value = cdoHigh
If UCase(importance) = "LOW" Then oMsg.Fields("urn:schemas:httpmail:importance").Value = cdoLow

'Mail Subject
oMsg.Subject = header


Dim attachment As String
For Each attachment In attachments

' iCalendar -attachements.
If InStr(attachment, ".ics") Then

' Mail content class
oMsg.Fields("urn:schemas:mailheader:content-class").Value = "urn:content-classes:calendarmessage"

oMsg.TextBody = body
oMsg.HTMLBody = Replace(body, vbCrLf, "")

Dim iBps As IBodyParts
iBps = oMsg.BodyPart.BodyParts

Dim iBp As CDO.IBodyPart 'iCalendar as text
iBp = iBps.Add

Dim AttachmentText As String
Dim oRead As System.IO.StreamReader
oRead = File.OpenText(attachment)
AttachmentText = oRead.ReadToEnd()

Dim Stm As ADODB.Stream
With iBp
.ContentMediaType = "text/calendar; method=REQUEST"
.ContentTransferEncoding = "7bit"
Stm = .GetDecodedContentStream
Stm.WriteText(AttachmentText)
Stm.Flush()
End With

Dim oBP As CDO.IBodyPart
oBP = oMsg.AddAttachment(attachment, "", "") 'iCalendar as an attachment

'Set ContentMediaType - vcs files need this setting.
oBP.ContentMediaType = "application/ics"
oBP.ContentTransferEncoding = "7bit"

Else
oMsg.AddAttachment(attachment, "", "") 'Other attachments
End If

Next

'Call the send method to send the mail

If oMsg.Subject = "" And body = "" Then
ErrorMsg = "Header and body are empty"
GoTo problem
End If

oMsg.Send()
oMsg = Nothing
iConfg = Nothing

Catch ex As Exception
ErrorMsg = ex.Message
GoTo problem
End Try

Return ""
Exit Function

problem:
Return ErrorMsg

End Function

End Module