网页输入内容自动填写：参考excel

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim j As Integer

Dim ex As Object

Dim wb As Object

Dim sh As Object

Dim objDoc

Dim endi As Integer

Dim k As Integer

Private i As Integer

Private si As String

Private Sub Form_Load()

WebBrowser1.Width = Screen.Width

WebBrowser1.Height = Screen.Height - 500

i = 1

Set ex = CreateObject("Excel.Application")

 

Set wb = ex.Workbooks.Open(App.Path & "\1.xls")

Set sh = wb.Sheets(4)

If sh.Cells(1, 1) <> 4 Then

          wb.Close True

            ex.Quit

            Set sh = Nothing

             Set wb = Nothing

             Set ex = Nothing

        Unload Me

        End

Else:

 

Set sh = wb.Sheets(1)

endi = sh.UsedRange.Rows.Count

WebBrowser1.Navigate "http://148.36.20.220:86/"

End If

End Sub

 

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)

If WebBrowser1.LocationURL = "http://148.36.20.220:86/" Then

  

     

    If i > endi Then

     

            wb.Close True

            ex.Quit

            Set sh = Nothing

             Set wb = Nothing

         

                Set ex = Nothing

        Unload Me

        End

      Else:

     WebBrowser1.Document.Forms(0).TextBox1.Value = sh.Cells(i, 1)

       WebBrowser1.Document.Forms(0).TextBox2.Value = sh.Cells(i, 2)

       j = (Int(Rnd * 10) + 3) * 1000

       Sleep j

       DoEvents

       WebBrowser1.Document.Forms(0).Button1.Click

       i = i + 1

        End If

 End If

  

 If WebBrowser1.LocationURL = "http://148.36.20.220:86/qd.aspx" Then

  Dim s As Variant

  s = pDisp.Document.documentElement.outerHTML

  If InStr(s, "上午请签到") > 0 Then

     j = (Int(Rnd * 10) + 5) * 1000

       Sleep j

       DoEvents

       On Error Resume Next

    Set objDoc = WebBrowser1.Document

    For k = 0 To objDoc.All.Length - 1

    If objDoc.All(k).Name = "ImageButton1" Then

            objDoc.All(k).Click

        

        End If

        

    Next

     WebBrowser1.Navigate "http://148.36.20.220:86/"

 ' WebBrowser1.Document.Forms(0).ImageButton1.Click

  ElseIf InStr(s, "下午请签到") > 0 Then

     j = (Int(Rnd * 10) + 5) * 1000

       Sleep j

       DoEvents

        On Error Resume Next

    Set objDoc = WebBrowser1.Document

    For k = 0 To objDoc.All.Length - 1

    If objDoc.All(k).Name = "ImageButton2" Then

            objDoc.All(k).Click

         

        End If

    Next

     WebBrowser1.Navigate "http://148.36.20.220:86/"

  'WebBrowser1.Document.Forms(0).ImageButton2.Click

  Else:

     j = (Int(Rnd * 10) + 3) * 1000

       Sleep j

       DoEvents

       WebBrowser1.Navigate "http://148.36.20.220:86/"

  End If

  End If

 

End Sub




2

积累一些材料




Sub test()

Dim ie

Set ie = CreateObject("internetexplorer.application")

ie.Visible = True

ie.Navigate "http://hao.360.cn"

While ie.Busy Or ie.ReadyState <> 4

Wend

While ie.Document.Title <> "登  录"

Wend

While ie.Busy Or ie.ReadyState <> 4

Wend

  ie.Document.logform.u6name.Value = "460"

  ie.Document.logform.p6wd.Value = "366"

  ie.Document.logform.submit

 'Set ws = CreateObject("Wscript.shell")

 'ws.run "C:\Program Files\6.exe"

 'set ws=nothing

 Set ie = Nothing

End Sub

3 下面可以将网页的内容读取到excel sheet 中

http://www.chinastock.com.cn/fund/fundscreening/index.shtml

Sub 运用VBA提取网页的基金信息到Excel工作表中()

    Dim IE As Object, srg$, arr, Ar, brr, i%, j%, sr$, Rst(1 To 10000, 1 To 13)

    Set IE = CreateObject("Microsoft.XMLHTTP")

    With IE

        .Open "get", "http://www.chinastock.com.cn/fund/fundscreening/index.shtml", False

        .send

        srg = .responsetext

    End With

    Cells.Clear

    

    '提取标题行文字

    arr = Replace(Split(Split(srg, "<THEAD>")(1), "</THEAD>")(0), "<br>", vbCrLf) '先后以<THEAD>和</THEAD>为拆分字符提取.responsetext中二者之间的内容，并将<br>替换成vbCrLf

    For i = 1 To 13

        Ar = Split(Replace(Split(arr, "</td>")(i + 2), "</span>", ""), ">")

        Rst(1, i) = Ar(UBound(Ar))

        Erase Ar

    Next

    

    '提取标题行以下内容

    brr = Split(srg, "jsp?symbol=")    '以jsp?symbol=为拆分字符将.responsetext拆分成一个一维数组

    For i = 2 To UBound(brr) Step 2

        '提取基金代码

        Rst(i / 2 + 1, 1) = "'" & Split(brr(i), """")(0)

        '提取基金简称

        Rst(i / 2 + 1, 2) = Mid(Split(Split(brr(i), """")(3), "</a>")(0), 2)

        '提取净值日期

        Rst(i / 2 + 1, 3) = Split(Split(Split(brr(i), """")(3), "<td>")(1), "</td>")(0)

        '份额净值（元）

        Rst(i / 2 + 1, 4) = Val(Split(Split(Split(brr(i), """")(3), "</td>")(2), "<td>")(1))

        '份额净值（元）

        Rst(i / 2 + 1, 4) = Val(Split(Split(Split(brr(i), """")(3), "</td>")(2), "<td>")(1))

         '份额累计净值（元）

        Rst(i / 2 + 1, 5) = Val(Split(Split(Split(brr(i), """")(3), "</td>")(3), "<td>")(1))

         '份额累计净值（元）

        sr = Split(Split(Split(brr(i), """")(3), "</td>")(4), "<td>")(1)

        If sr Like "*--*" Then

            Rst(i / 2 + 1, 6) = "--"

        Else

            Rst(i / 2 + 1, 6) = Val(sr)

        End If

        sr = ""

        '提取当日(%)及以后的各列

        For j = 7 To 13

            Ar = Split(Split(Split(brr(i), """")(3), "</td>")(j - 2), ">")

            Rst(i / 2 + 1, j) = Val(Ar(UBound(Ar) - 1))

            Erase Ar

        Next

    Next

    '将结果数组Rst的数据写入工作表

    [A1].Resize(i / 2, 13) = Rst

    Columns.AutoFit

End Sub

或用下面简单的

Sub 运用VBA提取网页的基金信息到Excel工作表中()

    On Error GoTo ErrorHandler

    Dim re As Object, srg$, pos1%, pos2%, i%, j%

    Dim arr() As String, brr() As String, crr() As String, Rst(1 To 10000, 1 To 13)

    Application.ScreenUpdating = False

    '下载数据

    With CreateObject("Microsoft.XMLHTTP")

        .Open "get", "%%%%%%%%%%%%%%%%%%", False

        .send

        srg = .responsetext

    End With

    '提取标题

    pos1 = InStr(srg, "<THEAD>") + Len("<THEAD>")

    pos2 = InStr(srg, "</THEAD>")

    arr = Split(Mid(srg, pos1, pos2 - pos1), "</td>")

    Set re = CreateObject("VBScript.RegExp")

    With re

        .Global = True

        .Pattern = "<[^>]+>|\s+"

        For i = 1 To 13

            Rst(1, i) = .Replace(arr(i + 1), "")

        Next

    End With

    '提取内容

    brr = Split(Mid(srg, pos2, InStr(pos2, srg, "</table>")), "</tr>")

    With re

        For i = 0 To UBound(brr) - 7

            crr = Split(brr(i), "</td>")

            For j = 1 To 13

                If j = 1 Then

                    Rst(i + 2, j) = "'" & .Replace(crr(j + 1), "")

                Else

                    Rst(i + 2, j) = .Replace(crr(j + 1), "")

                End If

            Next

        Next

    End With

    '把数据写入当前工作表

    Cells.Clear

    [A1].Resize(i + 1, 13) = Rst

    Columns.AutoFit

ErrorHandler:

    Set re = Nothing

    Erase arr, brr, crr, Rst

    Application.ScreenUpdating = True

End Sub