Lewies Blog

    1 ‘ Variables that may help to identify the end-user
    2 ‘Debug.Print Environ(”USERNAME”)
    3 ‘Debug.Print Environ(”USERDOMAIN”)
    4 ‘Debug.Print Environ(”USERDNSDOMAIN”)
    5 ‘Debug.Print Environ(”COMPUTERNAME”)
    6 ‘Debug.Print Application.ProductCode
    7 
    8 Private WebClient As Object
    9 Private m_ActiveXPrefix As String
   10 Private m_ParameterNames() As String
   11 Private m_ParameterValues() As String
   12 Private m_MethodName As String
   13 Private m_XmlNamespace As String
   14 Private m_OnReadystateChange As String
   15 Private m_ParameterCount As Integer
   16 Private m_EndPoint As String
   17 
   18 Private Property Get ActiveXPrefix() As String
   19 If Not m_ActiveXPrefix = “” Then
   20 ActiveXPrefix = m_ActiveXPrefix
   21 Exit Property
   22 End If
   23 Dim Prefixes(4) As String
   24 Prefixes(0) = “Microsoft”
   25 Prefixes(1) = “MSXML”
   26 Prefixes(2) = “MSXML2″
   27 Prefixes(3) = “MSXML3″
   28 Dim test As Object
   29 On Error Resume Next
   30 For Each Prefix In Prefixes
   31 Set test = CreateObject(Prefix & “.XmlHttp”)
   32 If Not Err Then
   33 Set test = CreateObject(Prefix & “.XmlDom”)
   34 If Not Err Then
   35 m_ActiveXPrefix = Prefix
   36 ActiveXPrefix = Prefix
   37 Exit Property
   38 End If
   39 End If
   40 Err.Clear
   41 Next
   42 End Property
   43 
   44 Private Property Get ParameterIndex(name As String) As Integer
   45 For i = 0 To m_ParameterCount
   46 If m_ParameterNames(i) = name Then
   47 ParameterIndex = i
   48 Exit Property
   49 End If
   50 Next
   51 ParameterIndex = -1
   52 End Property
   53 
   54 Public Property Let Parameter(name As String, Value As String)
   55 Dim i As Integer
   56 i = ParameterIndex(name)
   57 If i = -1 Then
   58 AddParameter name, Value
   59 Else
   60 m_ParameterValues(i) = Value
   61 End If
   62 End Property
   63 
   64 Public Property Get Parameter(name As String) As String
   65 Dim i As Integer
   66 i = ParameterIndex(name)
   67 If i = -1 Then
   68 Parameter = “”
   69 Else
   70 Parameter = m_ParameterValues(i)
   71 End If
   72 End Property
   73 
   74 Public Sub AddParameter(name As String, Value As String)
   75 Dim i As Integer
   76 i = m_ParameterCount
   77 m_ParameterCount = m_ParameterCount + 1
   78 ReDim Preserve m_ParameterNames(m_ParameterCount)
   79 ReDim Preserve m_ParameterValues(m_ParameterCount)
   80 m_ParameterNames(i) = name
   81 m_ParameterValues(i) = Value
   82 End Sub
   83 
   84 Public Sub ClearParameters()
   85 ReDim m_ParameterNames(0)
   86 ReDim m_ParameterValues(0)
   87 m_ParameterCount = 0
   88 End Sub
   89 
   90 Public Property Get MethodName() As String
   91 MethodName = m_MethodName
   92 End Property
   93 
   94 Public Property Let MethodName(name As String)
   95 m_MethodName = name
   96 End Property
   97 
   98 Public Property Let XmlNamespace(uri As String)
   99 m_XmlNamespace = uri
  100 End Property
  101 
  102 Public Property Get XmlNamespace() As String
  103 XmlNamespace = m_XmlNamespace
  104 End Property
  105 
  106 Public Property Let OnReadystateChange(Method As String)
  107 m_OnReadystateChange = Method
  108 End Property
  109 
  110 Public Property Get OnReadystateChange() As String
  111 OnReadystateChange = m_OnReadystateChange
  112 End Property
  113 
  114 Public Property Get EndPoint() As String
  115 EndPoint = m_EndPoint
  116 End Property
  117 
  118 Public Property Let EndPoint(uri As String)
  119 m_EndPoint = uri
  120 End Property
  121 
  122 Public Function Query(Optional Asynch As Boolean = False) As Object
  123 Dim Envelope As Object
  124 Set Envelope = CreateEnvelope()
  125 WebClient.Open “POST”, Me.EndPoint, Asynch
  126 WebClient.setRequestHeader “SOAPAction”, “”"” & Me.XmlNamespace & Me.MethodName & “”"”
  127 WebClient.setRequestHeader “Content-Type”, “text/xml; charset=utf-8″
  128 WebClient.setRequestHeader “Content-Length”, CStr(Len(Envelope.xml))
  129 ‘Debug.Print Envelope.xml
  130 On Error GoTo ErrorTrap
  131 WebClient.send Envelope.xml
  132 On Error GoTo 0
  133 If Asynch Then
  134 While Not WebClient.readyState = 4
  135 DoEvents
  136 Wend
  137 End If
  138 ‘Debug.Print WebClient.ResponseText
  139 If Envelope.loadXML(WebClient.ResponseText) Then
  140 If Envelope.LastChild.FirstChild.FirstChild.nodeName = “soap:Fault” Then
  141 MsgBox “An error occured while communicating with the server.”
  142 Debug.Print Envelope.LastChild.FirstChild.FirstChild.FirstChild.nextSibling.text
  143 GoTo Reset
  144 End If
  145 Envelope.loadXML Envelope.LastChild.FirstChild.FirstChild.FirstChild.xml
  146 Set Query = Envelope
  147 End If
  148 GoTo Reset
  149 ErrorTrap:
  150 MsgBox Err.Description
  151 Reset:
  152 Me.ClearParameters
  153 End Function
  154 
  155 Private Function CreateEnvelope() As Object
  156 Dim Soap As Object
  157 Dim Envelope As Object
  158 Dim Body As Object
  159 Dim Method As Object
  160 Dim ParameterNode As Object
  161 Set Soap = CreateObject(ActiveXPrefix & “.XmlDom”)
  162 Soap.async = False
  163 Soap.appendChild (Soap.createProcessingInstruction(“xml”, “version=”"1.0″” encoding=”"utf-8″”"))
  164 Set Envelope = Soap.createElement(“soap:Envelope”)
  165 Envelope.setAttribute “xmlns:xsi”, “http://www.w3.org/2001/XMLSchema-instance”
  166 Envelope.setAttribute “xmlns:xsd”, “http://www.w3.org/2001/XMLSchema”
  167 Envelope.setAttribute “xmlns:soap”, “http://schemas.xmlsoap.org/soap/envelope/”
  168 Soap.appendChild Envelope
  169 Set Body = Soap.createElement(“soap:Body”)
  170 Envelope.appendChild Body
  171 Set Method = Soap.createElement(Me.MethodName)
  172 Body.appendChild Method
  173 Method.setAttribute “xmlns”, Me.XmlNamespace
  174 For i = 0 To m_ParameterCount - 1
  175 Set ParameterNode = Soap.createElement(m_ParameterNames(i))
  176 ParameterNode.text = m_ParameterValues(i)
  177 Method.appendChild ParameterNode
  178 Next
  179 Set CreateEnvelope = Soap
  180 End Function
  181 
  182 Private Sub Class_Initialize()
  183 Set WebClient = CreateObject(ActiveXPrefix & “.XmlHttp”)
  184 Me.ClearParameters
  185 End Sub
  186 
  187 Private Sub Class_Terminate()
  188 Set WebClient = Nothing
  189 End Sub