使用vbXMLRPC组件访问xmlrpc接口

<iframe align="top" marginwidth="0" marginheight="0" src="http://www.zealware.com/csdnblog01.html" frameborder="0" width="728" scrolling="no" height="90"></iframe>

这是最简单的一个helloworld的调用。xmlrpc服务器端的代码在前一个blog中。用perl写的。主要是为了测试不同语言的兼容性。

Private Sub Command1_Click()
Dim linsRequest As New XMLRPCRequest
Dim linsResponse As XMLRPCResponse
Dim linsUtility As New XMLRPCUtility
Dim linsValue As XMLRPCValue
Dim linsMember As XMLRPCMember
Dim llngChanId As Long
Dim lstrChanTitle As String

Me.MousePointer = vbHourglass

linsRequest.HostName = "202.195.160.145"
linsRequest.HostPort = 80
linsRequest.HostURI = "/webmin-rpc/xmlrpc.cgi"

linsRequest.MethodName = "World.HelloWorld"

Set linsResponse = linsRequest.Submit

Select Case linsResponse.Status
Case XMLRPC_PARAMSRETURNED
If linsResponse.Params.Count = 1 Then
If linsResponse.Params(1).ValueType = XMLRPC_STRING Then
Label1.Caption = linsResponse.Params(1).StringValue
Else
BugOut "Expecting a datetime to be returned instead received a '" & linsUtility.GetXMLRPCType(linsResponse.Params(1).ValueType) & "'."
End If
Else
BugOut "Expecting one return parameter, received '" & linsResponse.Params.Count & "'."
End If
Case XMLRPC_FAULTRETURNED
BugOut "Server returned a fault. Code is '" & linsResponse.Fault.faultCode & "', description is '" & linsResponse.Fault.faultString & "'."
Case XMLRPC_HTTPERROR
BugOut "HTTP error encountered. Code is '" & linsResponse.HTTPStatusCode & "', description is '" & linsUtility.GetHTTPError(linsResponse.HTTPStatusCode) & "'."
Case XMLRPC_XMLPARSERERROR
BugOut "XML Parsing Error encountered '" & linsResponse.XMLParseError & "'."
Case XMLRPC_NOTINITIALISED
BugOut "Weird, the response claims not to be initialised !!!"
Case Else
BugOut "Double Weird, unknown response status '" & linsResponse.Status & "'."
End Select

Me.MousePointer = vbDefault

End Sub

Private Sub BugOut(ByVal vstrError As String)
MsgBox vstrError, vbOKOnly + vbCritical, App.Title
End Sub

Trackback: http://tb.blog.csdn.net/TrackBack.aspx?PostId=477823