modbrowser.bas

VB网络应用,例如:聊天系统,浏览器程序

Attribute VB_Name = "modBrowser"
'--------------------------------------------------------------------------------
'本示例程序向你演示如何使用WebBrowser控件以及如何关闭
'浏览器窗口中的环境菜单
'为正确运行程序，你需要安装IE3.xx或IE4.xx

Option Explicit

'#Const bAllowRightClick = True
#Const bAllowRightClick = False

Public encount As Long
Public hwnds() As Long

Declare Function GetWindow Lib "user32" (ByVal HWnd As Long, _
    ByVal wCmd As Long) As Long

Declare Function GetWindowLong Lib "user32" _
    Alias "GetWindowLongA" (ByVal HWnd As Long, _
    ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" (ByVal HWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function SetFocusAPI Lib "user32" _
    Alias "SetFocus" (ByVal HWnd As Long) As Long

Declare Function GetFocus Lib "user32" () As Long

'GetWindow constants
Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_OWNER = 4
Public Const GW_CHILD = 5

' Window field offsets for GetWindowLong() and GetWindowWord()
Public Const GWL_WNDPROC = (-4)
Public Const GWL_HINSTANCE = (-6)
Public Const GWL_HWNDPARENT = (-8)
Public Const GWL_STYLE = (-16)
Public Const GWL_EXSTYLE = (-20)
Public Const GWL_USERDATA = (-21)
Public Const GWL_ID = (-12)

Public Const WS_VSCROLL = &H200000

Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206

Public Const WM_PARENTNOTIFY = &H210

Public mainHWnd As Long
Public prevMainWndProc As Long

Public prevWndProc() As Long
Public prevWndProcCount As Integer

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal HWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal HWnd As Long) As Long
Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal HWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal HWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

' ShellExecute Declarations ...
Public Const SW_SHOWDEFAULT = 10

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal HWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal HWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Const WM_USER = &H400
Const TB_SETSTYLE = WM_USER + 56
Const TB_GETSTYLE = WM_USER + 57
Const TBSTYLE_FLAT = &H800
Const TBSTYLE_ALTDRAG = &H400

Public Sub SetToolBarFlat(tlbTemp As Toolbar)
Dim lngStyle As Long
Dim lngResult As Long
Dim lngHWND As Long

  lngHWND = FindWindowEx(tlbTemp.HWnd, 0&, "ToolbarWindow32", vbNullString)
  lngStyle = SendMessage(lngHWND, TB_GETSTYLE, &O0, &O0)
  lngStyle = lngStyle Or TBSTYLE_FLAT 'Or TBSTYLE_ALTDRAG
  lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)
  tlbTemp.Refresh
End Sub

Function vbGetWindowText(ByVal HWnd) As String
  Dim c As Integer, s As String
  c = GetWindowTextLength(HWnd)
  If c <= 0 Then Exit Function
  s = String$(c, 0)
  c = GetWindowText(HWnd, s, c + 1)
  vbGetWindowText = s
End Function

Function vbGetWindowTextLine(ByVal HWnd) As String
  Dim sTitle As String, cTitle As Integer
  sTitle = vbGetWindowText(HWnd)
  ' Chop off end of multiline captions
  cTitle = InStr(sTitle, vbCr)
  vbGetWindowTextLine = IIf(cTitle, Left$(sTitle, cTitle), sTitle)
End Function

Function vbGetClassName(ByVal HWnd) As String
  Dim sName As String, cName As Integer
  sName = String$(41, 0)
  cName = GetClassName(HWnd, sName, 41)
  vbGetClassName = Left$(sName, cName)
End Function

Public Sub ShellURLDoc(HWnd As Long, httpDocName As String)
Dim rc As Long
Dim docPath As String
Dim docName As String
Dim pos As Long
  docName = Dir$(httpDocName)
  If (docName <> "") Then
    pos = InStr(1, httpDocName, docName) - 1
    If (pos > 0) Then
      docPath = Mid(httpDocName, 1, pos)
      rc = ShellExecute(HWnd, "open", httpDocName, 0, docPath, SW_SHOWDEFAULT)
      Debug.Print "ShellExecute:rc:", rc
    End If
  End If
End Sub

Function SetFocusToBrowser(hBrowserHwnd As Long) As Long
Dim lStyle As Long
Dim lResult As Long
Dim HWnd As Long
  HWnd = hBrowserHwnd
  While (lResult = 0) And (HWnd <> 0)
    HWnd = GetWindow(HWnd, GW_CHILD)
    lStyle = GetWindowLong(HWnd, GWL_STYLE)
    lResult = lStyle And WS_VSCROLL
  Wend
  SetFocusAPI (HWnd)
  SetFocusToBrowser = HWnd
End Function

Sub EnumWindows(Level As Integer, ByVal HWnd As Long)
Dim CurrWnd As Long, x
Dim count%

'Get the hWnd of the first item in the master list
'so we can process the task list entries (top-level only).

  GoSub DoWindow
  HWnd = GetWindow(HWnd, GW_CHILD)

  count = 0
' Loop while the hWnd returned by GetWindow is valid.
  While HWnd <> 0
    count = count + 1
    Call EnumWindows(Level + 1, HWnd)
    'Debug.Print String$(Level, Chr$(9)); count; ". "; Hex$(HWnd)
    
    'Get the next task list item in the master list.
    HWnd = GetWindow(HWnd, GW_HWNDNEXT)
  Wend
  
  Exit Sub
  
DoWindow:
  Dim s As String, prevProc As Long, wndClass As String
  wndClass = vbGetWindowTextLine(HWnd)
  If wndClass = "" Then wndClass = vbGetClassName(HWnd)
  s = "{" & Hex$(HWnd) & "}" & "[" & wndClass & "]"
  Debug.Print String$(Level * 2, " ") & s
  
  ' wndClass = "HTML_Internet Explorer" for IE3
  ' wndClass = "Internet Explorer_Server" for IE4
  If HWnd <> 0 And (wndClass = "HTML_Internet Explorer" Or _
                    wndClass = "Internet Explorer_Server") Then
    prevProc = GetWindowLong(HWnd, GWL_WNDPROC)
    Call SetWindowLong(HWnd, GWL_WNDPROC, AddressOf HTMLWndProc)
    prevWndProcCount = prevWndProcCount + 1
    ReDim Preserve prevWndProc(1, prevWndProcCount)
    prevWndProc(0, prevWndProcCount) = HWnd
    prevWndProc(1, prevWndProcCount) = prevProc
    'Debug.Print prevWndProcCount & ". Bound ";
  End If
  'Debug.Print "hWnd = " & Hex$(HWnd)
  Return
End Sub

Function ProcBindToBrowser(hBrowserHwnd As Long) As Long
Dim lStyle As Long
Dim lResult As Long
Dim HWnd As Long, prevProc As Long

#If bAllowRightClick = True Then
  Exit Function
#End If
  
  Debug.Print "ProcBindToBrowser"
  HWnd = hBrowserHwnd
  prevWndProcCount = 0
  ReDim prevWndProc(1, prevWndProcCount)
  EnumWindows 0, hBrowserHwnd
  ProcBindToBrowser = HWnd

End Function

Function ProcUnBindFromBrowser(hBrowserHwnd As Long) As Long
Dim i As Integer

#If bAllowRightClick = True Then
  Exit Function
#End If
  
  Debug.Print "ProcUnBindToBrowser"
  For i = 1 To prevWndProcCount
    If prevWndProc(0, i) <> 0 Then
      Call SetWindowLong(prevWndProc(0, i), GWL_WNDPROC, prevWndProc(1, i))
      'Debug.Print i & ". UnBound ";
    End If
    'Debug.Print "hWnd = " & Hex$(prevWndProc(0, i))
  Next i
  prevWndProcCount = 0
  ReDim prevWndProc(1, prevWndProcCount)

End Function

Function HTMLWndProc(ByVal hw As Long, ByVal uMsg As Long, _
                    ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case uMsg
    Case WM_RBUTTONDOWN
      Debug.Print "Yeaaa !!! WM_RBUTTONDOWN"
      ' eat message
    Case WM_RBUTTONUP
      Debug.Print "Yeaaa !!! WM_RBUTTONUP"
      ' eat message
    Case Else
      Dim wndProc As Long
      ' check if messages captured for hw
      wndProc = HTMLFindWndProc(hw)
      If wndProc <> 0 Then
        ' handle captured windows messages
        HTMLWndProc = CallWindowProc(wndProc, hw, uMsg, wParam, lParam)
      End If
  End Select
End Function

Function HTMLFindWndProc(HWnd As Long) As Long
Dim i As Long
  HTMLFindWndProc = 0
  If HWnd = mainHWnd Then
    ' it is handle of main window
    HTMLFindWndProc = prevMainWndProc
  ElseIf prevWndProcCount > 0 Then
    For i = 1 To prevWndProcCount
      If prevWndProc(0, i) = HWnd Then
        ' it is handle of one of child windows (frames)
        HTMLFindWndProc = prevWndProc(1, i)
        Exit For
      End If
    Next i
  End If
End Function