這兩天用Excel VBA實(shí)現(xiàn)了登入到網(wǎng)站，提交表單并將搜索結(jié)果寫(xiě)回Excel的功能。在寫(xiě)回結(jié)果之前同事顯示滾動(dòng)的進(jìn)度條。
在Excel VBE界面,需要在reference中加入以下3個(gè)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


效果圖如下:
[img]http://joeykh.iteye.com/upload/picture/pic/38524/76c699ed-477a-311d-a216-f207a250e234.gif[/img]

關(guān)于滾動(dòng)進(jìn)度條的制作可參考
http://www.cnblogs.com/jinliangliu/archive/2006/07/15/451314.html

之前沒(méi)玩過(guò)VB,覺(jué)得還挺有意思的。最后制成的Excel在附件中。

總結(jié)

以上是生活随笔為你收集整理的Excel VBA操作网页 显示滚动进度条的全部?jī)?nèi)容，希望文章能夠幫你解決所遇到的問(wèn)題。

如果覺(jué)得生活随笔網(wǎng)站內(nèi)容還不錯(cuò)，歡迎將生活随笔推薦給好友。