Excel VBA操作网页 显示滚动进度条

    这两天用Excel VBA实现了登入到网站，提交表单并将搜索结果写回Excel的功能。在写回结果之前同事显示滚动的进度条。
    在Excel VBE界面,需要在reference中加入以下3个library
    Microsoft Internet Controls
    Microsoft HTML Object Library
    Microsoft ActiveX Data Objects 2.8 Library
    VBA代码如下:

Sub GoogleSearch()
    'This project includes references to "Microsoft Internet Controls" and
    '"Microsoft HTML Object Library" and
    '"Microsoft ActiveX Data Objects 2.8 Library"
    
    'Variable declarations
    Dim myIE As New InternetExplorer 'New '
    Dim myURL As String
    Dim myDoc As HTMLDocument
    Dim strUsername As String
    Dim strPassword As String
    Dim strKw As String
    Dim strHtml As String
    
    'Show process bar
    'ShowProcessBar
    BeginProgress
        
    'Set starting URL and login string
    Sheets("SearchForm").Select
    myURL = Range("B1").Value
    strUsername = Range("B2").Value
    strPassword = Range("B3").Value
    strSearch = Range("B5").Value
    
    'Make IE navigate to the URL and make browser visible
    myIE.navigate myURL
    'myIE.Visible = True
    
    'Wait for the page to load
    Do While myIE.Busy Or myIE.readyState <> READYSTATE_COMPLETE
    PushProgress (1)
    DoEvents
    Loop
    
    'Set IE document into object
    Set myDoc = myIE.document
    
    'Enter search string on form
    myDoc.forms(0).q.Value = strSearch
    
    'Submit form
    myDoc.f.submit
    
    'Wait for the page to load
    Do While myIE.Busy Or myIE.readyState <> READYSTATE_COMPLETE
    PushProgress (1)
    DoEvents
    Loop
    
   'Save html content to file and then copy data to Excel sheet
    strHtml = myDoc.documentElement.outerHTML
    
    'Save html
    strFileUrl = ThisWorkbook.Path & "/searchResults.html"
    WriteStrToFile strHtml, strFileUrl, "UTF-8"
    
    'Copy data from html file
    Workbooks.Open strFileUrl
    Selection.UnMerge
    Range("A1:L80").Select
    HtmlContentValue = Range("A1:L80").Value
    ActiveWorkbook.Close (False)
    ThisWorkbook.Activate
    Sheets("ResultsReports").Select
    Range("A1:L80").Value = HtmlContentValue
    Selection.UnMerge
    Range("A1:L80").Select

    'MsgBox "End Search" 'myIE.LocationName
    'Normally exit
    'End progress bar
    Sheets("SearchForm").Select
    EndProgress
    Sheets("ResultsReports").Select
    myIE.Quit
    Set myIE = Nothing

End Sub

Private Sub WriteStrToFile(ByVal strText As String, ByVal strPath As String, ByVal strCharSet As String)
    'Dim objText          As New FileSystemObject
    'Please add reference: Microsoft ActiveX Data Objects 2.8 Library
    Dim objText         As New ADODB.Stream
    
    objText.Type = adTypeText
    objText.Open
    objText.Charset = strCharSet
    objText.WriteText strText, adWriteChar
    objText.SaveToFile strPath, adSaveCreateOverWrite
    objText.Close
    Set objText = Nothing
    
End Sub

Private Sub BeginProgress()
    Range("C6").Value = 0
    Range("D6").Value = 10000
    'For j = 1 To Range("D6").Value
    '   Range("C6").Value = j
    'Next j
End Sub

Private Sub PushProgress(ByVal pushValue As Integer)
    Range("C6").Value = Range("C6").Value + pushValue
    If (Range("C6").Value = 9999) Then
      Range("C6").Value = 0
    End If
End Sub

Private Sub EndProgress()
    Range("C6").Value = 10000
    Range("D6").Value = 10000
    'For j = 1 To Range("D6").Value
    '   Range("C6").Value = j
    'Next j
End Sub    

效果图如下:


关于滚动进度条的制作可参考
http://www.cnblogs.com/jinliangliu/archive/2006/07/15/451314.html

之前没玩过VB,觉得还挺有意思的。最后制成的Excel在附件中。