因为工作的原因，需要实时获取当日的银行汇率，以前一直是通过打开网页复制获得数据，现在用access数据库制做了一个从中国银行网站上采集汇率的示例，感觉方便了很多。本示例的下载请点击屏幕左下角的“阅讯原文”，供大家参考！

代   码:

Sub 汇率采集()
    Dim url As String
    Dim hmlFile As Object
    Dim arr() As Variant
    Dim r As Variant
    Dim I As Integer
    Dim j As Integer
    Dim m As Integer
    Dim SQL1 As String
    Dim rst1 As New ADODB.Recordset
    CurrentDb.Execute "delete * from 中国银行汇率"
    url = "http://www.boc.cn/sourcedb/whpj"
    With CreateObject("microsoft.xmlhttp")
        .Open "GET", url, False
        .Send
        Do Until .ReadyState = 4
            DoEvents
        Loop
        Set hmlFile = CreateObject("htmlfile")
        hmlFile.body.innerhtml = .responsetext
    End With
    Set r = hmlFile.ALL.tags("table")(1).Rows
    ReDim arr(r.Length - 1, r(0).Cells.Length - 1)
    For I = 0 To UBound(arr)
        For j = 0 To UBound(arr, 2)
            arr(I, j) = r(I).Cells(j).innertext
        Next
    Next
    SQL1 = "select * from 中国银行汇率"
    rst1.Open SQL1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    On Error Resume Next
    For m = 1 To UBound(arr)
        rst1.AddNew
        rst1!货币名称 = arr(m, 0)
        If arr(m, 1) <> "" Then rst1!现汇买入价 = arr(m, 1) Else rst1!现汇买入价 = 0
        If arr(m, 2) <> "" Then rst1!现汇卖出价 = arr(m, 2) Else rst1!现汇卖出价 = 0
        rst1!现钞买入价 = arr(m, 3)
        rst1!中行折算价 = arr(m, 4)
        rst1!现钞卖出价 = arr(m, 5)
        rst1!发布日期 = arr(m, 6)
        rst1!发布时间 = arr(m, 7)
        rst1.Update
    Next
    Set hmlFile = Nothing
    Set rst1 = Nothing
End Sub

附   件:

点击下载此附件

图   示: