|
本帖最后由 VBA万岁 于 2015-1-27 16:19 编辑
VBA万岁 发表于 2015-1-23 16:49
Mrk:
Sub test()
On Error Resume Next
Dim html, arr, r, c%, i%, j%
Set html = CreateObject("htmlfile")
ActiveSheet.UsedRange.Clear: Range("a1") = " "
With CreateObject("Microsoft.XMLHTTP")
.Open "get", "......", False
.send
arr = Split(.responseText, "......")
For i = 2 To UBound(arr)
c = Val(Split(arr(i), Chr(34) & ">")(0))
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) = Split(Split(arr(i), ">")(1), "<")(0)
.Open "get", "......" & c, False
.send
html.body.innerhtml = .responseText
Set r = html.all.tags("table")(57).Rows
For j = 1 To r.Length - 1
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) = Split(r(j).Cells(1).innerText, " ")(0)
Cells(ActiveSheet.UsedRange.Rows.Count, 2) = pinyin(Split(r(j).Cells(1).innerText, " ")(0), "", 2)
Next
Next
End With
Range("a2:b1000").Copy Range("a1:b1")
End Sub
Sub test2()
Dim vcode, myObj As Shape
Dim nUrl As String, localFilename As String, lngRetVal As Long, code$
For Each myObj In ActiveSheet.Shapes
If myObj.Name Like "Rectangle*" Then myObj.Delete
Next
nUrl = "......"
Set vcode = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 410, 1, 80, 28)
vcode.Select
Selection.ShapeRange.Fill.UserPicture nUrl
Application.Wait (Now + TimeValue("0:00:01"))
code = InputBox("请输入验证码!", "验证码:")
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "......", False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "Role=7&Account=" & Range("c2").Value & "&Password=......&CheckCode=" & code
URL = Split(Split(.responseText, "CDATA[")(1), "]]")(0)
End With
On Error Resume Next
Dim i As Long, j%, r
i = ActiveSheet.UsedRange.Rows.Count
With CreateObject("internetexplorer.application")
.Visible = True
.Navigate URL
Do Until .ReadyState = 4
DoEvents
Loop
.Navigate "......"
Do Until .ReadyState = 4
DoEvents
Loop
Set r = .document.all.tags("table")(0).Rows
If Cells(i, 1) = r(0).Cells(1).innerText Then .Navigate URL: Exit Sub
For j = 0 To r.Length - 1
Cells(i + 1, j * 2 + 1) = "'" & r(j).Cells(1).innerText
Cells(i + 1, j * 2 + 2) = "'" & r(j).Cells(3).innerText
Next
.Navigate URL
.Quit
End With
Cells.WrapText = False
End Sub
|
|