vba操作模板

vba http post方法

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        Dim url As String
        Dim str As String
        url = "http://192.168.7.204:8043/Api/Service/Calculate"
        str = "{i_code:010007,m_type:X_CNBD,a_type:SPT_BD,SENDER_ID:1,Number:1,HS_DATE:2018/12/4 0:00:00}"
        Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
        http.Open "POST", url, False
        http.setrequestheader "Content-Type", "application/json"
        http.setrequestheader "Content-Length", Len(str)
        http.send (str)
        If http.waitforresponse() Then
            Dim s As String
            s = http.responsetext
MsgBox (s)
        Else: MsgBox ("失败")
        End If
End Sub

webservice方法
需要下载soaptoolit3.0包

   Dim resposeText As String

   Dim uri As String
   uri = "http://192.168.7.204:8090/service.asmx?wsdl"
   Dim m_spClient As New SoapClient30 'SoapClient30对象实例化
   m_spClient.MSSoapInit uri '引用webservice
   '调用方法 processXeqMsg 参数 para
   resposeText = m_spClient.processXeqMsg(para)

http也可以接webservice

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RowNumber As Integer
Dim ColumnNumber As Integer
RowNumber = Target.Row
ColumnNumber = Target.Column
Dim i_code As String
Dim m_type As String
Dim a_type As String
Dim SENDER_ID As String
Dim ORDDATE As String
Dim HSDATE As String
If ColumnNumber = 18 Then
SENDER_ID = "0"
ElseIf ColumnNumber = 19 Then
SENDER_ID = "2"
ElseIf ColumnNumber = 21 Then
SENDER_ID = "1"
ElseIf ColumnNumber = 22 Then
SENDER_ID = "4"
Else
Exit Sub
End If
i_code = Cells(RowNumber, "N").Value
m_type = Cells(RowNumber, "J").Text
a_type = Cells(RowNumber, "K").Text
ORDDATE = Cells(RowNumber, "L").Text
HSDATE = Cells(RowNumber, "F").Text

getDatas RowNumber, i_code, m_type, a_type, SENDER_ID, Target, HSDATE, ORDDATE
End Sub

正式代码

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_Handle
Dim RowNumber As Integer
Dim ColumnNumber As Integer
RowNumber = Target.Row
ColumnNumber = Target.Column
Dim i_code As String
Dim m_type As String
Dim SENDER_ID As String
Dim ORDDATE As String
Dim HSDATE As String
If ColumnNumber = 18 Then
SENDER_ID = "0"
ElseIf ColumnNumber = 19 Then
SENDER_ID = "2"
ElseIf ColumnNumber = 21 Then
SENDER_ID = "1"
ElseIf ColumnNumber = 22 Then
SENDER_ID = "4"
Else
Exit Sub
End If
i_code = Cells(RowNumber, "N").Value
m_type = Cells(RowNumber, "J").Text
ORDDATE = Cells(RowNumber, "L").Text
HSDATE = Cells(RowNumber, "F").Text
If m_type = "上交所" Then
m_type = "XSHG"
ElseIf m_type = "深交所" Then
m_type = "XSHE"
ElseIf m_type = "银行间" Then
m_type = "X_CNBD"
End If

If i_code = "" Then
MsgBox "缺少债券代码,无法反算"
Exit Sub
End If

If m_type = "" Then
MsgBox "缺少交易市场,无法反算"
Exit Sub
End If

If HSDATE = "" Then
MsgBox "缺少核算日期,无法反算"
Exit Sub
End If

If ORDDATE = "" Then
MsgBox "缺少交易日期,无法反算"
Exit Sub
End If

getDatas RowNumber, i_code, m_type, "SPT_BD", SENDER_ID, Target, HSDATE, ORDDATE
Exit Sub
Err_Handle:
     Application.EnableEvents = True
     MsgBox Err.Description
End Sub


Sub getDatas(ByVal Row As String, ByVal i_code As String, ByVal m_type As String, ByVal a_type As String, ByVal SENDER_ID As String, ByVal Number As String, ByVal HS_DATE As String, ByVal ORDDATE As String)
        Dim url As String
        Dim Result As String
        url = "http://192.168.7.204:8090/service.asmx/CalculateOfTradeElements?i_code=" + i_code + "&m_type=" + m_type + "&a_type=" + a_type + "&SENDER_ID=" + SENDER_ID + "&Number=" + Number + "&HS_DATE=" + HS_DATE + "&ORDDATE=" + ORDDATE
        Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
        http.Open "GET", url, False
        http.setRequestHeader "Content-Type", "text/xml"
        http.send
        If http.waitforresponse() Then
            Result = http.responseText
        Else: MsgBox ("失败")
            Exit Sub
        End If
        Result = Replace(Result, "&acute;", Chr(39)) '替换单引号

        Result = Replace(Result, "&quot;", Chr(34))    '替换双引号

        Result = Replace(Result, "&lt;", "<")    '替换<

        Result = Replace(Result, "&gt;", ">")    '替换>

        Result = Replace(Result, "<br>", Chr(13)) '替换回车符

        Result = Replace(Result, "&nbsp;", Chr(32)) '替换空格符

        Result = Replace(Result, "&nbsp; &nbsp; &nbsp; &nbsp;", Chr(9)) '替换tab符

        Dim XMLDoc As New MSXML2.DOMDocument
        Dim NETPRICE As MSXML2.IXMLDOMNode
        Dim YTM_PERCENT As MSXML2.IXMLDOMNode
        Dim FULLPRICE As MSXML2.IXMLDOMNode
        Dim ORDAMOUNT As MSXML2.IXMLDOMNode
        Dim MtrDateYTM_PERCENT As MSXML2.IXMLDOMNode
        Dim RC As MSXML2.IXMLDOMNode
        Dim RM As MSXML2.IXMLDOMNode
        XMLDoc.loadXML (Result)

        Set RC = XMLDoc.selectSingleNode("//RE/RC")
        Set RM = XMLDoc.selectSingleNode("//RE/RM")
        If RC.Text = "-1" Then
        MsgBox RM.Text
        Exit Sub
        End If


        Set NETPRICE = XMLDoc.selectSingleNode("//Result/NETPRICE")
        Set YTM_PERCENT = XMLDoc.selectSingleNode("//Result/YTM_PERCENT")
        Set FULLPRICE = XMLDoc.selectSingleNode("//Result/FULLPRICE")
        Set ORDAMOUNT = XMLDoc.selectSingleNode("//Result/ORDAMOUNT")
        Set MtrDateYTM_PERCENT = XMLDoc.selectSingleNode("//Result/MtrDateYTM_PERCENT")
        Application.EnableEvents = False
        Range("R" + Row).Value = NETPRICE.Text
        Range("S" + Row).Value = FULLPRICE.Text
        Range("U" + Row).Value = YTM_PERCENT.Text / 100
        Range("V" + Row).Value = MtrDateYTM_PERCENT.Text / 100
        Application.EnableEvents = True

        Set NETPRICE = Nothing
        Set YTM_PERCENT = Nothing
        Set FULLPRICE = Nothing
        Set ORDAMOUNT = Nothing
        Set MtrDateYTM_PERCENT = Nothing

End Sub

vba http post方法

发表评论