Subclassing the WebBrowserControl 1

[CassandraR]

Hi DrJavaJoe:

Per your request, here is the code that I am working with. I have replaced some of your code with a simpler interface to get the handle for the webbrowser. (The code used is what MS has suggested.)

Code for the MainLib.bas module.

Option Explicit
'
' Code for MainLib.bas module.
'

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'
'--------------------------------------------------------------------------------------
'

Public Sub Main()

' Temporary code for debugging frmPIC
frmPIC.Show
Exit Sub
' End of Temporary code for debugging frmPIC

'    If App.PrevInstance Then
'        End
'    ElseIf Left(LCase(Command()), 2) = "/c" Then
'        frmCFG.Show
'    ElseIf Left(LCase(Command()), 2) = "/s" Then
'        frmPIC.Show
'    End If
End Sub
'
'--------------------------------------------------------------------------------------
'

Code for the form module (frmPIC.frm)

Option Explicit
'
' frmPIC.frm CODE MODULE
'
'   Form includes:
'       wbrLisa     WebBrowserControl
'   File needed: LisaView.html, plus an animated GIF pointed to by LisaView.html
'

Private Sub DoScreen()
    Do While True
        DoEvents
        Sleep 50
    Loop
End Sub
'
'--------------------------------------------------------------------------------------
'

Private Sub wbrLisa_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, _
            Flags As Variant, TargetFrameName As Variant, PostData As Variant, _
            Headers As Variant, Cancel As Boolean)
    Dim lngResult As Long
    '
    '   Only hook the window procedure once
    '
    If Not HookedWebBrowser Then
        lngResult = GetBrowserWindow(Me.hwnd)
        Call HookWebBrowser
    End If
End Sub
'
'--------------------------------------------------------------------------------------
'

Private Sub Form_Load()
    Dim strTemp As String
    Dim lngBrowserHWND As Long
    
    Width = Screen.Width
    Height = Screen.Height
    Top = 0
    Left = 0
    
    lngBrowserHWND = GetBrowserWindow(Me.hwnd)
    
    With wbrLisa
        .Left = 0
        .Top = 0
        .Width = frmPIC.Width + 200
        .Height = frmPIC.Height
        .AddressBar = False
        strTemp = "file://" & App.Path & "/LisaView.html"
        strTemp = Replace(strTemp, "\", "/")
        .Navigate strTemp
        .Visible = True
    End With
    Me.Show
    DoScreen
End Sub
'
'--------------------------------------------------------------------------------------
'

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    UnHookWebBrowser
End Sub
'
'--------------------------------------------------------------------------------------
'

Code for the subclassing module (mdlWBRSuclass2.bas)

Option Explicit
'
'   API Declarations
'
Private Declare Function GetWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal wCmd As Long) As Long
   
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long
    
Private 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

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    Destination As Any, _
    Source As Any, _
    ByVal Length As Long)

'   API parameter constants
Private Const GWL_WNDPROC As Long = -4&
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD As Long = 5&

'   Window Procedure Message Constants
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_MOUSEMOVE = &H200
Private Const WM_RBUTTONDOWN As Long = &H204&
Private Const WM_RBUTTONUP As Long = &H205&

'
'   Local pointer variables
'
Private m_lngOriginalWindowProc As Long
Private m_lngWebControlHWND As Long
'
'--------------------------------------------------------------------------------------
'

Function LoWord(DWord As Long) As Integer
    CopyMemory LoWord, DWord, 2
End Function
'
'--------------------------------------------------------------------------------------
'

Function HiWord(DWord As Long) As Integer
    CopyMemory HiWord, ByVal VarPtr(DWord) + 2, 2
End Function
'
'--------------------------------------------------------------------------------------
'

Public Function GetBrowserWindow(hwndBrowserContainer As Long) As Long
    Dim lngRetVal As Long
    Dim lngResult As Long
    Dim hwndChild, hwndPeer As Long
    Dim strClassString As String * 256

    hwndPeer = GetWindow(hwndBrowserContainer, GW_CHILD)
    While (lngResult = 0) And (hwndPeer <> 0)
        lngRetVal = GetClassName(hwndPeer, strClassString, 256)
        If hwndPeer <> 0 Then
            lngRetVal = GetClassName(hwndPeer, strClassString, 256)
            If Left$(strClassString, InStr(strClassString, Chr$(0)) - 1) = _
                        "Shell Embedding" Then
                lngResult = 1
                hwndChild = hwndPeer
            End If
        End If
        hwndPeer = GetWindow(hwndPeer, GW_HWNDNEXT)
    Wend
    m_lngWebControlHWND = hwndChild
    GetBrowserWindow = hwndChild
End Function
'
'--------------------------------------------------------------------------------------
'

Public Sub HookWebBrowser()
    If m_lngWebControlHWND <> 0 Then
        '
        '   Subclass the Web Control Window with the new-found hWnd
        '
        m_lngOriginalWindowProc = SetWindowLong(m_lngWebControlHWND, GWL_WNDPROC, _
                    AddressOf WebBrowserWindowProc)
    End If
End Sub
'
'--------------------------------------------------------------------------------------
'

Public Function HookedWebBrowser() As Boolean
    '
    '   Give a way to tell if we are currently subclassed
    '
    HookedWebBrowser = CBool(m_lngOriginalWindowProc)
End Function
'
'--------------------------------------------------------------------------------------
'

Public Sub UnHookWebBrowser()
    '
    '   Define local variables
    '
    Dim lngReturnValue As Long
    '
    '   Reset the window procedure to the original value
    '
    If m_lngOriginalWindowProc Then _
        lngReturnValue = SetWindowLong(m_lngWebControlHWND, GWL_WNDPROC, _
                    m_lngOriginalWindowProc)
    '
    '   Reset the local window procedure address
    '
    m_lngOriginalWindowProc = 0
End Sub
'
'--------------------------------------------------------------------------------------
'

Private Function WebBrowserWindowProc(ByVal WindowHandle As Long, _
                                      ByVal Message As Long, _
                                      ByVal wParam As Long, _
                                      ByVal LParam As Long) As Long

Debug.Print "WebBrowserWindowProc : " & CStr(Message)
    
    Select Case Message
        Case WM_MOUSEMOVE
            Debug.Print "WM_MOUSEMOVE : " & LoWord(LParam) & " - " & HiWord(LParam)
        Case WM_LBUTTONDOWN
            Debug.Print "I've been clicked"
        Case WM_RBUTTONUP, WM_RBUTTONDOWN
            'Don't let it see the right mouse button up or down
            WebBrowserWindowProc = 0
        Case Else
            'Pass anything else through unchanged
            WebBrowserWindowProc = CallWindowProc(m_lngOriginalWindowProc, _
                    WindowHandle, Message, wParam, LParam)
    End Select
' Temporary code to allow exit.
If Message = 33& Then
    UnHookWebBrowser
    End
End If
' End of Temporary code to allow exit.
End Function
'
'--------------------------------------------------------------------------------------
'

The HTML file referred to by frmPIC.frm

<HTML>
<HEAD>
	<META name="description" content="Screen Saver Interface To GIF File">
	<META name="generator" content="CuteHTML">
</HEAD>
<BODY BACKGROUND="C:\WINDOWS\LisaSCR.GIF" BGCOLOR="#000000">

</BODY>
</HTML>

With all of the above code, VB still does not exit gracefully. It causes a protection fault.

Thanks,
Cassie

 

[CassandraR]

OOPS!

I should have mentioned that this is a continuation of another thread: Importing Gif animation files into vb
thread222-952129

Cassandra

 

[Hypetia]

Cassandra, I believe that your program is crashing because you are ending the program using the End statement in the WebBrowserWindowProc. Although you are unhooking your web browser control before ending your program but unhooking or unsubclassing does not complete as long as there is any code running in the window procedure.

Thats exactly what is happening in your case. You look for message 33 (WM_MOUSEACTIVATE), unhook your webbrowser and immediately end your program after that.

I always avoid the use of End statement even if I am not doing any kind of sublcassing. I always prefer to unload my form. If you terminate your program using the Unload method, you don't even need to unhook any controls/windows before unloading your form.

Moreover, I wonder why are you using DoScreen sub. This sub executes an endless loop that prevents your program from ending using the Unload method. You may simply remove the last two lines in the Form_Load event from which this subroutine is called. The form will be shown automatically when the Load event completes.

If you have some strong reason for using DoScreen sub, then you may better utilize your time there instead of looping uselessly. You may use the GetCursorPos and GetAsyncKeyState function to get the position and button status of the mouse without using subclassing at all.

Finally, from thread222-952129, I see that you are doing all this stuff to terminate your screensaver on a keyboard or mouse action. I have a very simple suggestion for this.

You may monitor the keyboard events just by turning on KeyPreview property of your form. This causes your form to receive all keyboard events before they are passed to the control in focus.

As far as mouse events are concerned you can capture mouse event in your form by using the SetCapture function. This function forces Windows to send all mouse events to your form (or any other window) even if mouse is not present above it.

See the SetCapture function for more details.

Hope that helps.

 

[CassandraR]

Hi Hypertia:

Many thanks for the suggestions. I have incorporated your suggestions and have them working. Now, I just need to a bit fine-tuning on the mouse handling.

I love a solution without subclassing, as subclassing doesn't work well for me. (I know, I need to hit the books.)

Many, many thanks! Have a star on me.

Cassandra