Dynamics CRM VBA SOAP only authentication

CrmAuth.bas

Attribute VB_Name = "CrmAuth"
Option Explicit

' Use the PtrSafe attribute for x64 installations
Private Declare PtrSafe Function FileTimeToLocalFileTime Lib "Kernel32" (lpFileTime As FILETIME, ByRef lpLocalFileTime As FILETIME) As Long
Private Declare PtrSafe Function LocalFileTimeToFileTime Lib "Kernel32" (lpLocalFileTime As FILETIME, ByRef lpFileTime As FILETIME) As Long
Private Declare PtrSafe Function SystemTimeToFileTime Lib "Kernel32" (lpSystemTime As SYSTEMTIME, ByRef lpFileTime As FILETIME) As Long
Private Declare PtrSafe Function FileTimeToSystemTime Lib "Kernel32" (lpFileTime As FILETIME, ByRef lpSystemTime As SYSTEMTIME) As Long

Public Type FILETIME
  LowDateTime As Long
  HighDateTime As Long
End Type

Public Type SYSTEMTIME
  Year As Integer
  Month As Integer
  DayOfWeek As Integer
  Day As Integer
  Hour As Integer
  Minute As Integer
  Second As Integer
  Milliseconds As Integer
End Type

''' <summary>
''' Gets a CRM Online SOAP header.
''' </summary>
''' <param name="username">Username of a valid CRM user.</param>
''' <param name="password">Password of a valid CRM user.</param>
''' <param name="url">The Url of the CRM Online organization (https://org.crm.dynamics.com).</param>
''' <returns>The SOAP header XML.</returns>
Public Function GetHeaderOnline(ByVal username As String, ByVal password As String, ByVal url As String)

    If Not EndsWith(url, "/") Then
        url = url & "/"
    End If
    
    Dim urnAddress As String
    urnAddress = GetUrnOnline(url)
    
    Dim now As Date
    now = DateTime.now
    
    Dim xml As String
    xml = "<s:Envelope xmlns:s=""http://www.w3.org/2003/05/soap-envelope"" xmlns:a=""http://www.w3.org/2005/08/addressing"" xmlns:u=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-utility-1.0.xsd"">"
    xml = xml & "<s:Header>"
    xml = xml & "<a:Action s:mustUnderstand=""1"">http://schemas.xmlsoap.org/ws/2005/02/trust/RST/Issue</a:Action>"
    xml = xml & "<a:MessageID>urn:uuid:" & GetGUID() & "</a:MessageID>"
    xml = xml & "<a:ReplyTo>"
    xml = xml & "<a:Address>http://www.w3.org/2005/08/addressing/anonymous</a:Address>"
    xml = xml & "</a:ReplyTo>"
    xml = xml & "<a:To s:mustUnderstand=""1"">https://login.microsoftonline.com/RST2.srf</a:To>"
    xml = xml & "<o:Security s:mustUnderstand=""1"" xmlns:o=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<u:Timestamp u:Id=""_0"">"
    xml = xml & "<u:Created>" & Format(UTCTIME(now), "yyyy-MM-ddThh:mm:ss") & ".0000000Z</u:Created>"
    xml = xml & "<u:Expires>" & Format(DateAdd("n", 60, UTCTIME(now)), "yyyy-MM-ddThh:mm:ss") & ".0000000Z</u:Expires>"
    xml = xml & "</u:Timestamp>"
    xml = xml & "<o:UsernameToken u:Id=""uuid-" & GetGUID() & "-1"">"
    xml = xml & "<o:Username>" & username & "</o:Username>"
    xml = xml & "<o:Password>" & password & "</o:Password>"
    xml = xml & "</o:UsernameToken>"
    xml = xml & "</o:Security>"
    xml = xml & "</s:Header>"
    xml = xml & "<s:Body>"
    xml = xml & "<trust:RequestSecurityToken xmlns:trust=""http://schemas.xmlsoap.org/ws/2005/02/trust"">"
    xml = xml & "<wsp:AppliesTo xmlns:wsp=""http://schemas.xmlsoap.org/ws/2004/09/policy"">"
    xml = xml & "<a:EndpointReference>"
    xml = xml & "<a:Address>urn:" & urnAddress & "</a:Address>"
    xml = xml & "</a:EndpointReference>"
    xml = xml & "</wsp:AppliesTo>"
    xml = xml & "<trust:RequestType>http://schemas.xmlsoap.org/ws/2005/02/trust/Issue</trust:RequestType>"
    xml = xml & "</trust:RequestSecurityToken>"
    xml = xml & "</s:Body>"
    xml = xml & "</s:Envelope>"

    Dim oHttp As Object
    Dim response As New MSXML2.DOMDocument60
    Set response = CreateObject("MSXML2.DOMDocument.6.0")
    
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        GetHeaderOnline = Empty
    End If
    
    oHttp.Open "POST", "https://login.microsoftonline.com/RST2.srf", False
    oHttp.setRequestHeader "Content-Length", Len(xml)
    oHttp.setRequestHeader "Content-Type", "application/soap+xml; charset=UTF-8"
    oHttp.send (xml)
    response.LoadXML oHttp.responseText
    
    Dim token1, token2 As String
    Dim requestedSecurityTokenNodes As MSXML2.IXMLDOMNodeList
    Set requestedSecurityTokenNodes = response.getElementsByTagName("wst:RequestedSecurityToken")
    token1 = requestedSecurityTokenNodes(0).ChildNodes(0).ChildNodes(1).ChildNodes(0).ChildNodes(2).ChildNodes(0).text
    token2 = requestedSecurityTokenNodes(0).ChildNodes(0).ChildNodes(2).ChildNodes(0).text
    
    Dim keyIdentifer As String
    Dim keyIdentifierNodes As MSXML2.IXMLDOMNodeList
    Set keyIdentifierNodes = response.getElementsByTagName("wsse:KeyIdentifier")
    keyIdentifer = keyIdentifierNodes(0).text
    
    Dim tokenExpires As String
    Dim tokenExpiresNodes As MSXML2.IXMLDOMNodeList
    Set tokenExpiresNodes = response.getElementsByTagName("wsu:Expires")
    tokenExpires = tokenExpiresNodes(0).text
    
    Set response = Nothing
    Set oHttp = Nothing
    
    GetHeaderOnline = CreateSoapHeaderOnline(url, keyIdentifer, token1, token2)
    
End Function

''' <summary>
''' Gets a CRM Online SOAP header.
''' </summary>
''' <param name="url">The Url of the CRM Online organization (https://org.crm.dynamics.com).</param>
''' <param name="keyIdentifer">The KeyIdentifier from the initial request.</param>
''' <param name="token1">The first token from the initial request.</param>
''' <param name="token2">The second token from the initial request.</param>
''' <returns>The XML SOAP header to be used in future requests.</returns>
Private Function CreateSoapHeaderOnline(ByVal url As String, ByVal keyIdentifier As String, ByVal token1 As String, ByVal token2 As String)

    Dim xml As String
    xml = "<s:Header>"
    xml = xml & "<a:Action s:mustUnderstand=""1"">http://schemas.microsoft.com/xrm/2011/Contracts/Services/IOrganizationService/Execute</a:Action>"
    xml = xml & "<Security xmlns=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<EncryptedData Id=""Assertion0"" Type=""http://www.w3.org/2001/04/xmlenc#Element"" xmlns=""http://www.w3.org/2001/04/xmlenc#"">"
    xml = xml & "<EncryptionMethod Algorithm=""http://www.w3.org/2001/04/xmlenc#tripledes-cbc""/>"
    xml = xml & "<ds:KeyInfo xmlns:ds=""http://www.w3.org/2000/09/xmldsig#"">"
    xml = xml & "<EncryptedKey>"
    xml = xml & "<EncryptionMethod Algorithm=""http://www.w3.org/2001/04/xmlenc#rsa-oaep-mgf1p""/>"
    xml = xml & "<ds:KeyInfo Id=""keyinfo"">"
    xml = xml & "<wsse:SecurityTokenReference xmlns:wsse=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<wsse:KeyIdentifier EncodingType=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-soap-message-security-1.0#Base64Binary"" ValueType=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-x509-token-profile-1.0#X509SubjectKeyIdentifier"">" & keyIdentifier & "</wsse:KeyIdentifier>"
    xml = xml & "</wsse:SecurityTokenReference>"
    xml = xml & "</ds:KeyInfo>"
    xml = xml & "<CipherData>"
    xml = xml & "<CipherValue>" & token1 & "</CipherValue>"
    xml = xml & "</CipherData>"
    xml = xml & "</EncryptedKey>"
    xml = xml & "</ds:KeyInfo>"
    xml = xml & "<CipherData>"
    xml = xml & "<CipherValue>" & token2 & "</CipherValue>"
    xml = xml & "</CipherData>"
    xml = xml & "</EncryptedData>"
    xml = xml & "</Security>"
    xml = xml & "<a:MessageID>urn:uuid:" & GetGUID() & "</a:MessageID>"
    xml = xml & "<a:ReplyTo>"
    xml = xml & "<a:Address>http://www.w3.org/2005/08/addressing/anonymous</a:Address>"
    xml = xml & "</a:ReplyTo>"
    xml = xml & "<a:To s:mustUnderstand=""1"">" & url & "XRMServices/2011/Organization.svc</a:To>"
    xml = xml & "</s:Header>"
    
    CreateSoapHeaderOnline = xml
    
End Function

''' <summary>
''' Gets the correct URN Address based on the Online region.
''' </summary>
''' <param name="url">The Url of the CRM Online organization (https://org.crm.dynamics.com).</param>
''' <returns>URN Address.</returns>
Private Function GetUrnOnline(ByVal url As String)
    If InStr(1, UCase(url), "CRM2.DYNAMICS.COM", vbTextCompare) > 0 Then
        GetUrnOnline = "crmsam:dynamics.com"
    ElseIf InStr(1, UCase(url), "CRM4.DYNAMICS.COM", vbTextCompare) > 0 Then
        GetUrnOnline = "crmemea:dynamics.com"
    ElseIf InStr(1, UCase(url), "CRM5.DYNAMICS.COM", vbTextCompare) > 0 Then
        GetUrnOnline = "crmapac:dynamics.com"
    Else
        GetUrnOnline = "crmna:dynamics.com"
    End If
        
End Function


''' <summary>
''' Gets a CRM On Premise SOAP header.
''' </summary>
''' <param name="username">Username of a valid CRM user.</param>
''' <param name="password">Password of a valid CRM user.</param>
''' <param name="url">The Url of the CRM On Premise (IFD) organization (https://org.domain.com).</param>
''' <returns>The SOAP header XML.</returns>
Public Function GetHeaderOnPremise(ByVal username As String, ByVal password As String, ByVal url As String)

    If Not EndsWith(url, "/") Then
        url = url & "/"
    End If
    
    Dim adfsUrl As String
    adfsUrl = GetAdfs(url)
    If adfsUrl = Empty Then
        GetHeaderOnPremise = Empty
    End If
     
    Dim urnAddress, usernamemixed As String
    Dim now As Date
    now = DateTime.now
    
    urnAddress = url & "XRMServices/2011/Organization.svc"
    usernamemixed = adfsUrl & "/13/usernamemixed"
    
    Dim xml As String
    xml = "<s:Envelope xmlns:s=""http://www.w3.org/2003/05/soap-envelope"" xmlns:a=""http://www.w3.org/2005/08/addressing"">"
    xml = xml & "<s:Header>"
    xml = xml & "<a:Action s:mustUnderstand=""1"">http://docs.oasis-open.org/ws-sx/ws-trust/200512/RST/Issue</a:Action>"
    xml = xml & "<a:MessageID>urn:uuid:" & GetGUID() & "</a:MessageID>"
    xml = xml & "<a:ReplyTo>"
    xml = xml & "<a:Address>http://www.w3.org/2005/08/addressing/anonymous</a:Address>"
    xml = xml & "</a:ReplyTo>"
    xml = xml & "<Security s:mustUnderstand=""1"" xmlns:u=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-utility-1.0.xsd"" xmlns=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<u:Timestamp  u:Id=""" & GetGUID() & """>"
    xml = xml & "<u:Created>" & Format(UTCTIME(now), "yyyy-MM-ddThh:mm:ss") & ".0000000Z</u:Created>"
    xml = xml & "<u:Expires>" & Format(DateAdd("n", 60, UTCTIME(now)), "yyyy-MM-ddThh:mm:ss") & ".0000000Z</u:Expires>"
    xml = xml & "</u:Timestamp>"
    xml = xml & "<UsernameToken u:Id=""" & GetGUID() & """>"
    xml = xml & "<Username>" & username & "</Username>"
    xml = xml & "<Password Type=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-username-token-profile-1.0#PasswordText"">" & password & "</Password>"
    xml = xml & "</UsernameToken>"
    xml = xml & "</Security>"
    xml = xml & "<a:To s:mustUnderstand=""1"">" & usernamemixed & "</a:To>"
    xml = xml & "</s:Header>"
    xml = xml & "<s:Body>"
    xml = xml & "<trust:RequestSecurityToken xmlns:trust=""http://docs.oasis-open.org/ws-sx/ws-trust/200512"">"
    xml = xml & "<wsp:AppliesTo xmlns:wsp=""http://schemas.xmlsoap.org/ws/2004/09/policy"">"
    xml = xml & "<a:EndpointReference>"
    xml = xml & "<a:Address>" & urnAddress & "</a:Address>"
    xml = xml & "</a:EndpointReference>"
    xml = xml & "</wsp:AppliesTo>"
    xml = xml & "<trust:RequestType>http://docs.oasis-open.org/ws-sx/ws-trust/200512/Issue</trust:RequestType>"
    xml = xml & "</trust:RequestSecurityToken>"
    xml = xml & "</s:Body>"
    xml = xml & "</s:Envelope>"
    
    Dim oHttp As Object
    Dim response As New MSXML2.DOMDocument60
    Set response = CreateObject("MSXML2.DOMDocument.6.0")
    
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        GetHeaderOnPremise = Empty
    End If
    
    oHttp.Open "POST", usernamemixed, False
    oHttp.setRequestHeader "Content-Length", Len(xml)
    oHttp.setRequestHeader "Content-Type", "application/soap+xml; charset=UTF-8"
    oHttp.send (xml)
    response.LoadXML oHttp.responseText
      
    Dim token1 As String
    Dim cipherValue1Nodes As MSXML2.IXMLDOMNodeList
    Set cipherValue1Nodes = response.getElementsByTagName("e:CipherValue")
    token1 = cipherValue1Nodes(0).text
    
    Dim token2 As String
    Dim cipherValue2Nodes As MSXML2.IXMLDOMNodeList
    Set cipherValue2Nodes = response.getElementsByTagName("xenc:CipherValue")
    token2 = cipherValue2Nodes(0).text
    
    Dim keyIdentifer As String
    Dim keyIdentiferNodes As MSXML2.IXMLDOMNodeList
    Set keyIdentiferNodes = response.getElementsByTagName("o:KeyIdentifier")
    keyIdentifer = keyIdentiferNodes(0).text
    
    Dim x509IssuerName As String
    Dim securityTokenReferenceNodes As MSXML2.IXMLDOMNodeList
    
    Set securityTokenReferenceNodes = response.getElementsByTagName("o:SecurityTokenReference")
    x509IssuerName = securityTokenReferenceNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(0).text
       
    Dim x509SerialNumber As String
    x509SerialNumber = securityTokenReferenceNodes(0).ChildNodes(0).ChildNodes(0).ChildNodes(1).text
    
    Dim binarySecret As String
    Dim binarySecretNodes As MSXML2.IXMLDOMNodeList
    Set binarySecretNodes = response.getElementsByTagName("trust:BinarySecret")
    binarySecret = binarySecretNodes(0).text

    Set response = Nothing
    Set oHttp = Nothing
    
    Dim created, expires, timestamp As String
    created = Format(DateAdd("n", -1, UTCTIME(now)), "yyyy-MM-ddThh:mm:ss") & ".0000000Z"
    expires = Format(DateAdd("n", 60, UTCTIME(now)), "yyyy-MM-ddThh:mm:ss") & ".0000000Z"
    timestamp = "<u:Timestamp xmlns:u=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-utility-1.0.xsd"" u:Id=""_0""><u:Created>" & created & "</u:Created><u:Expires>" & expires & "</u:Expires></u:Timestamp>"
    Dim digestValue As String
    digestValue = SHA1Base64(timestamp)
      
    Dim signedInfo As String
    signedInfo = "<SignedInfo xmlns=""http://www.w3.org/2000/09/xmldsig#""><CanonicalizationMethod Algorithm=""http://www.w3.org/2001/10/xml-exc-c14n#""></CanonicalizationMethod><SignatureMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#hmac-sha1""></SignatureMethod><Reference URI=""#_0""><Transforms><Transform Algorithm=""http://www.w3.org/2001/10/xml-exc-c14n#""></Transform></Transforms><DigestMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#sha1""></DigestMethod><DigestValue>" & digestValue & "</DigestValue></Reference></SignedInfo>"
    Dim signatureValue As String
    signatureValue = Base64_HMACSHA1(signedInfo, binarySecret)
      
    GetHeaderOnPremise = CreateSoapHeaderOnPremise(url, keyIdentifer, token1, token2, x509IssuerName, x509SerialNumber, signatureValue, digestValue, created, expires)
    
End Function

''' <summary>
''' Gets a CRM On Premise (IFD) SOAP header.
''' </summary>
''' <param name="url">The CRM On Premise URL ("https://org.domain.com/").</param>
''' <param name="keyIdentifer">The KeyIdentifier from the initial request.</param>
''' <param name="token1">The first token from the initial request.</param>
''' <param name="token2">The second token from the initial request.</param>
''' <param name="issuerNameX509">The certificate issuer.</param>
''' <param name="serialNumberX509">The certificate serial number.</param>
''' <param name="signatureValue">The hashsed value of the header signature.</param>
''' <param name="digestValue">The hashed value of the header timestamp.</param>
''' <param name="created">The header created date/time.</param>
''' <param name="expires">The header expiration date/tim.</param>
''' <returns>SOAP Header XML.</returns>
Private Function CreateSoapHeaderOnPremise(ByVal url As String, ByVal keyIdentifier As String, ByVal token1 As String, ByVal token2 As String, ByVal issuerNameX509 As String, _
    ByVal serialNumberX509 As String, ByVal signatureValue As String, ByVal digestValue As String, ByVal created As String, ByVal expires As String)
    
    Dim xml As String
    xml = "<s:Header>"
    xml = xml & "<a:Action s:mustUnderstand=""1"">http://schemas.microsoft.com/xrm/2011/Contracts/Services/IOrganizationService/Execute</a:Action>"
    xml = xml & "<a:MessageID>urn:uuid:" & GetGUID() & "</a:MessageID>"
    xml = xml & "<a:ReplyTo>"
    xml = xml & "<a:Address>http://www.w3.org/2005/08/addressing/anonymous</a:Address>"
    xml = xml & "</a:ReplyTo>"
    xml = xml & "<a:To s:mustUnderstand=""1"">" & url & "XRMServices/2011/Organization.svc</a:To>"
    xml = xml & "<o:Security xmlns:o=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<u:Timestamp xmlns:u=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-utility-1.0.xsd"" u:Id=""_0"">"
    xml = xml & "<u:Created>" & created & "</u:Created>"
    xml = xml & "<u:Expires>" & expires & "</u:Expires>"
    xml = xml & "</u:Timestamp>"
    xml = xml & "<xenc:EncryptedData Type=""http://www.w3.org/2001/04/xmlenc#Element"" xmlns:xenc=""http://www.w3.org/2001/04/xmlenc#"">"
    xml = xml & "<xenc:EncryptionMethod Algorithm=""http://www.w3.org/2001/04/xmlenc#aes256-cbc""/>"
    xml = xml & "<KeyInfo xmlns=""http://www.w3.org/2000/09/xmldsig#"">"
    xml = xml & "<e:EncryptedKey xmlns:e=""http://www.w3.org/2001/04/xmlenc#"">"
    xml = xml & "<e:EncryptionMethod Algorithm=""http://www.w3.org/2001/04/xmlenc#rsa-oaep-mgf1p"">"
    xml = xml & "<DigestMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#sha1""/>"
    xml = xml & "</e:EncryptionMethod>"
    xml = xml & "<KeyInfo>"
    xml = xml & "<o:SecurityTokenReference xmlns:o=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<X509Data>"
    xml = xml & "<X509IssuerSerial>"
    xml = xml & "<X509IssuerName>" & issuerNameX509 & "</X509IssuerName>"
    xml = xml & "<X509SerialNumber>" & serialNumberX509 & "</X509SerialNumber>"
    xml = xml & "</X509IssuerSerial>"
    xml = xml & "</X509Data>"
    xml = xml & "</o:SecurityTokenReference>"
    xml = xml & "</KeyInfo>"
    xml = xml & "<e:CipherData>"
    xml = xml & "<e:CipherValue>" & token1 & "</e:CipherValue>"
    xml = xml & "</e:CipherData>"
    xml = xml & "</e:EncryptedKey>"
    xml = xml & "</KeyInfo>"
    xml = xml & "<xenc:CipherData>"
    xml = xml & "<xenc:CipherValue>" & token2 & "</xenc:CipherValue>"
    xml = xml & "</xenc:CipherData>"
    xml = xml & "</xenc:EncryptedData>"
    xml = xml & "<Signature xmlns=""http://www.w3.org/2000/09/xmldsig#"">"
    xml = xml & "<SignedInfo>"
    xml = xml & "<CanonicalizationMethod Algorithm=""http://www.w3.org/2001/10/xml-exc-c14n#""/>"
    xml = xml & "<SignatureMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#hmac-sha1""/>"
    xml = xml & "<Reference URI=""#_0"">"
    xml = xml & "<Transforms>"
    xml = xml & "<Transform Algorithm=""http://www.w3.org/2001/10/xml-exc-c14n#""/>"
    xml = xml & "</Transforms>"
    xml = xml & "<DigestMethod Algorithm=""http://www.w3.org/2000/09/xmldsig#sha1""/>"
    xml = xml & "<DigestValue>" & digestValue & "</DigestValue>"
    xml = xml & "</Reference>"
    xml = xml & "</SignedInfo>"
    xml = xml & "<SignatureValue>" & signatureValue & "</SignatureValue>"
    xml = xml & "<KeyInfo>"
    xml = xml & "<o:SecurityTokenReference xmlns:o=""http://docs.oasis-open.org/wss/2004/01/oasis-200401-wss-wssecurity-secext-1.0.xsd"">"
    xml = xml & "<o:KeyIdentifier ValueType=""http://docs.oasis-open.org/wss/oasis-wss-saml-token-profile-1.0#SAMLAssertionID"">" & keyIdentifier & "</o:KeyIdentifier>"
    xml = xml & "</o:SecurityTokenReference>"
    xml = xml & "</KeyInfo>"
    xml = xml & "</Signature>"
    xml = xml & "</o:Security>"
    xml = xml & "</s:Header>"
    
    CreateSoapHeaderOnPremise = xml
    
End Function

''' <summary>
''' Gets the name of the ADFS server CRM uses for authentication.
''' </summary>
''' <param name="url">The Url of the CRM On Premise (IFD) organization (https://org.domain.com).</param>
''' <returns>The AD FS server url.</returns>
Private Function GetAdfs(ByVal url As String) As String

    url = url & "XrmServices/2011/Organization.svc?wsdl=wsdl0"
    Dim adfsUrl As String
    
    Dim oHttp As Object
    Dim response As New MSXML2.DOMDocument60
    Set response = CreateObject("MSXML2.DOMDocument.6.0")
    
    On Error Resume Next
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    If Err.Number <> 0 Then
        Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
    End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        GetAdfs = Empty
    End If
    
    oHttp.Open "GET", url, False
    oHttp.send
    response.LoadXML oHttp.responseText
    
    Dim adfsUrlNodes As MSXML2.IXMLDOMNodeList
    Set adfsUrlNodes = response.getElementsByTagName("ms-xrm:Identifier")
    
    If adfsUrlNodes.Length = 0 Then
        GetAdfs = Empty
    End If
     
    adfsUrl = adfsUrlNodes(0).text
    adfsUrl = Replace(adfsUrl, "http://", "https://")
    
    Set response = Nothing
    Set oHttp = Nothing

    GetAdfs = adfsUrl
    
End Function

Private Function GetGUID() As String
    GetGUID = Mid$(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
End Function

Private Function EndsWith(str As String, ending As String) As Boolean
     Dim endingLen As Integer
     endingLen = Len(ending)
     EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function

'http://expertland.net/question/nuty4u5q323b54w4z0b62l253z50jr4w2/detail.html

'===============================================================================
' Convert local time to UTC
'===============================================================================
Public Function UTCTIME(local_time As Date) As Date
  Dim oLocalFileTime As FILETIME
  Dim oUtcFileTime As FILETIME
  Dim oSystemTime As SYSTEMTIME

  ' Convert to a SYSTEMTIME
  oSystemTime = DateToSystemTime(local_time)

  ' 1. Convert to a FILETIME
  ' 2. Convert to UTC time
  ' 3. Convert to a SYSTEMTIME
  Call SystemTimeToFileTime(oSystemTime, oLocalFileTime)
  Call LocalFileTimeToFileTime(oLocalFileTime, oUtcFileTime)
  Call FileTimeToSystemTime(oUtcFileTime, oSystemTime)

  ' Convert to a Date
  UTCTIME = SystemTimeToDate(oSystemTime)
End Function

'===============================================================================
' Convert UTC to local time
'===============================================================================
Public Function LOCALTIME(utc_time As Date) As Date
  Dim oLocalFileTime As FILETIME
  Dim oUtcFileTime As FILETIME
  Dim oSystemTime As SYSTEMTIME

  ' Convert to a SYSTEMTIME.
  oSystemTime = DateToSystemTime(utc_time)

  ' 1. Convert to a FILETIME
  ' 2. Convert to local time
  ' 3. Convert to a SYSTEMTIME
  Call SystemTimeToFileTime(oSystemTime, oUtcFileTime)
  Call FileTimeToLocalFileTime(oUtcFileTime, oLocalFileTime)
  Call FileTimeToSystemTime(oLocalFileTime, oSystemTime)

  ' Convert to a Date
  LOCALTIME = SystemTimeToDate(oSystemTime)
End Function

'===============================================================================
' Convert a Date to a SYSTEMTIME
'===============================================================================
Private Function DateToSystemTime(Value As Date) As SYSTEMTIME
  With DateToSystemTime
    .Year = Year(Value)
    .Month = Month(Value)
    .Day = Day(Value)
    .Hour = Hour(Value)
    .Minute = Minute(Value)
    .Second = Second(Value)
  End With
End Function

'===============================================================================
' Convert a SYSTEMTIME to a Date
'===============================================================================
Private Function SystemTimeToDate(Value As SYSTEMTIME) As Date
  With Value
    SystemTimeToDate = _
      DateSerial(.Year, .Month, .Day) + _
      TimeSerial(.Hour, .Minute, .Second)
  End With
End Function

'http://stackoverflow.com/questions/16897645/creating-sha1-hash-and-xml-canonicalization-in-access-vba

Public Function SHA1Base64(ByVal sTextToHash As String)

    Dim asc As Object, enc As Object
    Dim TextToHash() As Byte
    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")
    TextToHash = asc.Getbytes_4(sTextToHash)
    Dim bytes() As Byte
    bytes = enc.ComputeHash_2((TextToHash))
    SHA1Base64 = EncodeBase64(bytes)
    Set asc = Nothing
    Set enc = Nothing

End Function

'http://stackoverflow.com/questions/10068548/base64-hmac-sha1-string-in-vba

Public Function Base64_HMACSHA1(ByVal sTextToHash As String, ByVal sSharedSecretKey As String)
    
    Dim decodedKey() As Byte
    decodedKey = DecodeBase64(sSharedSecretKey)
    Dim asc As Object, enc As Object
    Dim TextToHash() As Byte
    Dim SharedSecretKey() As Byte
    Set asc = CreateObject("System.Text.UTF8Encoding")
    Set enc = CreateObject("System.Security.Cryptography.HMACSHA1")

    TextToHash = asc.Getbytes_4(sTextToHash)
    SharedSecretKey = decodedKey
    enc.Key = SharedSecretKey

    Dim bytes() As Byte
    bytes = enc.ComputeHash_2((TextToHash))
    Base64_HMACSHA1 = EncodeBase64(bytes)
    Set asc = Nothing
    Set enc = Nothing

End Function

Private Function EncodeBase64(ByRef arrData() As Byte) As String

    Dim objXML As MSXML2.DOMDocument60
    Dim objNode As MSXML2.IXMLDOMElement
    
    Set objXML = New MSXML2.DOMDocument60
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

Private Function DecodeBase64(ByVal strData As String) As Byte()
 
    Dim objXML As MSXML2.DOMDocument60
    Dim objNode As MSXML2.IXMLDOMElement
    
    Set objXML = New MSXML2.DOMDocument60
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.text = strData
    DecodeBase64 = objNode.nodeTypedValue
    
    Set objNode = Nothing
    Set objXML = Nothing
 
End Function