Listing 4 Excel VBA-Client

Dim error As Integer
Dim mintIndex As Integer
Dim mstrProjectlist As String

Private Sub Init()
    mstrProjectlist = "Projectlist"
    mintIndex = 1
    Worksheets(mstrProjectlist).Columns("A:Z").ClearContents
    Worksheets(mstrProjectlist).Range("A" & mintIndex).Value = "Project-Nr."
    Worksheets(mstrProjectlist).Range("B" & mintIndex).Value = "Title"
    Worksheets(mstrProjectlist).Range("C" & mintIndex).Value = "Type"
    Worksheets(mstrProjectlist).Range("D" & mintIndex).Value = "Division"
    Worksheets(mstrProjectlist).Range("E" & mintIndex).Value = "Process"
    Worksheets(mstrProjectlist).Range("F" & mintIndex).Value = "Projectleader"
    Worksheets(mstrProjectlist).Range("G" & mintIndex).Value = "Methode of Finance"
    Worksheets(mstrProjectlist).Range("H" & mintIndex).Value = "State"
    mintIndex = mintIndex + 1
End Sub

Private Sub DoXMLRequest(ByVal lstrUserID As String, ByVal lstrPassword As String)
    '
    ' vbXMLRPC
    '
    Dim linsRequest As New XMLRPCRequest
    Dim linsResponse As XMLRPCResponse
    Dim linsMember As XMLRPCMember
    Dim lstrResult As String
    Dim linsValue As XMLRPCValue
    Dim lintIndex As Integer
    
    '
    ' initialize
    '
    error = 0
    
    '
    ' call XMLRPC Server
    '
    Set linsResponse = CallXMLRPCServer(lstrUserID, lstrPassword)
    
    '
    ' process response
    '
    If error = 0 Then
        lintIndex = mintIndex
        For Each linsValue In linsResponse.params(1).ArrayValue
            If linsValue.ValueType <> XMLRPC_STRUCT Then
              MsgBox "Unexpected response from XML-RPC request " & linsUtility.GetXMLRPCType(linsResponse.params(1).ValueType) & " returned, expecting a struct"
            End If
            For Each linsMember In linsValue.StructValue
                If linsMember.Name = "projectnr" Then
                    Worksheets(mstrProjectlist).Range("A" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "name" Then
                    Worksheets(mstrProjectlist).Range("B" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "projecttype" Then
                    Worksheets(mstrProjectlist).Range("C" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "division" Then
                    Worksheets(mstrProjectlist).Range("D" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "process" Then
                    Worksheets(mstrProjectlist).Range("E" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "projectleader" Then
                    Worksheets(mstrProjectlist).Range("F" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "methodfinance" Then
                    Worksheets(mstrProjectlist).Range("G" & lintIndex).Value = linsMember.Value.StringValue
                End If
                If linsMember.Name = "review_state" Then
                    Worksheets(mstrProjectlist).Range("H" & lintIndex).Value = linsMember.Value.StringValue
                End If
            Next linsMember
            lintIndex = lintIndex + 1
        Next linsValue
    End If
End Sub

Private Function CallXMLRPCServer(ByVal lstrUserID As String, ByVal lstrPassword As String) As XMLRPCResponse
    Dim linsRequest As New XMLRPCRequest
    Dim linsResponse As XMLRPCResponse
    Dim linsUtility As New XMLRPCUtility
    
    On Error GoTo XMLRPCError

    linsRequest.HostName = "test.fhso.ch"
    linsRequest.HostPort = 80
    linsRequest.HostURI = "/xmlrpc"
    linsRequest.BasicAuthFlag = True
    linsRequest.Password = lstrPassword
    linsRequest.UserID = lstrUserID
    linsRequest.MethodName = "getProjects"
    
    Set linsResponse = linsRequest.Submit
    
    '
    ' test response before returning it to the caller
    '
    If linsResponse.Status = XMLRPC_FAULTRETURNED Then
        MsgBox linsResponse.Fault.faultString
        error = -1
    ElseIf linsResponse.Status <> XMLRPC_PARAMSRETURNED Then
        MsgBox "Unexpected response from XML-RPC request " & linsResponse.Status
        error = -1
    ElseIf linsResponse.params.Count <> 1 Then
        MsgBox "Unexpected response from XML-RPC request " & linsResponse.params.Count & " return parameters, expecting 1"
        error = -1
    ElseIf linsResponse.params(1).ValueType <> XMLRPC_ARRAY Then
        MsgBox "Unexpected response from XML-RPC request " & linsUtility.GetXMLRPCType(linsResponse.params(1).ValueType) & " returned, expecting an array"
        error = -1
    End If
    
    Set CallXMLRPCServer = linsResponse

XMLRPCError:
    If Err.Number <> 0 Then
        MsgBox "Error " & Err.Description
        Err.Clear
        error = -1
    End If
End Function

Private Sub OK_Click()
    Me.Hide
    Init
    'change the cursor to hourglass
    Application.Cursor = xlWait
    ' makes sure that the statusbar is visible
    Application.DisplayStatusBar = True
    'add your message to status bar
    Application.StatusBar = "Please wait while datas are downloaded from server..."
    
    DoXMLRequest TextUserID, TextPassword
    
    'restore default cursor
    Application.Cursor = xlDefault
    ' gives control of the statusbar back to the programme
    Application.StatusBar = False
    
    Worksheets(mstrProjectlist).Select
End Sub