threadolepump.bas

VB圣经

Attribute VB_Name = "ThreadOlePump"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'   Files:
'     None
'   Minimal VBoost conditionals:
'     None
'   Conditional Compilation Values:
'     None
'
' This file is discussed in Chapter 13.
'***************************************************************
Option Explicit

Private Const cstrOleThreadClass As String = "OleMainThreadWndClass"
Private Const cstrOleThreadWndName As String = "OleMainThreadWndName"
Private Const cstrWin95RPCClass As String = "WIN95 RPC Wmsg"
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Private Const VER_PLATFORM_WIN32_NT  As Long = 2

Private Type OSVERSIONINFO 'for GetVersionEx API call
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion(0 To 127) As Byte 'Don't care about string info, leave as byte
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function GetWindowTextW Lib "user32" (ByVal hWnd As hWnd, ByVal lpString As Long, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowTextA Lib "user32" (ByVal hWnd As hWnd, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function FindWindowW Lib "user32" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long

Private Enum GWCmd
    GW_HWNDFIRST = 0
    GW_HWNDLAST = 1
    GW_HWNDNEXT = 2
    GW_HWNDPREV = 3
    GW_OWNER = 4
    GW_CHILD = 5
End Enum

Private Const ERROR_INVALID_WINDOW_HANDLE As Long = 1400&
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As hWnd, ByVal uCmd As GWCmd) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As hWnd, Optional ByVal lpProcessId As Long = 0) As Long

Private m_fInit As Boolean
Private m_OLEhWnd As Long
Private m_ClassNameBuf As String

Public Sub SpinOlehWnd(ByVal fYield As Boolean)
Dim PMFlags As PMOptions
Dim wMsgMin As Long
Dim wMsgMax As Long
Dim MSG As MSG
    If Not m_fInit Then FindOLEhWnd
    If fYield Then
        PMFlags = PM_REMOVE
    Else
        PMFlags = PM_REMOVE Or PM_NOYIELD
    End If
    If m_OLEhWnd = 0 Then
        'Not sure which window to spin on (this is very unlikely)
        'A PeekMessage loop on all windows can still beat DoEvents
        'and reduce side effects by just looking at WM_USER messages
        'and higher
        wMsgMin = &H400 'WM_USER
        wMsgMax = &H7FFF
    End If
    Do While PeekMessage(MSG, m_OLEhWnd, wMsgMin, wMsgMax, PMFlags)
        TranslateMessage MSG 'Probably does nothing, but technically correct
        DispatchMessage MSG
    Loop
End Sub
Private Sub FindOLEhWnd()
Dim WndEnumProc As Long
Dim fWin95RPC As Boolean
Dim OSVI As OSVERSIONINFO
    m_fInit = True 'One shot only
    OSVI.dwOSVersionInfoSize = Len(OSVI)
    If GetVersionEx(OSVI) Then
        If OSVI.dwPlatformId And VER_PLATFORM_WIN32_NT Then
            If OSVI.dwMajorVersion < 5 Then
                WndEnumProc = FuncAddr(AddressOf WndEnumProcW)
            Else
                FindOLEhWndWindows2000
                Exit Sub
            End If
        ElseIf OSVI.dwPlatformId And VER_PLATFORM_WIN32_WINDOWS Then
            If OSVI.dwMinorVersion = 0 Then
                fWin95RPC = True
                WndEnumProc = FuncAddr(AddressOf WndEnumProcAWin95RPC)
            Else 'Win98, look for same class as NT
                WndEnumProc = FuncAddr(AddressOf WndEnumProcA)
            End If
        Else
            Exit Sub
        End If
    End If
    m_ClassNameBuf = String$(255, 0)
    EnumThreadWindows App.ThreadID, WndEnumProc, VarPtr(m_OLEhWnd)
    If m_OLEhWnd = 0 Then
        If fWin95RPC Then
            EnumThreadWindows App.ThreadID, FuncAddr(AddressOf WndEnumProcA), VarPtr(m_OLEhWnd)
        End If
    End If
    m_ClassNameBuf = vbNullString
End Sub
Private Function WndEnumProcW(ByVal hWnd As Long, OlehWnd As Long) As BOOL
Dim CharLen As Long
    CharLen = GetClassNameW(hWnd, m_ClassNameBuf, 255)
    If CharLen = Len(cstrOleThreadClass) Then
        OlehWnd = hWnd
        If Left$(m_ClassNameBuf, CharLen) = cstrOleThreadClass Then
            CharLen = GetWindowTextW(hWnd, StrPtr(m_ClassNameBuf), 255)
            If CharLen Then
                If Left$(m_ClassNameBuf, CharLen) = cstrOleThreadWndName Then
                    'If we find one with this window name, then its the desired window
                    'Otherwise, any window with this class will do.
                    Exit Function
                End If
            End If
        End If
    End If
    WndEnumProcW = BOOL_TRUE
End Function
Private Function WndEnumProcA(ByVal hWnd As Long, OlehWnd As Long) As BOOL
    If GetClassNameA(hWnd, m_ClassNameBuf, 255) Then
        If Left$(m_ClassNameBuf, Len(cstrOleThreadClass)) = cstrOleThreadClass Then
            OlehWnd = hWnd
            If GetWindowTextA(hWnd, m_ClassNameBuf, 255) Then
                If Left$(m_ClassNameBuf, InStr(m_ClassNameBuf, vbNullChar) - 1) = cstrOleThreadWndName Then
                    'If we find one with this window name, then its the desired window
                    'Otherwise, any window with this class will do.
                    Exit Function
                End If
            End If
        End If
    End If
    WndEnumProcA = BOOL_TRUE
End Function
Private Function WndEnumProcAWin95RPC(ByVal hWnd As Long, OlehWnd As Long) As BOOL
    If GetClassNameA(hWnd, m_ClassNameBuf, 255) Then
        If 1 = InStr(Left$(m_ClassNameBuf, InStr(m_ClassNameBuf, vbNullChar) - 1), cstrWin95RPCClass) Then
            OlehWnd = hWnd
            Exit Function
        End If
    End If
    WndEnumProcAWin95RPC = BOOL_TRUE
End Function
'The OLE hwnd is hidden on Windows 2000. It doesn't show up in
'an EnumThreadWindows or an EnumChildWindows list, but it is
'available with FindWindow. The problem is that this call may
'get the OLE window in a different thread than this one, so we
'then have to use GetWindow to find the window in this thread.
'GetWindow is prone to windows being deleted and cycles, so we
'have to be very careful while using it.
Private Sub FindOLEhWndWindows2000()
Dim hWndStart As Long
Dim hWndCur As Long
Dim FindThreadID As Long
    FindThreadID = App.ThreadID
    With Err
RestartLoop:
        .Clear
        hWndCur = FindWindowW(StrPtr(cstrOleThreadClass), 0)
        If hWndCur Then
            m_ClassNameBuf = String$(255, 0)
            hWndCur = GetWindow(hWndCur, GW_HWNDFIRST)
            hWndStart = hWndCur
            Do While hWndCur
                If GetWindowThreadProcessId(hWndCur) = FindThreadID Then
                    If WndEnumProcW(hWndCur, m_OLEhWnd) = BOOL_FALSE Then
                        Exit Do
                    End If
                End If
                hWndCur = GetWindow(hWndCur, GW_HWNDNEXT)
                If hWndStart = hWndCur Then GoTo RestartLoop
            Loop
            If .LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
                'A window died underneath us. Just try the loop again,
                'we'll get it eventually.
                GoTo RestartLoop
            End If
            m_ClassNameBuf = vbNullString
        End If
    End With
End Sub
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function