求助 关于网页取问题
需要将附件中的表格的值抓到单元格A1中) 。样式都无所谓。只需要用webbrowser 控件就好？ 请问如何写呢？最终效果：
网站地址：www.newdefine.com
已知TABLE ID & TABLE NAME ，表格部分代码如下：
代码:
<table cellspacing="0" rules="all" border="1" id="gvEngageRecords" style="background-color:#99DDDD;border-collapse:collapse;">
取值的部分：
<td align="center" onclick="javascript:return RedirectToDetails('1383264');" style="white-space:nowrap;cursor:pointer;color:blue;text-decoration:underline;">1383264</td>
<td align="center" onclick="javascript:return RedirectToDetails('1383246');" style="white-space:nowrap;cursor:pointer;color:blue;text-decoration:underline;">1383246</td>
已知的网页取值办法：
Sub 导入数据()
UserForm1.WebBrowser1.Navigate "http://www.newdefine.com"
Do Until UserForm1.WebBrowser1.ReadyState = 4
' DoEvents
Loop
Dim arr(1 To 20, 0 To 10)
' Dim arrHref(0 To 20, 0 To 1)
' Do
Set dmt = UserForm1.WebBrowser1.Document
Set t = dmt.getElementById("gvEngageRecords") '获取数据表格
Set hrefs = t.Rows(0).Cells(0).getElementsByTagName("A") '取得链接数据
'For n = 0 To hrefs.Length - 1
'arrHref(n, 0) = hrefs(n).href
'arrHref(n, 1) = hrefs(n).innerText
'Next
'For x = 0 To n - 1
' For i = 2 To t.Rows.Length - 2
'For j = 0 To 10
' arr(i - 1, j) = t.Rows(i).Cells(j).innerText
' Next
'Next
Range("a" & Range("a65536").End(xlUp).Row + 1).Resize(20, 11) = arr
' UserForm1.WebBrowser1.Navigate arrHref(x, 0) '导航
Do Until UserForm1.WebBrowser1.ReadyState = 4
DoEvents
Loop
Set dmt = UserForm1.WebBrowser1.Document
Set t = dmt.getElementById("gvEngageRecords") '获取数据表格
' Next
' Loop Until arrHref(n - 1, 1) <> "..."
End Sub
--------------------编程问答-------------------- 测试了下，该网站无法打开。。。 --------------------编程问答-------------------- Do Until UserForm1.WebBrowser1.ReadyState = 4
这句不对，应该用
Do Until UserForm1.WebBrowser1.document.ReadyState = 4 --------------------编程问答-------------------- www.newdefine.com 肯定能打开的啦~
Do Until UserForm1.WebBrowser1.document.ReadyState = 4 测试还是不成功呢？ --------------------编程问答-------------------- 你在Set t = dmt.getElementById("gvEngageRecords")下面插入一句：
msgbox t.innerhtml
看看能得到页面代码吗？ --------------------编程问答-------------------- 没有返回， 机器直接不动了。 --------------------编程问答-------------------- 直接下载得到网页源代码，然后用字符串处理函数处理的吧，会正则的话用正则效果更佳。
Private Function getHtmlStr$(strUrl$)--------------------编程问答-------------------- 谢谢，牦牛兄~ 不能用XMLHTTP呀。 因为是要登录的， 我已经用webbrowser模拟登录了。进去之后向下走到了取值这里 卡住了。 --------------------编程问答-------------------- 其实XMLHTTP也可以发送登陆信息的。
Dim XmlHttp As Object
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
XmlHttp.Open "GET", strUrl, False
XmlHttp.send
getHtmlStr = StrConv(XmlHttp.ResponseBody, vbUnicode)
Set XmlHttp = Nothing
End Function
你在WebBrowser1_documentcomplete事件里处理看看吧 --------------------编程问答-------------------- XMLHTTP 可以发送js的登录脚本么？ 如果可以那太赞了。
网页的登录按钮 为：
<input height="26" width="60" type="image" onclick="javascript:trimAndSubmit();" title="Log on with Email ID" src="/smlogin/images/Log_on_SSO.gif">--------------------编程问答--------------------
Dim bo As Boolean
Private Sub CommandButton1_Click()
Dim HTTP As Object, i&, m$, n$, arA, arB, arC, j&, T%, TT%, k%, y%, f As Boolean
k = [a1]
If k > 1 Then k = k + 1
Set HTTP = CreateObject("Msxml2.XMLHTTP")
T = Range("a65536").End(xlUp).Row + 1
For i = k To 1952
If bo Then End
DoEvents
HTTP.Open "GET", "http://www.newdefine.com" & i, False
HTTP.send ""
m = StrConv(HTTP.responseBody, vbUnicode)
m = Replace(m, "</tbody>", "<tbody>")
m = Replace(m, Chr(9), "")
arA = Split(m, "<tbody>")
arB = Split(arA(1), Chr(10))
DoEvents
TT = 0
For j = 0 To UBound(arB)
DoEvents
m = Replace(arB(j), "<", "<|")
m = Replace(m, ">", "<")
If InStr(m, "<") = 0 Then
n = m
Else
arC = Split(m, "<")
For y = 0 To UBound(arC)
If InStr(arC(y), "|") = 0 Then n = n & arC(y)
Next y
End If
If TT = 18 Then T = T + 1: TT = 0: f = False
n = Replace(n, " ", "")
If n <> "" Then f = True
If f Then TT = TT + 1: Cells(T, TT) = "'" & n
n = ""
Next j
[a1] = i
T = T + 1
With Range("a" & T - 1)
.Interior.ColorIndex = 45
.Activate
' .Value = "以上是第" & i & "页"
End With
Next i
End Sub
Private Sub CommandButton2_Click()
bo = True
End Sub
牦牛兄，能基于这上面改改么？ --------------------编程问答-------------------- 哈哈 不知道为毛，竟然测试成功了。 ActiveWorkbook.RefreshAll
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://g1w0170m.austin.hp.com/EngagementRMX/Request/ETrack_Summary.aspx?scartid=6" _
, Destination:=Range("$A$1"))
.Name = "ETrack_Summary.aspx?scartid=6"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 2
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = """gvEngageRecords"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = True
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
补充：VB , VBA
