How to send a meeting request by using WebDAV

Private Sub SendRequest_Click()
 Dim strApptURL As String
 Dim strMeetingURL As String
 Dim strSubmissionURL As String
 Dim strExServer As String
 Dim strMailbox As String
 Dim strFolder As String
 Dim strApptItem As String
 Dim strMeetingItem As String
 Dim strPassWord As String
 
 Dim strXMLNSInfo As String
 Dim strApptRequest As String
 Dim strUIDRequest As String
 Dim strUID As String
 Dim bResult As Boolean
 
 ' TODO: Replace with your server name.
 strExServer = "MyServer"
 ' TODO: Replace with your mailbox name.
 strMailbox = "Administrator"
 strFolder = "Calendar"
 strApptItem = "meetappt.eml"
 strMeetingItem = "meetappt2.eml"
 strPassWord = "password"

 strApptURL = "http://" & strExServer & "/exchange/" & _
    strMailbox & "/" & strFolder & "/" & strApptItem
 strMeetingURL = "http://" & strExServer & "/exchange/" & _
    strMailbox & "/" & strFolder & "/" & strMeetingItem
 strSubmissionURL = "http://" & strExServer & "/exchange/" & _
    strMailbox & "/##DavMailSubmissionURI##/"
 
 strXMLNSInfo = "xmlns:g=""DAV:"" " & _
    "xmlns:e=""http://schemas.microsoft.com/exchange/"" " & _
    "xmlns:mapi=""http://schemas.microsoft.com/mapi/"" " & _
    "xmlns:mapit=""http://schemas.microsoft.com/mapi/proptag/"" " & _
    "xmlns:x=""xml:"" xmlns:cal=""urn:schemas:calendar:"" " & _
    "xmlns:dt=""urn:uuid:c2f41010-65b3-11d1-a29f-00aa00c14882/"" " & _
    "xmlns:header=""urn:schemas:mailheader:"" " & _
    "xmlns:mail=""urn:schemas:httpmail:"">"
 
 ' Calendar item properties.
 strCalInfo = "<cal:location>meetappt Location</cal:location>" & _
    "<cal:dtstart dt:dt=""dateTime.tz"">2001-09-22T22:00:00.000Z</cal:dtstart>" & _
    "<cal:dtend dt:dt=""dateTime.tz"">2001-09-22T22:30:00.000Z</cal:dtend>" & _
    "<cal:instancetype dt:dt=""int"">0</cal:instancetype>" & _
    "<cal:busystatus>BUSY</cal:busystatus>" & _
    "<cal:meetingstatus>CONFIRMED</cal:meetingstatus>" & _
    "<cal:alldayevent dt:dt=""boolean"">0</cal:alldayevent>" & _
    "<cal:responserequested dt:dt=""boolean"">1</cal:responserequested>"
    
 ' urn:schemas:mailheader:to  Required Attendee
 ' urn:schemas:mailheader:cc  Optional Attendee
 ' urn:schemas:mailheader:bcc Resource
 ' TODO: Replace the value to fit your environment.
 strHeaderInfo = "<header:to>user1@here.microsoft.com</header:to>" & _
    "<header:cc>user2@here.microsoft.com</header:cc>" & _
    "<header:bcc>user3@here.microsoft.com</header:bcc>"
     
 strMailInfo = "<mail:subject>meetappt Subject</mail:subject>" & _
    "<mail:htmldescription>Let's meet here</mail:htmldescription>"

 strApptRequest = "<?xml version=""1.0""?>" & _
 "<g:propertyupdate " & strXMLNSInfo & _
  "<g:set>" & _
   "<g:prop>" & _
    "<g:contentclass>urn:content-classes:appointment</g:contentclass>" & _
    "<e:outlookmessageclass>IPM.Appointment</e:outlookmessageclass>" & _
    strMailInfo & _
    strCalInfo & _
    strHeaderInfo & _
    "<mapi:finvited dt:dt=""boolean"">1</mapi:finvited>" & _
   "</g:prop>" & _
  "</g:set>" & _
 "</g:propertyupdate>"
    
 bResult = False

 ' Create meeting associated appointment in calendar.
 bResult = CreateMeetingAppointment(strApptURL, _
            strApptRequest, _
            strMailbox, _
            strPassWord)
 If bResult Then
  MsgBox "Successfully create the meeting appointment!"
 
  strUIDRequest = "<?xml version='1.0'?>" & _
      "<a:propfind xmlns:a='DAV:'>" & _
      "<a:prop xmlns:uid='urn:schemas:calendar:'>" & _
      "<uid:uid/>" & _
      "</a:prop>" & _
      "</a:propfind>"

  ' urn:schemas:calendar:uid needs to be copied over to meeting request.
  strUID = FindAppointmentUID(strApptURL, _
           strUIDRequest, _
           strMailbox, _
           strPassWord)
 
  If strUID <> "" Then
  bResult = False
  ' Meeting request item properties.
  ' TODO: Replace the value to fit your environment.
  strCCInfo = "<g:contentclass>urn:content-classes:calendarmessage</g:contentclass>" & _
     "<e:outlookmessageclass>IPM.Schedule.Meeting.Request</e:outlookmessageclass>"
    
  strMapiInfo = "<mapi:finvited dt:dt=""boolean"">1</mapi:finvited>" & _
     "<mapi:responsestatus dt:dt=""int"">1</mapi:responsestatus>" & _
     "<mapi:responsestate dt:dt=""int"">0</mapi:responsestate>" & _
     "<mapi:response_requested dt:dt=""boolean"">1</mapi:response_requested>" & _
     "<mapi:apptstateflags dt:dt=""int"">3</mapi:apptstateflags>" & _
     "<mapi:busystatus dt:dt=""int"">1</mapi:busystatus>" & _
     "<mapi:intendedbusystatus dt:dt=""int"">2</mapi:intendedbusystatus>"
     
  strMeetingRequest = "<?xml version=""1.0""?>" & _
     "<g:propertyupdate " & strXMLNSInfo & _
      "<g:set>" & _
       "<g:prop>" & _
        strCCInfo & _
        strMailInfo & _
        strCalInfo & "<cal:uid>" & strUID & "</cal:uid>" & _
        strHeaderInfo & _
        strMapiInfo & _
       "</g:prop>" & _
      "</g:set>" & _
     "</g:propertyupdate>"

  ' Create meeting request item in calendar.
  bResult = CreateMeetingAppointment(strMeetingURL, _
             strMeetingRequest, _
             strMailbox, _
             strPassWord)
  If bResult Then
   MsgBox "Successfully create the meeting request!"
   bResult = False

   ' MOVE the meeting request to mail submission URI.
   bResult = SubmitMeetingRequest(strMeetingURL, _
             strSubmissionURL, _
             strMailbox, _
             strPassWord)
   If bResult Then
    MsgBox "Successfully send the meeting request!"
   End If
         
  End If ' end bResult is TRUE for creating meeting request
 End If ' end strUID <> ""
 End If ' end bResult is TRUE for creating meeting appt
 
End Sub

Function CreateMeetingAppointment( _
 strURL, _
 strApptRequest, _
 strUserName, _
 strPassWord) As Boolean
   
 Dim xmlReq As MSXML.XMLHTTPRequest
 On Error GoTo ErrHandler
 
 ' Create the DAV PROPPATCH request.
 Set xmlReq = CreateObject("Microsoft.XMLHTTP")
 xmlReq.open "PROPPATCH", strURL, False, strUserName, strPassWord
 xmlReq.setRequestHeader "Content-Type", "text/xml"
 xmlReq.send strApptRequest

 ' Process the results.
 If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
  MsgBox "Success! PROPPATCH Results = " & xmlReq.Status & _
    ": " & xmlReq.statusText
  CreateMeetingAppointment = True
 Else
  MsgBox "Request Failed.  PROPPATCH Results = " & xmlReq.Status & _
    ": " & xmlReq.statusText
  CreateMeetingAppointment = False
 End If
ErrExit:
   Set xmlReq = Nothing
   Exit Function
ErrHandler:
   MsgBox Err.Number & ": " & Err.Description
   CreateMeetingAppointment = False
End Function

Function FindAppointmentUID( _
 strURL, _
 strUIDRequest, _
 strUserName, _
 strPassWord) As String
 
 Dim xmlReq As MSXML.XMLHTTPRequest
 Dim xmldom As MSXML.DOMDocument
 Dim xmlRoot As MSXML.IXMLDOMElement
 Dim xmlNode As MSXML.IXMLDOMNode
 Dim xmlAttr As MSXML.IXMLDOMAttribute
 Dim baseName As String
 
 On Error GoTo ErrHandler
 ' Create the DAV PROPFIND request.
 Set xmlReq = CreateObject("Microsoft.XMLHTTP")
 xmlReq.open "PROPFIND", strURL, False, strUserName, strPassWord
 xmlReq.setRequestHeader "Content-Type", "text/xml"
 xmlReq.setRequestHeader "Depth", "0"
 xmlReq.send (strUIDRequest)
 
 ' 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
    For Each xmlAttr In xmlRoot.Attributes
    If xmlAttr.Text = "urn:schemas:calendar:" Then
    baseName = xmlAttr.baseName
    Exit For
    End If
    Next
 
    Set xmlNode = xmlRoot.selectSingleNode("//" & baseName & ":uid")
    FindAppointmentUID = xmlNode.Text
 Else
    MsgBox "Failed to find Appointment UID"
    FindAppointmentUID = ""
 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
 FindAppointmentUID = ""

End Function
 
Function SubmitMeetingRequest( _
 strSrcURL, _
 strSubmissionURL, _
 strUserName, _
 strPassWord) As Boolean
 
 Dim xmlReq As MSXML.XMLHTTPRequest
 On Error GoTo ErrHandler
  
 Set xmlReq = CreateObject("Microsoft.xmlhttp")
 xmlReq.open "MOVE", strSrcURL, False, strUserName, strPassWord
 xmlReq.setRequestHeader "Destination", strSubmissionURL
 xmlReq.setRequestHeader "Content-Type", "message/rfc822"
 xmlReq.send
 
 ' Display the results.
 If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
   MsgBox "Success!   " & "Results = " & xmlReq.Status & ": " & xmlReq.statusText
   SubmitMeetingRequest = True
 ElseIf xmlReq.Status = 401 Then
   SubmitMeetingRequest = False
   MsgBox "You don't have permission to do the job! Please check your permissions on this item."
 Else
   SubmitMeetingRequest = False
   MsgBox "Request Failed.  Results = " & xmlReq.Status & ": " & xmlReq.statusText
 End If
 
ErrExit:
 Set xmlReq = Nothing
 Exit Function
ErrHandler:
 MsgBox Err.Number & ": " & Err.Description
 SubmitMeetingRequest = False
End Function