WEBBROWSER中模擬鼠標點擊(SendMessage/PostMessage)

好久沒有寫文章，發一篇頂頂博客訪問量。別人建議轉一些比較好的代碼也貼過來，但是我打算這里主要發自己原創的代碼，所以么。。流量該多少就多少吧。。。

回到主題，在webbrowser中點擊某鏈接網上幾乎都是用document對象模擬點擊，這個方法基本能應對一般的情況，但是例如廣告聯盟的點擊XXX就有檢測機制（不多解釋，你們懂的）。所以完全模擬鼠標的點擊事件就比較完美。於是我用了最常見的SendMessage。

接下來就要解決一個問題，webbrowser的句柄問題。從控件本身得到的句柄不是真正的瀏覽窗口的句柄，用SPY++看一下就能看出來，這里不貼圖了。按照這個窗體的結構，用以下代碼可以獲取到網頁的窗口的句柄。
'獲得webbrowser的句柄
Private Function GetBrowserWindow(hWnd As Long) As Long
    Dim lngHnd As Long
    lngHnd = FindWindowEx(hWnd, 0, "Shell Embedding", vbNullString) '
    lngHnd = FindWindowEx(lngHnd, 0, "Shell DocObject View", vbNullString)
    lngHnd = FindWindowEx(lngHnd, 0, "Internet Explorer_Server", vbNullString)
    GetBrowserWindow = lngHnd
End Function

然后就是網頁元素的定位，向哪個坐標發送點擊。這里用了DOM對象遍歷來獲取具體位置。都知道網頁上一個元素有offsetLeft,offsetWidth,offsetHeight,offsetTop屬性，但是都是相對容器來說的，所以可以通過遍歷相加得到這個元素的絕對位置（這個絕對也是相對於網頁瀏覽器窗口來說的。。）。於是代碼如下：
Private Sub GetPos(objA As Object)
    On Error Resume Next
    adW = objA.offsetWidth
    adH = objA.offsetHeight
    adX = objA.offsetLeft
    adY = objA.offsetTop
    Set objA = objA.parentNode   '遍歷結點 獲取絕對位置
    Do While Not (objA Is Nothing)
        adX = adX + objA.offsetLeft
        adY = adY + objA.offsetTop
        Set objA = objA.parentNode
    Loop
    txtX.Text = CStr(adX)
    txtY.Text = CStr(adY)
    'Debug.Print "X:" & adX, "Y:" & adY, "W:" & adW, "H:" & adH, "P:" & adPos
End Sub

好了，主要的問題分析完畢，我不多說廢話了，直接貼代碼看吧。

'獲得webbrowser的句柄
Private Function GetBrowserWindow(hWnd As Long) As Long
    Dim lngHnd As Long
    lngHnd = FindWindowEx(hWnd, 0, "Shell Embedding", vbNullString) '
    lngHnd = FindWindowEx(lngHnd, 0, "Shell DocObject View", vbNullString)
    lngHnd = FindWindowEx(lngHnd, 0, "Internet Explorer_Server", vbNullString)
    GetBrowserWindow = lngHnd
End Function

Private Function IsURL(objHTML As Object) As Boolean
    On Error Resume Next

    Dim strHTML As String, strURL As String
    
    IsURL = False
    strURL = LCase$(txtHost.Text)
    strHTML = LCase$(objHTML.innerhtml)   '都轉成小寫
    
    If InStr(strHTML, strURL) > 0 Then IsURL = True  '是這個域名 返回true

End Function

Private Sub GetPos(objA As Object)
    On Error Resume Next

    adW = objA.offsetWidth
    adH = objA.offsetHeight
    adX = objA.offsetLeft
    adY = objA.offsetTop
    Set objA = objA.parentNode   '遍歷結點 獲取絕對位置

    Do While Not (objA Is Nothing)
        adX = adX + objA.offsetLeft
        adY = adY + objA.offsetTop
        Set objA = objA.parentNode
    Loop

    txtX.Text = CStr(adX)
    txtY.Text = CStr(adY)
    'Debug.Print "X:" & adX, "Y:" & adY, "W:" & adW, "H:" & adH, "P:" & adPos
End Sub

''獲取坐標按鈕點擊事件
Private Sub cmdGetXY_Click()
    On Error Resume Next

    Dim objHTML As Object
    Dim i       As Integer
    
    If txtHost.Text = "" Then
        'MsgBox "不寫域名，搞我呀。。。"
        Exit Sub
    End If

    txtX.Text = ""
    txtY.Text = ""
    adX = 0
    adY = 0
    adW = 0
    adH = 0
    
    For i = 0 To 9
        Set objHTML = webB.Document.GetElementByID("bdfs" & CStr(i))

        If Not (objHTML Is Nothing) Then
            If IsURL(objHTML) Then
                Set objHTML = webB.Document.GetElementByID("dfs" & CStr(i))
                adPos = 1   '右側鏈接區
                Call GetPos(objHTML)
                Exit For
            End If
        End If

        Set objHTML = webB.Document.GetElementByID("400" & CStr(i))

        If Not (objHTML Is Nothing) Then
            If IsURL(objHTML) Then
                Set objHTML = webB.Document.GetElementByID("aw" & CStr(i - 1))
                adPos = 0
                Call GetPos(objHTML)
                Exit For
            End If
        End If

        Set objHTML = webB.Document.GetElementByID("300" & CStr(i))

        If Not (objHTML Is Nothing) Then
            If IsURL(objHTML) Then
                Set objHTML = webB.Document.GetElementByID("aw" & CStr(i - 1))
                adPos = 2
                Call GetPos(objHTML)
                Exit For
            End If
        End If

    Next
    
    'If adX = 0 And adY = 0 Then MsgBox "沒有找到。。。"
    
    Set objHTML = Nothing
    
End Sub

'''發送點擊按鈕點擊事件
Private Sub cmdClick_Click()
    On Error Resume Next
    Dim x      As Long, y As Long
    Dim intRnd As Integer

    Randomize   '啟動隨機數

    If adX = 0 And adY = 0 Then
        'MsgBox "沒有找到鏈接你也點。。。"
        Exit Sub
    End If
    
    wbHwnd = GetBrowserWindow(Me.hWnd)  '得到句柄

    If adPos = 0 Then  '在搜索結果區的上面
        webB.Document.parentwindow.Scroll 0, adY - adH + 8  '修正下數據 正好對准
        x = 30 + Int((Rnd * adW) / 2)
        y = (Int((Rnd * adH) / 2) + 2) * &H10000
    ElseIf adPos = 1 Then '在右側的推廣鏈接區
        webB.Document.parentwindow.Scroll adX, adY - 11 '修正下數據
        x = 150 + Int((Rnd * adW) / 2)
        y = (Int((Rnd * adH) / 2) + 2) * &H10000
    ElseIf adPos = 2 Then '在搜索結果當中
        webB.Document.parentwindow.Scroll 0, adY - 11  '修正下數據
        x = 30 + Int((Rnd * adW) / 2)
        y = (Int((Rnd * adH) / 2) + 2) * &H10000
    End If
    
    'Debug.Print "Click:", x, y / &H10000
    PostMessage wbHwnd, WM_LBUTTONDOWN, 1&, x + y
    PostMessage wbHwnd, WM_LBUTTONUP, 1&, x + y
  
End Sub

 

有什么問題可以加我Q跟我討論。