【IE8是否允许网页脚本访问计算机关键位置】用WebBrowser打开淘宝宝贝页面，键鼠锁死，电脑死机
运行程序，在Text1中填入：http://item.taobao.com/item.htm?id=12772069714&
点击浏览即死机
Form1.frm
Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long)
Private Sub Command1_Click()
Form1.Caption = "正在打开宝贝信息页面..."
WebBrowser1.Silent = True
WebBrowser1.Navigate Text1.Text
Do Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
WebBrowser1.SetFocus
Dim i As Long
For i = 1 To 700
SendKeys "{PGDN}"
Next i
Do While WebBrowser1.Busy = True
DoEvents
Loop
Form1.Caption = "开始获取宝贝信息..."
WBDocBodyInnerHtml = WebBrowser1.Document.body.innerHtml
WBDocBodyInnerHtml = Replace(WBDocBodyInnerHtml, """", "")
Call GetBaoBeiInfo
End Sub
Private Sub Command2_Click()
Open "c:\temp001.txt" For Output As #1
Print #1, WebBrowser1.Document.body.innerHtml
Close #1
End Sub
Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
pDisp.Document.parentWindow.execScript "window.alert=null; "
pDisp.Document.parentWindow.execScript "window.confirm=null; "
pDisp.Document.parentWindow.execScript "window.showModalDialog=null; "
pDisp.Document.parentWindow.execScript "window.open=null; "
End Sub
Private Function GetBaoBeiString(strFront As String, strBack As String, LeftToRight As Boolean, Optional ByRef SearchStartPos As Long = 1) As String
Dim StartPos As Long, EndPos As Long, Length As Long
If LeftToRight = True Then
StartPos = InStr(SearchStartPos, WBDocBodyInnerHtml, strFront)
If StartPos = 0 Then
Exit Function
End If
StartPos = StartPos + Len(strFront)
Length = InStr(StartPos, WBDocBodyInnerHtml, strBack) - StartPos
Else
EndPos = InStr(SearchStartPos, WBDocBodyInnerHtml, strBack)
If EndPos = 0 Then
Exit Function
End If
StartPos = InStrRev(WBDocBodyInnerHtml, strFront, EndPos) + Len(strFront)
Length = EndPos - StartPos
End If
GetBaoBeiString = Mid(WBDocBodyInnerHtml, StartPos, Length)
SearchStartPos = EndPos + Len(strBack)
End Function
Private Sub GetBaoBeiInfo()
Dim SearchStartPos As Long, BaoBeiString As String, BaoBeiLabel As String
SearchStartPos = 1
BaoBeiInfo.宝贝标题 = GetBaoBeiString("<DIV class=tb-detail-hd>" & vbCrLf & "<H3>", "</H3><SPAN", True)
ReDim BaoBeiInfo.左侧类目(1, 0)
Do
BaoBeiString = GetBaoBeiString("<LI title= ", ">", True, SearchStartPos)
If BaoBeiString = "" Then Exit Do
BaoBeiLabel = GetBaoBeiString(">", ":", True, SearchStartPos)
BaoBeiInfo.左侧类目(0, UBound(BaoBeiInfo.左侧类目, 2)) = BaoBeiLabel
BaoBeiInfo.左侧类目(1, UBound(BaoBeiInfo.左侧类目, 2)) = BaoBeiString
ReDim Preserve BaoBeiInfo.左侧类目(1, UBound(BaoBeiInfo.左侧类目, 2) + 1)
Loop
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.一口价 = GetBaoBeiString("</SPAN> <STRONG id=J_StrPrice>", "</STRONG>元", True)
ReDim BaoBeiInfo.自定义颜色(1)
BaoBeiInfo.自定义颜色(0) = GetBaoBeiString("<LI class=tb-txt tb-selected title=", " data-value=", True)
If BaoBeiInfo.自定义颜色(0) = "" Then
SearchStartPos = 1
ReDim BaoBeiInfo.自定义颜色(0)
Do
BaoBeiInfo.自定义颜色(UBound(BaoBeiInfo.自定义颜色)) = GetBaoBeiString("<LI class=tb-txt title=", " data-value=", True, SearchStartPos)
If BaoBeiInfo.自定义颜色(UBound(BaoBeiInfo.自定义颜色)) = "" Then Exit Do
ReDim Preserve BaoBeiInfo.自定义颜色(UBound(BaoBeiInfo.自定义颜色) + 1)
Loop
End If
Dim URL As String, LocalFileName As String, lngRetVal As Long
SearchStartPos = 1
ReDim BaoBeiInfo.颜色图片的本地地址(0)
Do
URL = GetBaoBeiString("<DIV class=tb-pic tb-s40><A href=#><IMG src=", "_40x40.jpg></A> ", True, SearchStartPos)
If URL = "" Then Exit Do
LocalFileName = Mid(URL, InStrRev(URL, "/") + 1)
lngRetVal = URLDownloadToFile(0, URL, LocalFileName, 0, 0)
BaoBeiInfo.颜色图片的本地地址(UBound(BaoBeiInfo.颜色图片的本地地址)) = App.Path & "" & LocalFileName
ReDim Preserve BaoBeiInfo.颜色图片的本地地址(UBound(BaoBeiInfo.颜色图片的本地地址) + 1)
Loop
SearchStartPos = 1
ReDim BaoBeiInfo.尺码(0)
Do
BaoBeiInfo.尺码(UBound(BaoBeiInfo.尺码)) = GetBaoBeiString("<SPAN>", "</SPAN></A> </LI>", False, SearchStartPos)
If BaoBeiInfo.尺码(UBound(BaoBeiInfo.尺码)) = "" Then Exit Do
ReDim Preserve BaoBeiInfo.尺码(UBound(BaoBeiInfo.尺码) + 1)
Loop
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
BaoBeiInfo.货号 = GetBaoBeiString("货号: ", "</LI>", True)
End Sub
Public Type BaoBeiInformation
宝贝标题 As String
短类目名称 As String
左侧类目() As String '二维(0,?)
货号 As String
一口价 As String
自定义颜色() As String '一维
颜色图片的本地地址() As String '一维
尺码() As String '一维
库存数量 As String
宝贝描述源码 As String
宝贝描述图片() As String '一维
End Type
Public Const 所在地 As String = "浙江"
Public Const 城市 As String = "杭州"
Public WBDocBodyInnerHtml As String
Public BaoBeiInfo As BaoBeiInformation
