CraigWardman.com

Namespace Email.Exchange.AirSync
    Public Class AirSyncHelper
        'class was written based on AS2.5 specification
        Public Const AirSyncSupportedVersion As String = "2.5"
 
        Private _asCodePages As Dictionary(Of Integer, EncodingHelpers.WBXML.WbXmlCodepage)
        Private ReadOnly Property ASCodePages() As Dictionary(Of Integer, EncodingHelpers.WBXML.WbXmlCodepage)
            Get
                If _asCodePages Is Nothing Then
                    InitAirSyncCodepages()
                End If
 
                Return _asCodePages
            End Get
        End Property
 
        'host address endpoint where exchange webmail is hosted
        Private _asHostAddress As String
        Private Property ASHostAddress() As String
            Get
                Return _asHostAddress
            End Get
            Set(ByVal value As String)
                _asHostAddress = value
                If _asHostAddress.EndsWith("/") Then _asHostAddress = _asHostAddress.Substring(0, _asHostAddress.Length - 1)
            End Set
        End Property
 
        'this could be used to have a different mailbox name to the domain login
        Private _asUsername As String
        Private Property ASUsername() As String
            Get
                Return _asUsername
            End Get
            Set(ByVal value As String)
                _asUsername = value
            End Set
        End Property
 
        'domain login credentials (HTTP Auth)
        Private _loginUsername As String
        Private Property LoginUsername() As String
            Get
                Return _loginUsername
            End Get
            Set(ByVal value As String)
                _loginUsername = value
            End Set
        End Property
 
        Private _loginDomain As String
        Private Property LoginDomain() As String
            Get
                Return _loginDomain
            End Get
            Set(ByVal value As String)
                _loginDomain = value
            End Set
        End Property
 
        Private _loginPassword As String
        Private Property LoginPassword() As String
            Get
                Return _loginPassword
            End Get
            Set(ByVal value As String)
                _loginPassword = value
            End Set
        End Property
 
        'ActiveSync policy key 
        Private _policyKey As String = ""
        Private Property PolicyKey() As String
            Get
                Return _policyKey
            End Get
            Set(ByVal value As String)
                _policyKey = value
            End Set
        End Property
 
        'base address (with the active sync folder)
        Private ReadOnly Property ActiveSyncBaseAddress() As String
            Get
                Return _asHostAddress & "/Microsoft-Server-ActiveSync/"
            End Get
        End Property
 
        Public Sub New(ByVal hostAddress As String, ByVal username As String, ByVal password As String, ByVal domain As String)
            ASHostAddress = hostAddress
            ASUsername = username
            LoginUsername = username
            LoginDomain = domain
            LoginPassword = password
        End Sub
 
        Public Function IsVersionCompatible() As Boolean
            'get the options from the server to get the AS Version
            Dim optReq As System.Net.HttpWebRequest = GetAirSyncWebRequest("")
            optReq.Method = "OPTIONS"
 
            Dim optResp As System.Net.HttpWebResponse = CType(optReq.GetResponse(), System.Net.HttpWebResponse)
 
            '200 OK?
            If optResp.StatusCode = 200 Then
                'check server versions
                Dim msAsProtocolVersions As String = optResp.Headers("MS-ASProtocolVersions")
                If Not String.IsNullOrEmpty(msAsProtocolVersions) Then
                    Dim supportedVersions As String() = msAsProtocolVersions.Split(","c)
 
                    'must support AirSyncTargetVersion
                    If supportedVersions.Contains(AirSyncSupportedVersion) Then
                        Return True
                    End If
                End If
            End If
 
            Return False
        End Function
 
        Public Sub ObtainPolicyKey()
            'in AirSync version 12 the policy type was changed from MS-WAP-Provisioning-XML to MS-EAS-Provisioning-WBXML
            Dim policyType As String = ""
            If CDbl(AirSyncSupportedVersion) >= 12 Then
                policyType = "MS-EAS-Provisioning-WBXML"
            Else
                policyType = "MS-WAP-Provisioning-XML"
            End If
 
            Dim opkXml As String = <?xml version="1.0" encoding="utf-8"?>
                                   <Provision xmlns="Provision:" xmlns:settings="Settings:">
                                       <Policies>
                                           <Policy>
                                               <PolicyType>{PolicyType}</PolicyType>
                                           </Policy>
                                       </Policies>
                                   </Provision>.ToString().Replace("{PolicyType}", policyType)
 
            Dim opkResult As System.Xml.XmlDocument = ExecuteAirSyncCommand("Provision", opkXml)
 
            If opkResult IsNot Nothing Then
                Dim opkNsMgr As New Xml.XmlNamespaceManager(opkResult.NameTable)
                'since XPATH v1 doesnt support default namespace, add our own prefix
                opkNsMgr.AddNamespace("dflt", Codepages.Provision_14.Instance.XmlNs)
                opkNsMgr.AddNamespace(Codepages.Settings_18.Instance.XmlPrefix, Codepages.Settings_18.Instance.XmlNs)
 
                'this may not have a key, for e.g if their are no policies applied
                Dim pkNode As System.Xml.XmlNode = opkResult.SelectSingleNode("dflt:Provision/dflt:Policies/dflt:Policy/dflt:PolicyKey", opkNsMgr)
                If pkNode IsNot Nothing Then PolicyKey = pkNode.InnerText
 
                'TODO: this might need to reply to the server in future to confirm policy settings, but not for now...
            End If
 
        End Sub
 
        Public Function ExecuteAirSyncCommand(ByVal command As String, ByVal xmlBody As String) As System.Xml.XmlDocument
            'create a command query with some dummy device data
            Dim commandQuery As String = String.Format("?User={0}&DeviceId=CwWebDevice1234&DeviceType=PocketPC&Cmd={1}", ASUsername, command)
 
            'create a request to execute the command
            Dim execReq As System.Net.HttpWebRequest = GetAirSyncWebRequest(commandQuery)
            execReq.Method = "POST"
            execReq.Headers("MS-ASProtocolVersion") = AirSyncSupportedVersion
            execReq.ContentType = "application/vnd.ms-sync.wbxml"
 
            'convert the xml to wbxml
            Dim transportData() As Byte = GetWbxmlFromXml(xmlBody)
 
            execReq.ContentLength = transportData.Length
 
            'transfer the bytes
            Dim requestStream As IO.Stream = execReq.GetRequestStream()
            requestStream.Write(transportData, 0, transportData.Length)
            requestStream.Close()
 
            'get response
            Dim execResp As System.Net.HttpWebResponse = CType(execReq.GetResponse(), System.Net.HttpWebResponse)
            If execResp.StatusCode = 200 Then
                'convert the wbxml to xml
                Dim wbxmlRespDoc As New EncodingHelpers.WBXML.WbXmlDocument(ASCodePages)
                wbxmlRespDoc.Load(execResp.GetResponseStream())
 
                Return wbxmlRespDoc
            Else
                Throw New Exception("Status from server was not 200 (" & execResp.StatusCode & ")")
            End If
 
        End Function
 
        Private Function GetAirSyncWebRequest(ByVal queryString As String) As System.Net.HttpWebRequest
            Dim fullUrl As String = ActiveSyncBaseAddress & CStr(IIf(Not String.IsNullOrEmpty(queryString), queryString, ""))
            Dim asReq As System.Net.HttpWebRequest = CType(System.Net.WebRequest.Create(fullUrl), System.Net.HttpWebRequest)
 
            asReq.Credentials = New System.Net.NetworkCredential(LoginUsername, LoginPassword, LoginDomain)
            'BASIC: optReq.Headers("Authorization") = "Basic " & Convert.ToBase64String(Encoding.UTF8.GetBytes(domain & "\" & username & ":" & password))
            asReq.UserAgent = "Microsoft-Server-AirSyncClient/2.5+(CraigW)"
            asReq.KeepAlive = True
            If Not String.IsNullOrEmpty(PolicyKey) Then asReq.Headers("X-MS-PolicyKey") = PolicyKey
 
            Return asReq
        End Function
 
        Private Function GetWbxmlFromXml(ByVal xml As String) As Byte()
            'create new converter with our code pages
            Dim wbxmlReqDoc As New EncodingHelpers.WBXML.WbXmlDocument(ASCodePages)
 
            'load the xml source
            wbxmlReqDoc.LoadXml(xml)
 
            'return the bytes
            Return wbxmlReqDoc.GetBytes()
        End Function
 
        Private Sub InitAirSyncCodepages()
            _asCodePages = New Dictionary(Of Integer, EncodingHelpers.WBXML.WbXmlCodepage)
 
            'AirSync - 0
            _asCodePages.Add(Codepages.AirSync_0.Instance.Codepage, Codepages.AirSync_0.Instance)
 
            'Contacts - 1
            _asCodePages.Add(Codepages.Contacts_1.Instance.Codepage, Codepages.Contacts_1.Instance)
 
            'Calendar - 4
            _asCodePages.Add(Codepages.Calendar_4.Instance.Codepage, Codepages.Calendar_4.Instance)
 
            'FolderHierarchy - 7
            _asCodePages.Add(Codepages.FolderHierarchy_7.Instance.Codepage, Codepages.FolderHierarchy_7.Instance)
 
            'Provision - 14
            _asCodePages.Add(Codepages.Provision_14.Instance.Codepage, Codepages.Provision_14.Instance)
 
            'AirsyncBase - 17
            _asCodePages.Add(Codepages.AirSyncBase_17.Instance.Codepage, Codepages.AirSyncBase_17.Instance)
 
            'Settings  - 18
            _asCodePages.Add(Codepages.Settings_18.Instance.Codepage, Codepages.Settings_18.Instance)
 
 
        End Sub
    End Class
End Namespace

'CONVERTED FROM ORIGINAL C# CLASS:
' This class is released under restrictive CPL
' You can use this code or code, derived from this code in either 
' open source, free or commercial application, however, 
' you should clearly provide my name "Tamir Khason" 
' and link to my blog http://blogs.microsoft.co.il/blogs/tamir/ 
' or my private web site http://khason.biz within any distribution of the software. 
' For more information, contact me at tamir@khason.biz
 
 
' Some additional changes were made to give better XML compatibility, (to make compatible for use with AirSync)
' This includes:
' - fixed the way tags are closed (using a stack instead of searching the text)
' - added XML namespace compatibility 
'        -to switch codepages based on xml prefix, not first token found, when encoding XML -> WBXML
'       - also to encode the namespaces back into the XML output when decoding WBXML -> XML
' - added extra logic for inclusion of the attriubute wbxml flag (only if token exists)
' - defined a strongly typed codepage/tags class to define the required extra data (xml namespace/prefix)
' - added CDATA tags around XML content to prevent xml parser issues
 
 
 
Imports System.Collections.Generic
Imports System.Text
Imports System.Xml
Imports System.IO
Imports System.Text.RegularExpressions
 
Namespace EncodingHelpers.WBXML
    Friend Class WbXmlDocument
        Inherits XmlDocument
        Public VersionNumber As String = "1.3"
        'temp
        Public Charset As Encoding
        Private GlobalTokens As Dictionary(Of Byte, String)
        'change this to be strongly typed codepages with additional XML info
        'Private LocalTokens As Dictionary(Of Integer, Dictionary(Of Byte, String)), 
        Private LocalAttributes As Dictionary(Of Integer, Dictionary(Of Byte, String))
        Private LocalTokens As Dictionary(Of Integer, WbXmlCodepage)
 
        Public Sub New()
            MyBase.New()
 
            initGlobalTokens()
        End Sub
 
        Public Sub New(ByVal tokens As Dictionary(Of Integer, WbXmlCodepage))
            MyBase.New()
            initGlobalTokens()
            LocalTokens = tokens
            LocalAttributes = New Dictionary(Of Integer, Dictionary(Of Byte, String))
        End Sub
 
        Public Sub New(ByVal tokens As Dictionary(Of Integer, WbXmlCodepage), ByVal attributes As Dictionary(Of Integer, Dictionary(Of Byte, String)))
            MyBase.New()
            initGlobalTokens()
            LocalTokens = tokens
            LocalAttributes = attributes
        End Sub
 
        Private Sub New(ByVal imp As XmlImplementation)
            MyBase.New(imp)
        End Sub
        Private Sub New(ByVal nt As XmlNameTable)
            MyBase.New(nt)
        End Sub
 
        Private Sub initGlobalTokens()
            GlobalTokens = New Dictionary(Of Byte, String)()
            Dim vals As String() = [Enum].GetNames(GetType(GlobalToken))
 
            For i As Integer = 0 To vals.Length - 1
                GlobalTokens.Add(CByte(CType([Enum].Parse(GetType(GlobalToken), vals(i)), GlobalToken)), vals(i))
            Next
 
            LocalTokens = New Dictionary(Of Integer, WbXmlCodepage)()
        End Sub
 
        Private Enum GlobalToken
            SWITCH_PAGE = &H0
            ' Change the code page for the current token state. Followed by a single u_int8 indicating the new code page number. 
            [END] = &H1
            ' Indicates the end of an attribute list or the end of an element. 
            ENTITY = &H2
            ' A character entity. Followed by a mb_u_int32 encoding the character entity number. 
            STR_I = &H3
            'Inline string. Followed by a termstr. 
            LITERAL = &H4
            ' An unknown tag or attribute name. Followed by an mb_u_int32 that encodes an offset into the string table. 
            EXT_I_0 = &H40
            ' Inline string document-type-specific extension token. Token is followed by a termstr. 
            EXT_I_1 = &H41
            ' Inline string document-type-specific extension token. Token is followed by a termstr. 
            EXT_I_2 = &H42
            ' Inline string document-type-specific extension token. Token is followed by a termstr. 
            PI = &H43
            ' Processing instruction. 
            LITERAL_C = &H44
            ' Unknown tag, with content. 
            EXT_T_0 = &H80
            ' Inline integer document-type-specific extension token. Token is followed by a mb_uint_32. 
            EXT_T_1 = &H81
            ' Inline integer document-type-specific extension token. Token is followed by a mb_uint_32. 
            EXT_T_2 = &H82
            ' Inline integer document-type-specific extension token. Token is followed by a mb_uint_32. 
            STR_T = &H83
            ' String table reference. Followed by a mb_u_int32 encoding a byte offset from the beginning of the string table. 
            LITERAL_A = &H84
            ' Unknown tag, with attributes. 
            EXT_0 = &HC0
            ' Single-byte document-type-specific extension token. 
            EXT_1 = &HC1
            ' Single-byte document-type-specific extension token. 
            EXT_2 = &HC2
            ' Single-byte document-type-specific extension token. 
            OPAQUE = &HC3
            ' Opaque document-type-specific data. 
            LITERAL_AC = &HC4
            ' Unknown tag, with content and attributes.
        End Enum
 
        Private currentCodePage As Integer = 0
        'fix for MS 1;
        Public Overrides Sub Load(ByVal inStream As Stream)
            Using reader As New StreamReader(inStream)
                Load(Encoding.UTF8.GetBytes(reader.ReadToEnd()))
                reader.Close()
            End Using
        End Sub
 
        Public Overloads Sub Load(ByVal WBXmlData As Byte())
            Dim waitForAttr As Boolean = False
            Dim waitForContent As Boolean = False
            Dim openXmlTags As New Stack(Of String)
            Dim codepagesUsed As New List(Of Integer)
 
            If WBXmlData Is Nothing Then
                Return
            End If
 
            Dim builder As New StringBuilder()
 
            If WBXmlData.Length > 3 Then
                'first byte -> version number
                VersionNumber = String.Format("1.{0}", WBXmlData(0))
 
                'second byte -> public identifier. Void it.
 
                'third byte -> charset (IANA)
                Try
                    Charset = Encoding.GetEncoding(WBXmlData(2))
                Catch
                    Charset = Encoding.UTF8
                End Try
 
                'forth byte -> string table
                Dim stringTableLenght As Integer = WBXmlData(3)
                For i As Integer = 4 To 4 + (stringTableLenght - 1)
                    'read string table (if exist
                    Console.WriteLine()
                Next
 
                '4 + stringTableLenght byte and up -> token structs;
                Dim carret As Integer = 4 + stringTableLenght
 
                While carret < WBXmlData.Length
                    If GlobalTokens.ContainsKey(WBXmlData(carret)) Then
                        'global token;
                        Select Case CType(WBXmlData(carret), GlobalToken)
                            Case GlobalToken.SWITCH_PAGE
                                carret += 1
                                If carret >= WBXmlData.Length Then
                                    Exit Select
                                End If
                                currentCodePage = WBXmlData(carret)
 
                                If Not LocalTokens.ContainsKey(WBXmlData(carret)) Then
                                    Throw New XmlException(String.Format("Code page {0} was not loaded", WBXmlData(carret)))
                                End If
                                carret += 1
                                Exit Select
                            Case GlobalToken.STR_I
                                carret += 1
                                If carret >= WBXmlData.Length Then
                                    Exit Select
                                End If
                                Dim str As New List(Of Byte)()
                                While WBXmlData(carret) <> &H0
                                    'fix from Max to Min (incorrect conversion from c# carret++ operator into VB.NET)
                                    str.Add(WBXmlData(System.Math.Min(System.Threading.Interlocked.Increment(carret), carret - 1)))
                                    If carret >= WBXmlData.Length Then
                                        Exit While
                                    End If
                                End While
                                'put inside CDATA tags so it doesnt break the parser
                                builder.Append("<![CDATA[" & UTF8Encoding.UTF8.GetString(str.ToArray()) & "]]>")
                                carret += 1
                                Exit Select
                            Case GlobalToken.[END]
                                If waitForAttr Then
                                    builder.Append(If(waitForContent, ">", "/>"))
                                    waitForAttr = False
                                Else
                                    'change this to fix problem tags, just use a stack...
                                    'Dim lastUnclosed As String = findLastUnclosed(builder.ToString())
                                    builder.AppendFormat("</{0}>", openXmlTags.Pop)
                                End If
                                carret += 1
                                Exit Select
                            Case GlobalToken.OPAQUE
                                'fix from Max to Min (incorrect conversion from c# carret++ operator into VB.NET)
                                Dim opLenght As Byte = WBXmlData(System.Math.Min(System.Threading.Interlocked.Increment(carret), carret - 1))
                                builder.Append(BitConverter.ToString(WBXmlData, carret, opLenght))
                                Exit Select
 
                        End Select
                    ElseIf LocalTokens(currentCodePage).CodepageTags.ContainsKey(CByte(WBXmlData(carret) And &H3F)) Then
                        'local tocken;
                        Dim tagFromToken As String = LocalTokens(currentCodePage).CodepageTags(CByte(WBXmlData(carret) And &H3F))
 
                        'remember which codepages are being used so we know which namspaces to add to the XML
                        If Not codepagesUsed.Contains(currentCodePage) Then
                            codepagesUsed.Add(currentCodePage)
                        End If
 
                        'if its not the default namespace, we need to encode the tag
                        If Not currentCodePage = codepagesUsed(0) Then
                            tagFromToken = LocalTokens(currentCodePage).XmlPrefix & ":" & tagFromToken
                        End If
 
                        Dim hasAttrs As Boolean = CByte(WBXmlData(carret) And &H80) = &H80
                        Dim hasContent As Boolean = CByte(WBXmlData(carret) And &H40) = &H40
                        builder.AppendFormat("{2}{0}{1}", tagFromToken, If(hasAttrs, " ", (If(Not hasContent, "/>", ">"))), If(Not waitForAttr, "<", ""))
                        waitForAttr = hasAttrs
                        waitForContent = hasContent
                        If waitForContent Then openXmlTags.Push(tagFromToken)
                        carret += 1
                    Else
                        'nothing
                        carret += 1
                        If carret >= WBXmlData.Length Then
                            Exit While
                        End If
 
                    End If
                End While
            End If
 
            Try
                Dim fullXml As String = builder.ToString()
 
                'we need to insert the xmlns prefixes in the root node
                Dim defaultCodepage As Integer = codepagesUsed(0)
                Dim prefixShebang As String = String.Format(" xmlns=""{0}""", LocalTokens(defaultCodepage).XmlNs)
 
                For i As Integer = 1 To codepagesUsed.Count - 1
                    prefixShebang &= String.Format(" xmlns:{0}=""{1}""", LocalTokens(codepagesUsed(i)).XmlPrefix, LocalTokens(codepagesUsed(i)).XmlNs)
                Next
                codepagesUsed.Clear()
 
                'inject the namespaces
                fullXml = fullXml.Insert(fullXml.IndexOf(">"c), prefixShebang)
 
                MyBase.LoadXml(fullXml)
 
            Catch xex As XmlException
                Throw xex
            Catch ex As Exception
                Throw ex
            End Try
        End Sub
 
 
        'DEPRECATED - now using a stack to track open tags
        'Private Function findLastUnclosed(ByVal p As String) As String
        '    Dim allTagsRX As String = "<(/)?([a-z]+)[^>]*?(/)?>"
        '    Dim rx As New Regex(allTagsRX, RegexOptions.Compiled Or RegexOptions.IgnoreCase Or RegexOptions.Singleline)
        '    Dim matches As MatchCollection = rx.Matches(p)
        '    Dim tags As New List(Of String)()
        '    For Each m As Match In matches
        '        If m.Groups(1).Value = String.Empty Then
        '            tags.Add(m.Groups(2).Value)
        '        Else
        '            tags.Remove(m.Groups(2).Value)
        '        End If
 
        '        If m.Groups(3).Value <> String.Empty Then
        '            tags.Remove(m.Groups(2).Value)
        '        End If
        '    Next
        '    If tags.Count = 0 Then
        '        Return String.Empty
        '    Else
        '        Return tags(tags.Count - 1)
        '    End If
 
        'End Function
 
        Private Function lookupLocalTokens(ByVal value As String, ByRef dicID As Integer) As Byte
            dicID = currentCodePage
 
            'make sure we are on the right codepage (using xmlprefix)
            'so we can identify codepage changes in creating WBXML AirSync request.
            If value.Contains(":") Then
                Dim parts() As String = value.Split(":"c)
                Dim prefix As String = parts(0)
                value = parts(1)
 
                'find the codepage to which this namespace belongs
                For Each key As Integer In LocalTokens.Keys
                    If LocalTokens(key).XmlPrefix = prefix Then
                        dicID = key
                    End If
                Next
            End If
 
            If LocalTokens.ContainsKey(dicID) Then
                For Each b As Byte In LocalTokens(dicID).CodepageTags.Keys
                    If LocalTokens(dicID).CodepageTags(b) = value Then
                        Return b
                    End If
                Next
            End If
 
            'if we did not find it then mustnt be namespaced, this is the original code which will find the first codepage with a matching token
            For Each key As Integer In LocalTokens.Keys
                For Each b As Byte In LocalTokens(key).CodepageTags.Keys
                    If LocalTokens(key).CodepageTags(b) = value Then
                        dicID = key
                        Return b
                    End If
                Next
            Next
 
 
            Return Byte.MinValue
        End Function
 
        Private Function lookupLocalAttrs(ByVal value As String, ByRef dicID As Integer) As Byte
            dicID = currentCodePage
            If LocalAttributes.ContainsKey(dicID) Then
                For Each b As Byte In LocalAttributes(dicID).Keys
                    If LocalAttributes(dicID)(b) = value Then
                        Return b
                    End If
                Next
            End If
 
            For Each key As Integer In LocalAttributes.Keys
                For Each b As Byte In LocalAttributes(key).Keys
                    If LocalAttributes(key)(b) = value Then
                        dicID = key
                        Return b
                    End If
                Next
            Next
 
 
            Return Byte.MinValue
        End Function
 
        Public Function GetBytes() As Byte()
            Dim resp As New List(Of Byte)()
            'version
            resp.Add(If(VersionNumber <> String.Empty, Byte.Parse(VersionNumber.Replace("1.", String.Empty)), CByte(&H0)))
 
            'public identifier 
            resp.Add(&H1)
 
            'encoding (UTF8)
            resp.Add(&H6A)
 
            'string table length
            resp.Add(0)
 
            Using reader As XmlReader = New XmlNodeReader(Me.DocumentElement)
                reader.MoveToFirstAttribute()
                resp.AddRange(readNode(reader))
            End Using
 
            Return resp.ToArray()
        End Function
 
        Private Overloads Function readNode(ByVal root As XmlReader) As Byte()
            Dim tmpBytes As New List(Of Byte)()
            Dim depth As Integer = root.Depth
            While root.Read()
                If root.EOF Then
                    Return tmpBytes.ToArray()
                ElseIf root.IsStartElement() Then
                    Dim dicID As Integer = currentCodePage
                    Dim tk As Byte = lookupLocalTokens(root.Name, dicID)
                    If tk <> Byte.MinValue Then
 
                        tmpBytes.AddRange(addSwitch(dicID))
 
                        'test for attributes seperately, if no token we dont wanna encode this
                        Dim tagByte As Byte = CByte(tk + CByte(If(Not root.IsEmptyElement, &H40, &H0)))
 
 
                        'has content & attributes;
                        If root.HasAttributes Then
                            While root.MoveToNextAttribute()
                                tk = lookupLocalAttrs(root.Name, dicID)
                                If tk <> Byte.MinValue Then
                                    'advise we are putting an attribute
                                    tagByte += CByte(&H80)
 
                                    'put the tag byte
                                    tmpBytes.Add(tagByte)
 
                                    'now add the attribute
                                    tmpBytes.AddRange(addSwitch(dicID))
                                    tmpBytes.Add(tk)
                                    tmpBytes.Add(CByte(GlobalToken.[END]))
                                Else
                                    'just add the tag byte
                                    tmpBytes.Add(tagByte)
                                End If
                            End While
                        Else
                            'just add the tag byte
                            tmpBytes.Add(tagByte)
                        End If
                    End If
 
                    If root.NodeType = XmlNodeType.Text AndAlso root.ValueType Is GetType(String) Then
                        tmpBytes.Add(CByte(GlobalToken.STR_I))
                        tmpBytes.AddRange(Encoding.UTF8.GetBytes(root.Value))
                        tmpBytes.Add(&H0)
                    ElseIf root.Depth > depth Then
                        tmpBytes.AddRange(readNode(root))
 
 
                    End If
                ElseIf root.NodeType = XmlNodeType.Text AndAlso root.ValueType Is GetType(String) Then
                    tmpBytes.Add(CByte(GlobalToken.STR_I))
                    tmpBytes.AddRange(Encoding.UTF8.GetBytes(root.Value))
                    tmpBytes.Add(&H0)
                ElseIf root.NodeType = XmlNodeType.EndElement Then
                    tmpBytes.Add(CByte(GlobalToken.[END]))
 
 
                End If
            End While
 
            Return tmpBytes.ToArray()
 
        End Function
 
        Private Function addSwitch(ByVal dicId As Integer) As Byte()
            Dim bts As Byte() = New Byte(-1) {}
            If dicId <> currentCodePage Then
                bts = New Byte(1) {}
                bts(0) = CByte(GlobalToken.SWITCH_PAGE)
                bts(1) = CByte(dicId)
            End If
            currentCodePage = dicId
 
            Return bts
        End Function
 
 
    End Class
End Namespace

Namespace EncodingHelpers.WBXML
    Public Class WbXmlCodepage
 
        'the xml namespace associated with this codepage
        Private _xmlns As String
        Public Property XmlNs() As String
            Get
                Return _xmlns
            End Get
            Set(ByVal value As String)
                _xmlns = value
            End Set
        End Property
 
        'this xml prefix for the associated namespace
        Private _xmlPrefix As String
        Public Property XmlPrefix() As String
            Get
                Return _xmlPrefix
            End Get
            Set(ByVal value As String)
                _xmlPrefix = value
            End Set
        End Property
 
        'codepage number
        Private _codePage As Integer
        Public Property Codepage() As Integer
            Get
                Return _codePage
            End Get
            Set(ByVal value As Integer)
                _codePage = value
            End Set
        End Property
 
        'the codepage tags
        Private _codepageTags As Dictionary(Of Byte, String)
        Public Property CodepageTags() As Dictionary(Of Byte, String)
            Get
                Return _codepageTags
            End Get
            Set(ByVal value As Dictionary(Of Byte, String))
                _codepageTags = value
            End Set
        End Property
    End Class
End Namespace

<%@ Control Language="vb" AutoEventWireup="false" CodeBehind="OutlookCalendarWidget.ascx.vb" Inherits="UserControls.OutlookCalendarWidget" %>
<div id="ConnectToActiveSync">
<asp:Panel ID="pnlSetUserContext" runat="server" Visible="false"  DefaultButton="btnSetUserContext">
    Exchange User: <asp:TextBox ID="txtUsername" runat="server"></asp:TextBox>
    <asp:Button ID="btnSetUserContext" runat="server" Text="Begin" />
</asp:Panel>
 
<asp:Panel ID="pnlSubmitExchangePw" runat="server" Visible="false" DefaultButton="btnSubmitExchangePass">
In order to connect to Exchange, you will need to provide your login password:
    <asp:TextBox ID="txtExchangePass" runat="server" TextMode="Password"></asp:TextBox>
    <asp:Button ID="btnSubmitExchangePass" runat="server" Text="Continue" />
</asp:Panel>
<asp:Panel ID="pnlEpicFail" runat="server" visible="false">
Could not connect to Exchange server. Check connectivity.
</asp:Panel>
</div>
 
<asp:Panel ID="pnlOutlookCalendar" runat="server" Visible="false">
    <asp:Panel ID="pnlNotAuth" runat="server" visible="false">
        Not authorised, has your password changed? <asp:Button ID="btnResetPassword" runat="server"  Text="Reset Password"/>
    </asp:Panel>
    <asp:Label ID="lblActiveSyncErrorMessage" runat="server"></asp:Label>
    <asp:Repeater ID="rptCalendarItemGroups" runat="server">
        <ItemTemplate>
        <div class="calender-group-title"><%# Container.DataItem%></div>
        <div class="calendar-group-items">
            <asp:Repeater id="rptCalendarEvents" runat="server" OnItemDataBound="rptCalendarEvents_ItemDataBound">
                <ItemTemplate>
                <asp:Panel ID="pnlCalenderItem" CssClass="calendar-item" runat="server">
                    <div class="calendar-date"><%# IIf(Eval("GroupName") <> "Next Week", IIf(Eval("IsAllDay"), "All day", CDate(Eval("StartTime")).ToString("HH:mm")), CDate(Eval("StartTime")).ToString("ddd"))%></div>
                    <div class="calendar-subject"><%# Eval("Subject")%></div>
 
                    <div class="calendar-duration"><%# IIf(Not Eval("IsAllDay"), Eval("TimespanString"), "")%></div>
                    <div class="calendar-location"><span title='<%# Eval("AttendeesList") %>'><%# IIf(Eval("Location") <>"", "(" & Eval("Location") & ")" , "")%></span></div>
                </asp:Panel>
                </ItemTemplate>
            </asp:Repeater>
        </div>
        </ItemTemplate>
    </asp:Repeater>
</asp:Panel>

Namespace UserControls
    Public Class OutlookCalendarWidget
        Inherits System.Web.UI.UserControl
 
 
        Private Const _activeSyncServer As String = "https://webmail.yourdomain.com/"
        Private _calendarItems As List(Of CalendarItem)
 
        Protected Class CalendarItem
            Public Class Attendee
                Public Property Name As String
                Public Property Email As String
 
            End Class
 
            Public Property IsAllDay As Boolean
            Public Property StartTime As DateTime
            Public Property EndTime As DateTime
            Public Property Subject As String
            Public Property Location As String
            Public Property Attendees As New List(Of Attendee)
 
            Private _groupName As String
            Public ReadOnly Property GroupName As String
                Get
                    If String.IsNullOrEmpty(_groupName) Then
                        'categorize this calendar entry into a group
                        Dim daysFromToday As TimeSpan = StartTime.Date.Subtract(Today.Date)
                        Select Case daysFromToday.Days
                            Case Is < 0
                                _groupName = "Past"
                            Case Is = 0
                                _groupName = "Today"
                            Case Is <= 7
                                _groupName = StartTime.ToString("dddd")
                            Case Is <= 14
                                _groupName = "Next Week"
                            Case Else
                                _groupName = "Rest of Year"
                        End Select
                    End If
 
                    Return _groupName
                End Get
            End Property
 
            Public ReadOnly Property TimespanString As String
                Get
                    Dim format As String = ""
 
                    Dim elapsed As TimeSpan = EndTime.Subtract(StartTime)
 
                    'any days?
                    If elapsed.Days > 0 Then format &= "d'days'"
 
                    'hours?
                    If elapsed.Hours > 0 Then format &= CStr(IIf(format <> "", "\ ", "")) & "h'hrs'"
 
                    'mins?
                    If elapsed.Minutes > 0 Then format &= CStr(IIf(format <> "", "\ ", "")) & "m'mins'"
 
                    Return elapsed.ToString(format)
                End Get
            End Property
 
            Public ReadOnly Property AttendeesList As String
                Get
                    Return String.Join(", ", From a In Attendees Select a.Name)
                End Get
            End Property
        End Class
 
 
        Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
 
            If Not IsPostBack Then
                MessageLoop()
            End If
 
        End Sub
 
 
        Private Function GetUsername() As String
            If HttpContext.Current.User IsNot Nothing AndAlso HttpContext.Current.User.Identity IsNot Nothing AndAlso Not String.IsNullOrEmpty(HttpContext.Current.User.Identity.Name) Then
                'domain logged in - get the username
                Return HttpContext.Current.User.Identity.Name
            Else
                Return txtUsername.Text
            End If
        End Function
 
        Private Function GetPassword() As String
            Return txtExchangePass.Text
        End Function
 
        Private Sub SyncCalendar()
            Try
                Dim fullUsername As String = GetUsername()
                Dim username As String = ""
                Dim domain As String = ""
 
                Dim pw As String = GetPassword()
 
                'check for domain login
                If fullUsername.Contains("\") Then
                    Dim parts() As String = fullUsername.Split("\"c)
                    domain = parts(0)
                    username = parts(1)
                Else
                    username = fullUsername
                End If
 
                Dim asHelper As New Email.Exchange.AirSync.AirSyncHelper(_activeSyncServer, username, pw, domain)
 
                If asHelper.IsVersionCompatible() Then
                    'make sure the policy key is populated (if applicable) - not required for this version
                    'asHelper.ObtainPolicyKey()
 
                    'do an initial folder sync for the user (resets the sync on the server)
                    Dim initFolderSyncResult As System.Xml.XmlDocument = GetFolderSyncResult(asHelper, "0")
 
                    'use a namespace manager for FolderSync
                    Dim initFolderSyncNsMgr As New System.Xml.XmlNamespaceManager(initFolderSyncResult.NameTable)
 
                    'since XPATH 1 doesnt support default namespaces, we will have to invent our own
                    initFolderSyncNsMgr.AddNamespace("dflt", Email.Exchange.AirSync.Codepages.FolderHierarchy_7.Instance.XmlNs)
 
                    Dim statusNode As System.Xml.XmlNode = initFolderSyncResult.SelectSingleNode("dflt:FolderSync/dflt:Status", initFolderSyncNsMgr)
                    If statusNode IsNot Nothing AndAlso statusNode.InnerText = "1" Then
                        Dim folderSyncSyncKeyNode As System.Xml.XmlNode = initFolderSyncResult.SelectSingleNode("dflt:FolderSync/dflt:SyncKey", initFolderSyncNsMgr)
 
                        If folderSyncSyncKeyNode IsNot Nothing Then
                            'use the sync key to start a sync session on the server to complete the foldersync cycle
                            GetFolderSyncResult(asHelper, folderSyncSyncKeyNode.InnerText)
 
                            'do a sync on the calendar folder by using the server Id of the calendar from the initial sync
                            Dim calendarFolderNode As System.Xml.XmlNode = initFolderSyncResult.SelectSingleNode("dflt:FolderSync/dflt:Changes/dflt:Add[dflt:DisplayName = ""Calendar""]", initFolderSyncNsMgr)
 
                            If calendarFolderNode IsNot Nothing Then
                                Dim calendarFolderServerId As String = calendarFolderNode("ServerId").InnerText
                                Dim initialCalendarSyncResult As System.Xml.XmlDocument = GetSyncResult(asHelper, calendarFolderServerId, "Calendar", "0")
 
                                'use a namespace manager for Sync
                                Dim initCalSyncNsMgr As New System.Xml.XmlNamespaceManager(initialCalendarSyncResult.NameTable)
 
                                'since XPATH 1 doesnt support default namespaces, we will have to invent our own
                                initCalSyncNsMgr.AddNamespace("dflt", Email.Exchange.AirSync.Codepages.AirSync_0.Instance.XmlNs)
 
                                Dim calendarSyncKeyNode As System.Xml.XmlNode = initialCalendarSyncResult.SelectSingleNode("dflt:Sync/dflt:Collections/dflt:Collection/dflt:SyncKey", initCalSyncNsMgr)
 
                                If calendarSyncKeyNode IsNot Nothing Then
                                    'now we can do a second sync to get the juicy stuff
                                    Dim calendarSyncKey As String = calendarSyncKeyNode.InnerText
 
                                    Dim juicyCalendarSyncResult As System.Xml.XmlDocument = GetSyncResult(asHelper, calendarFolderServerId, "Calendar", calendarSyncKey)
 
                                    _calendarItems = ParseCalender(juicyCalendarSyncResult)
 
                                    If _calendarItems IsNot Nothing AndAlso _calendarItems.Count > 0 Then
 
                                        'bind the groups in date order (dont include items from the past)
                                        rptCalendarItemGroups.DataSource = (From ci In _calendarItems Order By ci.StartTime Ascending Where ci.StartTime.Date >= Today.Date And ci.StartTime.Date <= Today.Date.AddDays(14) Group ci By ci.GroupName Into g = Group Select g.First().GroupName)
                                        rptCalendarItemGroups.DataBind()
 
                                        If rptCalendarItemGroups.Items.Count = 0 Then lblActiveSyncErrorMessage.Text = "You have no calendar items to display"
                                    Else
                                        'couldnt do it - after all that!!
                                        lblActiveSyncErrorMessage.Text = "Could not do  sync the calendar folder. "
 
                                        'see if there was a status from AS
                                        'use a namespace manager for FolderSync
                                        Dim statusNsMgr As New System.Xml.XmlNamespaceManager(juicyCalendarSyncResult.NameTable)
 
                                        'since XPATH 1 doesnt support default namespaces, we will have to invent our own
                                        statusNsMgr.AddNamespace("dflt", Email.Exchange.AirSync.Codepages.AirSync_0.Instance.XmlNs)
 
                                        Dim juicyStatusNode As System.Xml.XmlNode = juicyCalendarSyncResult.SelectSingleNode("dflt:Sync/dflt:Collections/dflt:Collection/dflt:Status", statusNsMgr)
                                        If juicyStatusNode IsNot Nothing Then lblActiveSyncErrorMessage.Text &= " ActiveSync status: " & juicyStatusNode.InnerText
                                    End If
 
 
                                Else
                                    lblActiveSyncErrorMessage.Text = "Could not do initial sync on the calendar folder."
                                End If
 
 
                            Else
                                lblActiveSyncErrorMessage.Text = "There is no calendar folder found in the initial folder sync."
                            End If
 
                        Else
                            lblActiveSyncErrorMessage.Text = "Could not find SyncKey in FolderSync response."
                        End If
 
                    Else
                        lblActiveSyncErrorMessage.Text = "Initial FolderSync did not complete."
                        If statusNode IsNot Nothing Then lblActiveSyncErrorMessage.Text &= " ActiveSync status: " & statusNode.InnerText
                    End If
 
 
                Else
                    Throw New Exception("Server does not support the correct verion of AirSync. Required version: " & Email.Exchange.AirSync.AirSyncHelper.AirSyncSupportedVersion)
                End If
            Catch wEx As Net.WebException
                If wEx.Message.Contains("401") Then
                    pnlNotAuth.Visible = True
                Else
                    Throw wEx
                End If
            Catch ex As Exception
                lblActiveSyncErrorMessage.Text = "Could not connect to ActiveSync. " & ex.Message
            End Try
 
        End Sub
 
        Private Function GetFolderSyncResult(ByVal asHelper As Email.Exchange.AirSync.AirSyncHelper, ByVal syncKey As String) As System.Xml.XmlDocument
            Dim xmlRequestData As String = <?xml version="1.0" encoding="utf-8"?>
                                           <FolderSync xmlns="FolderHierarchy:">
                                               <SyncKey>{SyncKey}</SyncKey>
                                           </FolderSync>.ToString().Replace("{SyncKey}", syncKey)
 
            Return asHelper.ExecuteAirSyncCommand("FolderSync", xmlRequestData)
 
        End Function
 
        Private Function GetSyncResult(ByVal asHelper As Email.Exchange.AirSync.AirSyncHelper, ByVal collectionId As String, ByVal className As String, ByVal syncKey As String) As System.Xml.XmlDocument
            Dim xmlRequestData As String
 
            'initial sync has different body content
            If syncKey = "0" Then
                xmlRequestData = <?xml version="1.0" encoding="utf-8"?>
                                 <Sync xmlns="AirSync:">
                                     <Collections>
                                         <Collection>
                                             <Class>{ClassName}</Class>
                                             <SyncKey>{SyncKey}</SyncKey>
                                             <CollectionId>{CollectionId}</CollectionId>
                                         </Collection>
                                     </Collections>
                                 </Sync>.ToString().Replace("{SyncKey}", syncKey).Replace("{CollectionId}", collectionId).Replace("{ClassName}", className)
            Else
                xmlRequestData = <?xml version="1.0" encoding="utf-8"?>
                                 <Sync xmlns="AirSync:">
                                     <Collections>
                                         <Collection>
                                             <Class>{ClassName}</Class>
                                             <SyncKey>{SyncKey}</SyncKey>
                                             <CollectionId>{CollectionId}</CollectionId>
                                             <DeletesAsMoves/>
                                             <GetChanges/>
                                         </Collection>
                                     </Collections>
                                 </Sync>.ToString().Replace("{SyncKey}", syncKey).Replace("{CollectionId}", collectionId).Replace("{ClassName}", className)
            End If
 
            Return asHelper.ExecuteAirSyncCommand("Sync", xmlRequestData)
 
        End Function
 
 
        Private Sub rptCalendarItemGroups_ItemDataBound(ByVal sender As Object, ByVal e As System.Web.UI.WebControls.RepeaterItemEventArgs) Handles rptCalendarItemGroups.ItemDataBound
            If e.Item.ItemType = ListItemType.Item Or e.Item.ItemType = ListItemType.AlternatingItem Then
                Dim rptCalendarEvents As Repeater = CType(e.Item.FindControl("rptCalendarEvents"), Repeater)
 
                rptCalendarEvents.DataSource = From ci In _calendarItems Where ci.GroupName = CStr(e.Item.DataItem) Order By ci.StartTime Ascending Select ci
                rptCalendarEvents.DataBind()
            End If
        End Sub
 
        Protected Sub rptCalendarEvents_ItemDataBound(ByVal sender As Object, ByVal e As System.Web.UI.WebControls.RepeaterItemEventArgs)
            If e.Item.ItemType = ListItemType.Item Or e.Item.ItemType = ListItemType.AlternatingItem Then
                If DirectCast(e.Item.DataItem, CalendarItem).EndTime < Now Then
                    Dim pnlCalenderItem As Panel = CType(e.Item.FindControl("pnlCalenderItem"), Panel)
                    pnlCalenderItem.CssClass &= " strikeout"
                End If
            End If
        End Sub
 
        'Private isAlt As Boolean = False
        'Protected Function GetCalendarRowIsAlt() As Boolean
        '    'remember current row
        '    Dim thisOneIsAlt As Boolean = isAlt
 
        '    'invert for next call
        '    isAlt = Not isAlt
 
        '    Return thisOneIsAlt
        'End Function
 
        Private Function ParseCalender(ByVal juicyCalendarSyncResult As System.Xml.XmlDocument) As List(Of CalendarItem)
            Dim cItems As List(Of CalendarItem) = Nothing
 
            'use a namespace manager for Calendar Sync
            Dim juicyCalSyncNsMgr As New System.Xml.XmlNamespaceManager(juicyCalendarSyncResult.NameTable)
 
            'since XPATH 1 doesnt support default namespaces, we will have to invent our own + register the calendar prefix
            juicyCalSyncNsMgr.AddNamespace("dflt", Email.Exchange.AirSync.Codepages.AirSync_0.Instance.XmlNs)
            juicyCalSyncNsMgr.AddNamespace(Email.Exchange.AirSync.Codepages.Calendar_4.Instance.XmlPrefix, Email.Exchange.AirSync.Codepages.Calendar_4.Instance.XmlNs)
 
            Dim juicyStatusNode As System.Xml.XmlNode = juicyCalendarSyncResult.SelectSingleNode("dflt:Sync/dflt:Collections/dflt:Collection/dflt:Status", juicyCalSyncNsMgr)
            If juicyStatusNode IsNot Nothing AndAlso juicyStatusNode.InnerText = "1" Then
                'we can bindings to repeaterings
                cItems = New List(Of CalendarItem)
                For Each node As System.Xml.XmlNode In juicyCalendarSyncResult.SelectNodes("dflt:Sync/dflt:Collections/dflt:Collection/dflt:Commands/dflt:Add/dflt:ApplicationData", juicyCalSyncNsMgr)
                    Dim ci As New CalendarItem
                    ci.StartTime = DateTime.ParseExact(node("StartTime", "Calendar:").InnerText, "yyyyMMdd'T'HHmmss'Z'", Globalization.CultureInfo.CurrentCulture)
                    ci.EndTime = DateTime.ParseExact(node("EndTime", "Calendar:").InnerText, "yyyyMMdd'T'HHmmss'Z'", Globalization.CultureInfo.CurrentCulture)
                    ci.Subject = node("Subject", "Calendar:").InnerText
                    ci.IsAllDay = (node("AllDayEvent", "Calendar:") IsNot Nothing AndAlso node("AllDayEvent", "Calendar:").InnerText = "1")
 
                    If node("Location", "Calendar:") IsNot Nothing Then
                        ci.Location = node("Location", "Calendar:").InnerText
                    End If
 
                    'get all the accepted attendees
                    If node("Attendees", "Calendar:") IsNot Nothing Then
                        Dim attendees As System.Xml.XmlNodeList = node.SelectNodes("calendar:Attendees/calendar:Attendee", juicyCalSyncNsMgr)
                        For Each attendee As System.Xml.XmlNode In attendees
                            'accepted? (or not specified)
                            If attendee("AttendeeStatus", "Calendar:") Is Nothing OrElse attendee("AttendeeStatus", "Calendar:").InnerText <> "4" Then
                                ci.Attendees.Add(New CalendarItem.Attendee() With {
                                                 .Name = attendee("Attendee_Name", "Calendar:").InnerText,
                                                 .Email = attendee("Attendee_Email", "Calendar:").InnerText})
 
                            End If
                        Next
 
                        'organizer is attending
                        If node("Organizer_Name", "Calendar:") IsNot Nothing Then
                            Dim organiserName As String = node("Organizer_Name", "Calendar:").InnerText
                            If Not ci.AttendeesList.Contains(organiserName) Then
                                ci.Attendees.Add(New CalendarItem.Attendee() With {
                                                 .Name = organiserName,
                                                 .Email = node("Organizer_Email", "Calendar:").InnerText})
                            End If
                        End If
 
                    End If
 
                    cItems.Add(ci)
                Next
 
            End If
 
            Return cItems
        End Function
 
        Private Sub btnSetUserContext_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles btnSetUserContext.Click
            MessageLoop()
        End Sub
 
        Private Sub MessageLoop()
            pnlEpicFail.Visible = False
            pnlOutlookCalendar.Visible = False
            pnlSetUserContext.Visible = False
            pnlSubmitExchangePw.Visible = False
 
            'check we have a username/password and then sync
            If GetUsername() = "" Then
                pnlSetUserContext.Visible = True
            ElseIf GetPassword() = "" Then
                pnlSubmitExchangePw.Visible = True
            Else
                pnlOutlookCalendar.Visible = True
 
                SyncCalendar()
 
            End If
        End Sub
 
        Private Sub btnSubmitExchangePass_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles btnSubmitExchangePass.Click
 
            MessageLoop()
 
        End Sub
 
        Private Sub btnResetPassword_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles btnResetPassword.Click
            'show the password entry screen
            pnlNotAuth.Visible = False
            pnlOutlookCalendar.Visible = False
            pnlSubmitExchangePw.Visible = True
        End Sub
    End Class
End Namespace