Anywhere you go, let me go too

關於部落格
對人海闊天空,做事仔細周密
----------------------
因為改了平台後...覺得不是很好用....所以有另外......(評估中)
http://blog.xuite.net/king119wang/myskills
  • 32543

    累積人氣

  • 2

    今日人氣

    0

    訂閱人氣

用EXCEL2010寫VBS抓取XML訊息方法

 再來就是要建立你想開發的巨集
點選[巨集] --> [編輯] 就可以進入程式編輯畫面

 
接下來就可開始寫程式囉!
Sub CatchFxData()
'
' CatchFxData 巨集
'
' 快速鍵: Ctrl+Shift+F
'
  sRemoteUrl = "https://192.168.211.41/xmlgw/Ap2ApServlet"   ==>  你要去抓資料的URL
  
  webServerStatus = -1
 
   Set http = CreateObject("Msxml2.ServerXMLHTTP")
   Set objXML = CreateObject("Microsoft.FreeThreadedXMLDOM")
   objXML.preserveWhiteSpace = -1
 
                  
                             
                'http.setTimeouts 5000,5000,8000,8000
                
                http.Open "POST", sRemoteUrl, False     -----> 以post傳送
                
            '待上傳的上行電文   
                sTitaXML = "<?xml version='1.0' encoding='UTF-8'?><SvcRq><PrInqRq><MSGID>TEST</MSGID><CUST_ID>123456</CUST_ID><TYPE>101</TYPE></PrInqRq></SvcRq>"
                
                http.Send sTitaXML  ===>送出上行電文
 
                  'MsgBox "err.number=" & Err.Number
                  'MsgBox "Err.Description=" & Err.Description
                  'MsgBox "Err.HelpContext=" & Err.HelpContext   ===>DEBUG
            
                If (http.Status <> 200) And (Err.Number <> 0) Then
                
                   MsgBox Err.Number & Err.Description
                
                Else
                    
                    WebResult = http.responseText   ===>接收SERVER回傳的電文
                            
                    If InStr(WebResult, "Error") > 0 Then
                         MsgBox "取匯率資料發生異常!!"
                    Else                    
                    
                          '拆XML訊息
                       
                          objXML.LoadXML (WebResult)    ===>LOAD XML訊息
                          'MsgBox objXML.XML
                          
                            If objXML.parseError.ErrorCode <> 0 Then
                                 Response.write "<p>Parse Error Reason: " & objXML.parseError.reason & "</p>"
                            Else
                                                                                    
                                
                                returnCode = objXML.SelectSingleNode("//SvcRs/PrInqRs/ERRCODE").Text
                            
                               
                                If returnCode = 0 Then
                                
                                    Set NodeList = objXML.getElementsByTagName("QryRs")  ===> 因為VBS有些METHOD,這個取NodeList是找G博士問....一定要這樣子取 Tag Name 就是Node Name囉!
                                      
                                    iTotalCurrCount = NodeList.Length
                                    Dim aryCurr
                                    ReDim aryCurr(iTotalCurrCount, 8)  ==> 一定要像這樣定兩次, 不能直接用Dim定一一個非常數的陣列
                                    
                               '拆xml訊息入陣列中
                                    For Each ParentNode In NodeList
                                        For Each Node In ParentNode.ChildNodes
                                             aryCurr(i, j) = Node.Text   '資料存入陣列中
                                             j = j + 1
                                        Next
                                        
                                        j = 0
                                        i = i + 1
                                    Next
                                    
                                   
                                    Dim aryRealCurrRate
                                    ReDim aryRealCurrRate(i / 4, 6)
                                    
                                    Dim CurrCode, CurrName, Price1, Priec2, Price3, Price4
                                    
                                    
                                    '進行取值入Excel Sheet中
                                     iRow = 0
                                    
                                     For iHead = 0 To i
                                     
                                        If iHead = 0 Then
                                            Sheet20.Cells(5, 1) = "幣別"
                                            Sheet20.Cells(5, 2) = "即期買匯"
                                            Sheet20.Cells(5, 3) = "現金買匯"
                                            Sheet20.Cells(5, 4) = "即期賣匯"
                                            Sheet20.Cells(5, 5) = "現金賣匯"
                                        End If
                                        
                                      
                                        CurrName = aryCurr(iHead, 0)
                                        CurrCode = aryCurr(iHead, 6)
                                       
                                        Select Case aryCurr(iHead, 2)
                                           Case "01"
                                              Price1 = aryCurr(iHead, 5)
                                           Case "02"
                                              Price2 = aryCurr(iHead, 5)
                                           Case "03"
                                              Price3 = aryCurr(iHead, 5)
                                           Case "04"
                                              Price4 = aryCurr(iHead, 5)
                                              
                                              iRow = iRow + 1
                                              
                                              CellRow = 5 + iRow
                                              '將取出的值,直接指定到特定Sheet 特定欄位中
                                              Sheet20.Cells(CellRow, 1) = CurrCode + CurrName
                                              Sheet20.Cells(CellRow, 2) = Price1
                                              Sheet20.Cells(CellRow, 3) = Price2
                                              Sheet20.Cells(CellRow, 4) = Price3
                                              Sheet20.Cells(CellRow, 5) = Price4
                                        End Select
                                      
                                     Next
                                     
                                     
                                     i = 0
                                    
                                End If 'End 判斷XML 回傳return Code=0
                            End If ' End 判斷XML objXML.parseError=0
                          
                          webServerStatus = 0
                          iCount = 0
                          End
                  End If
                 
                End If
                  
End Sub
=============
如何另外用button去點選執行巨集??
Button按右鍵可以異動Button顯示名程,同時選擇[指定巨集]就可以去選擇您剛才寫好的巨集
結果顯示如下

這樣就大功告成了. 有了匯率就可以去計算自己的外幣投資報酬了:D

加油~

相簿設定
標籤設定
相簿狀態