Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/window2a/clswinvi.cls

Visual Basic class definition | 1999-09-06 | 19.1 KB | 531 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsWinView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Option Explicit

' Name:     Windows Information Viewer
' Author:   Chong Long Choo
' Date:     06 September 1999

' API type definitions

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

' Window field offsets for GetWindowLong() and GetWindowWord()

Const GWL_WNDPROC = (-4)
Const GWL_HINSTANCE = (-6)
Const GWL_HWNDPARENT = (-8)
Const GWL_STYLE = (-16)
Const GWL_EXSTYLE = (-20)
Const GWL_USERDATA = (-21)
Const GWL_ID = (-12)

' Class field offsets for GetClassLong() and GetClassWord()

Const GCL_MENUNAME = (-8)
Const GCL_HBRBACKGROUND = (-10)
Const GCL_HCURSOR = (-12)
Const GCL_HICON = (-14)
Const GCL_HMODULE = (-16)
Const GCL_CBWNDEXTRA = (-18)
Const GCL_CBCLSEXTRA = (-20)
Const GCL_WNDPROC = (-24)
Const GCL_STYLE = (-26)
Const GCW_ATOM = (-32)

' Window Styles

Const WS_OVERLAPPED = &H0&
Const WS_POPUP = &H80000000
Const WS_CHILD = &H40000000
Const WS_MINIMIZE = &H20000000
Const WS_VISIBLE = &H10000000
Const WS_DISABLED = &H8000000
Const WS_CLIPSIBLINGS = &H4000000
Const WS_CLIPCHILDREN = &H2000000
Const WS_MAXIMIZE = &H1000000
Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Const WS_BORDER = &H800000
Const WS_DLGFRAME = &H400000
Const WS_VSCROLL = &H200000
Const WS_HSCROLL = &H100000
Const WS_SYSMENU = &H80000
Const WS_THICKFRAME = &H40000
Const WS_GROUP = &H20000
Const WS_TABSTOP = &H10000
Const WS_MINIMIZEBOX = &H20000
Const WS_MAXIMIZEBOX = &H10000

' Thank to Steve McMahon because provide me all the
' constant of Extended Window Styles.
' Extended Window Styles
' NT3.5x
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_TRANSPARENT = &H20&

' Win9x/NT4
Private Const WS_EX_MDICHILD = &H40&
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_EX_WINDOWEDGE = &H100&
Private Const WS_EX_CLIENTEDGE = &H200&
Private Const WS_EX_CONTEXTHELP = &H400&

Private Const WS_EX_RIGHT = &H1000&
Private Const WS_EX_LEFT = &H0&
Private Const WS_EX_RTLREADING = &H2000&
Private Const WS_EX_LTRREADING = &H0&
Private Const WS_EX_LEFTSCROLLBAR = &H4000&
Private Const WS_EX_RIGHTSCROLLBAR = &H0&

Private Const WS_EX_CONTROLPARENT = &H10000
Private Const WS_EX_STATICEDGE = &H20000
Private Const WS_EX_APPWINDOW = &H40000

Private Const WS_EX_OVERLAPPEDWINDOW = (WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE)
Private Const WS_EX_PALETTEWINDOW = (WS_EX_WINDOWEDGE Or WS_EX_TOOLWINDOW Or WS_EX_TOPMOST)

' Win2000
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_NOINHERITLAYOUT = &H100000      '// Disable inheritence of mirroring by children
Private Const WS_EX_LAYOUTRTL = &H400000            '// Right to left mirroring
Private Const WS_EX_NOACTIVATE = &H8000000

' Class styles
Const CS_VREDRAW = &H1
Const CS_HREDRAW = &H2
Const CS_KEYCVTWINDOW = &H4
Const CS_DBLCLKS = &H8
Const CS_OWNDC = &H20
Const CS_CLASSDC = &H40
Const CS_PARENTDC = &H80
Const CS_NOKEYCVT = &H100
Const CS_NOCLOSE = &H200
Const CS_SAVEBITS = &H800
Const CS_BYTEALIGNCLIENT = &H1000
Const CS_BYTEALIGNWINDOW = &H2000
Const CS_PUBLICCLASS = &H4000

Const GW_HWNDNEXT = 2
Const GW_OWNER = 4
Const GW_CHILD = 5
Const GW_MAX = 5

Const WM_USER = &H400

' API Functions
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam&) As Long
Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessageLongByRef Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, lParam 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 SetCapture Lib "user32" (ByVal hwnd 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 WindowFromPoint Lib "user32" (ByVal x As Long, ByVal y 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 GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

' Build a list of all top level windows.
Public Sub ListTopLevelWindow()
    Dim hwnd As Long
    Dim res As Long
    Set objListTop = New clsWinView
    res = EnumWindows(AddressOf CallBack_EnumWindows, 0&)
    Set objListTop = Nothing
End Sub

'   Show the position of the selected window
Public Sub GetPosition(hwnd As Long, WinPosition As clsWinPosition, Optional strWindow As String)
    Dim WindowRect As RECT
    Dim useHwnd As Long
    Dim objTmpWinPos As clsWinPosition
    Set objTmpWinPos = New clsWinPosition
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    ' Get the rectangle describing the window
    GetWindowRect useHwnd, WindowRect
    With objTmpWinPos
        .Is_Iconic = (IsIconic(useHwnd))
        .Is_Zoomed = (IsZoomed(useHwnd))
        .Is_Enabled = (IsWindowEnabled(useHwnd))
        .Is_Visible = (IsWindowVisible(useHwnd))
        .Left = WindowRect.Left
        .Top = WindowRect.Top
        .Right = WindowRect.Right
        .Bottom = WindowRect.Bottom
    End With
    Set WinPosition = objTmpWinPos
End Sub

'   Show the size of the selected window
Public Sub GetSize(hwnd As Long, WinSize As clsWinSize, Optional strWindow As String)
    Dim WindowClientRect As RECT
    Dim useHwnd As Long
    Dim objTmpWinSize As clsWinSize
    Set objTmpWinSize = New clsWinSize
    If hwnd Then
        useHwnd& = hwnd
    Else
        useHwnd& = GetHwndFromWord(strWindow)
    End If
    ' Get the rectangle describing the window
    GetClientRect useHwnd, WindowClientRect
    objTmpWinSize.Horiz_Pixels = WindowClientRect.Right
    objTmpWinSize.Vert_Pixels = WindowClientRect.Bottom
    Set WinSize = objTmpWinSize
End Sub

' Show class styles for the selected window
Public Sub GetClassInfo(hwnd As Long, ClassInfo As clsClassInfo, Optional strWindow As String)
    Dim clsextra As Long, wndextra As Long
    Dim style As Long
    Dim useHwnd As Long
    Dim objTmpClassInfo As clsClassInfo
    Set objTmpClassInfo = New clsClassInfo
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    ' Get the class info
    ' These all used to be GetClassWord and GCW_ constants
    clsextra = GetClassLong(useHwnd, GCL_CBCLSEXTRA)
    wndextra = GetClassLong(useHwnd, GCL_CBWNDEXTRA)
    style = GetClassLong(useHwnd, GCL_STYLE)
    With objTmpClassInfo
        .Class_Extra = clsextra
        .Word_Extra = wndextra
        .CS_BYTEALIGNCLIENT = (style And CS_BYTEALIGNCLIENT)
        .CS_BYTEALIGNWINDOW = style And CS_BYTEALIGNWINDOW
        .CS_CLASSDC = (style And CS_CLASSDC)
        .CS_DBLCLKS = (style And CS_DBLCLKS)
        .CS_PUBLICCLASS = (style And CS_PUBLICCLASS)
        .CS_HREDRAW = (style And CS_HREDRAW)
        .CS_NOCLOSE = (style And CS_NOCLOSE)
        .CS_OWNDC = (style And CS_OWNDC)
        .CS_PARENTDC = (style And CS_PARENTDC)
        .CS_SAVEBITS = (style And CS_SAVEBITS)
        .CS_VREDRAW = (style And CS_VREDRAW)
    End With
    Set ClassInfo = objTmpClassInfo
End Sub

' Show window extra styles for the selected window
Public Sub GetWinExStyle(hwnd As Long, WinExStyle As clsWinExStyle, Optional strWindow As String)
    Dim style As Long
    Dim useHwnd As Long
    Dim objTmpWinExStyle As clsWinExStyle
    Set objTmpWinExStyle = New clsWinExStyle
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    ' Get the class info
    style& = GetWindowLong&(useHwnd&, GWL_EXSTYLE)
    With objTmpWinExStyle
        .WS_EX_DLGMODALFRAME = (style And WS_EX_DLGMODALFRAME)
        .WS_EX_NOPARENTNOTIFY = (style And WS_EX_NOPARENTNOTIFY)
        .WS_EX_TOPMOST = (style And WS_EX_TOPMOST)
        .WS_EX_ACCEPTFILES = (style And WS_EX_ACCEPTFILES)
        .WS_EX_TRANSPARENT = (style And WS_EX_TRANSPARENT)
        .WS_EX_MDICHILD = (style And WS_EX_MDICHILD)
        .WS_EX_TOOLWINDOW = (style And WS_EX_TOOLWINDOW)
        .WS_EX_WINDOWEDGE = (style And WS_EX_WINDOWEDGE)
        .WS_EX_CLIENTEDGE = (style And WS_EX_CLIENTEDGE)
        .WS_EX_CONTEXTHELP = (style And WS_EX_CONTEXTHELP)
        .WS_EX_RIGHT = (style And WS_EX_RIGHT)
        .WS_EX_LEFT = (style And WS_EX_LEFT)
        .WS_EX_RTLREADING = (style And WS_EX_RTLREADING)
        .WS_EX_LTRREADING = (style And WS_EX_LTRREADING)
        .WS_EX_LEFTSCROLLBAR = (style And WS_EX_LEFTSCROLLBAR)
        .WS_EX_RIGHTSCROLLBAR = (style And WS_EX_RIGHTSCROLLBAR)
        .WS_EX_CONTROLPARENT = (style And WS_EX_CONTROLPARENT)
        .WS_EX_STATICEDGE = (style And WS_EX_STATICEDGE)
        .WS_EX_APPWINDOW = (style And WS_EX_APPWINDOW)
        .WS_EX_OVERLAPPEDWINDOW = (style And WS_EX_OVERLAPPEDWINDOW)
        .WS_EX_PALETTEWINDOW = (style And WS_EX_PALETTEWINDOW)
        .WS_EX_LAYERED = (style And WS_EX_LAYERED)
        .WS_EX_NOINHERITLAYOUT = (style And WS_EX_NOINHERITLAYOUT)
        .WS_EX_LAYOUTRTL = (style And WS_EX_LAYOUTRTL)
        .WS_EX_NOACTIVATE = (style And WS_EX_NOACTIVATE)
    End With
    Set WinExStyle = objTmpWinExStyle
End Sub

' Show window styles for the selected window
Public Sub GetWinStyle(hwnd As Long, WinStyle As clsWInStyle, Optional strWindow As String)
    Dim style As Long
    Dim useHwnd As Long
    Dim objTmpWinStyle As clsWInStyle
    Set objTmpWinStyle = New clsWInStyle
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    ' Get the class info
    style& = GetWindowLong&(useHwnd&, GWL_STYLE)
    With objTmpWinStyle
        .WS_BORDER = (style And WS_BORDER)
        .WS_CAPTION = (style And WS_CAPTION)
        .WS_CHILD = (style And WS_CHILD)
        .WS_CLIPCHILDREN = (style And WS_CLIPCHILDREN)
        .WS_CLIPSIBLINGS = (style And WS_CLIPSIBLINGS)
        .WS_DISABLED = (style And WS_DISABLED)
        .WS_DLGFRAME = (style And WS_DLGFRAME)
        .WS_GROUP = (style And WS_GROUP)
        .WS_HSCROLL = (style And WS_HSCROLL)
        .WS_MAXIMIZE = (style And WS_MAXIMIZE)
        .WS_MAXIMIZEBOX = (style And WS_MAXIMIZEBOX)
        .WS_MINIMIZE = (style And WS_MINIMIZE)
        .WS_MINIMIZEBOX = (style And WS_MINIMIZEBOX)
        .WS_POPUP = (style And WS_POPUP)
        .WS_SYSMENU = (style And WS_SYSMENU)
        .WS_TABSTOP = (style And WS_TABSTOP)
        .WS_THICKFRAME = (style And WS_THICKFRAME)
        .WS_VISIBLE = (style And WS_VISIBLE)
        .WS_VSCROLL = (style And WS_VSCROLL)
    End With
    Set WinStyle = objTmpWinStyle
End Sub

' Retrieve the name of a control in a specific window
Private Function GetControlNameFromWindow(ByVal hwnd&)
    Dim formnum As Integer
    Dim ctlnum As Integer
    For formnum = 0 To Forms.Count - 1
        If Forms(formnum).hwnd = hwnd& Then
            GetControlNameFromWindow = Forms(formnum).Name
            Exit Function
        End If
        For ctlnum = 0 To Forms(formnum).Controls.Count - 1
            On Error Resume Next
            If Forms(formnum).Controls(ctlnum).hwnd = hwnd& Then
                If Err.Number = 0 Then
                    GetControlNameFromWindow = Forms(formnum).Controls(ctlnum).Name
                End If
                Exit Function
            End If
        Next ctlnum
    Next formnum
End Function

' Retrieve the name of a control
Public Function GetCtlName(hwnd As Long, Optional strWindow As String) As String
    Dim useHwnd As Long
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    GetCtlName = GetControlNameFromWindow(useHwnd)
End Function

' load parent window of a child window
Public Function GetParentWindow(hwnd As Long, Optional strWindow As String) As String
    Dim useHwnd As Long, newhwnd As Long
    Dim windowdesc As String
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    newhwnd& = GetParent(hwnd)
    If newhwnd& = 0 Then
        GetParentWindow = vbNullString
        Exit Function
    End If
    GetParentWindow = GetWindowDesc$(newhwnd&)
End Function

' load all the child windows of a specific window
Public Function GetChild(hwnd As Long, Optional strWindow As String) As Boolean
    Dim tHwnd As Long, i As Integer
    i = 1
    If hwnd Then
        tHwnd = hwnd
    Else
        tHwnd = GetHwndFromWord(strWindow)
    End If
    ' It's first child is the specified window
    'tHwnd = GetWindow(tHwnd, GW_CHILD)

    If tHwnd = 0 Then
        GetChild = False
        Exit Function
    End If
    Dim res As Double
    Set objListTop = New clsWinView
    res = EnumChildWindows(tHwnd, AddressOf CallBack_EnumChildWindows, tHwnd)
    GetChild = True
End Function

Public Sub GetOwnedWindow(hwnd As Long, Optional strWindow As String)
    Dim useHwnd As Long
    Dim dl As Long
    If hwnd Then
        useHwnd = hwnd
    Else
        useHwnd = GetHwndFromWord(strWindow)
    End If
    Set objListTop = New clsWinView
    dl& = EnumWindows(AddressOf CallBack_EnumOwnedWindows, useHwnd)
    Set objListTop = Nothing
End Sub

Public Sub SetPointMode(hwnd As Long)
    Dim dl&
    dl& = SetCapture(hwnd)
End Sub

Public Sub ResetPointMode(hwnd As Long)
    If GetCapture() = hwnd Then ReleaseCapture
End Sub

Public Function GetWindowFromPoint(hwnd As Long, x As Long, y As Long) As String
    Dim pt As POINTAPI
    Dim foundhWnd As Long
    pt.x = x
    pt.y = y
    'ClientToScreen hwnd, pt
    foundhWnd = WindowFromPoint(pt.x, pt.y)
    GetWindowFromPoint = GetWindowDesc$(foundhWnd)
End Function

Public Function GetHwndFromWord(strWindow As String) As Long
    Dim p As Integer
    p = InStr(strWindow, Chr$(9))
    If p > 0 Then GetHwndFromWord = Val(Left$(strWindow, p - 1))
End Function

Public Function GetBaseNameFromWord(strWindow As String) As String
    Dim p As Integer, q As Integer
    q = InStr(strWindow, Chr$(9))
    If q > 0 Then p = InStr(q + 1, strWindow, Chr$(9))
    If p > 0 Then GetBaseNameFromWord = Mid$(strWindow, q + 1, p - q - 1)
End Function

Public Function GetClassNameFromWord(strWindow As String) As String
    Dim p As Integer, q As Integer
    Dim strTmp As String
    For q = Len(strWindow) To 1 Step -1
        If Mid(strWindow, q, 1) = Chr(9) Then Exit For
        strTmp = Mid(strWindow, q, 1) + strTmp
    Next
    GetClassNameFromWord = strTmp
End Function

' Builds a string that describing the window in
' format handle, source application, class
' seperated by tabs.
Public Function GetWindowDesc(hwnd As Long) As String
    Dim desc As String
    Dim tbuf As String
    Dim inst As Long
    Dim dl As Long
    Dim hWndProcess As Long
    ' Include the windows handle first
    desc = "&H" + Hex(hwnd) + Chr(9)
    ' Get name of source app
    tbuf = String(256, 0) ' Predefine string length
    dl = GetWindowThreadProcessId(hwnd, hWndProcess)
    If hWndProcess = GetCurrentProcessId() Then
        ' Get instance for window
        inst = GetWindowLong(hwnd, GWL_HINSTANCE)
        ' Get the module filename
        dl = GetModuleFileName(inst, tbuf, 255)
        tbuf = GetBaseName(tbuf)
        tbuf = LPSTRToVBString$(tbuf)
    Else
        tbuf = "Foreign Window"
    End If
    ' And add it to the description
    desc = desc + tbuf + Chr(9)
    ' Add the class name
    tbuf = String(256, 0) ' Initialize space again
    dl = GetClassName(hwnd, tbuf, 255)
    tbuf = LPSTRToVBString$(tbuf)
    desc = desc + tbuf
    GetWindowDesc = desc
End Function

' If source is a path, this function retrieves the
' basename, or filename sans path
' source MUST be a valid filename
Private Function GetBaseName(ByVal source As String) As String
    Do While InStr(source, "\") <> 0
        source = Mid(source, InStr(source, "\") + 1)
    Loop
    If InStr(source, ":") <> 0 Then
        source = Mid(source, InStr(source, ":") + 1)
    End If
    GetBaseName = source
End Function

Public Function GetWindowTitle(ByVal hwnd As Long) As String
    Dim sWindowText As String, r As Long
    On Error Resume Next
    sWindowText = Space(255)
    r = GetWindowText(hwnd, sWindowText, 255)
    sWindowText = Left(sWindowText, r)
    GetWindowTitle = sWindowText
End Function

Private Function LPSTRToVBString$(ByVal s$)
    Dim nullpos&
    nullpos& = InStr(s$, Chr$(0))
    If nullpos > 0 Then
        LPSTRToVBString = Left$(s$, nullpos - 1)
    Else
        LPSTRToVBString = ""
    End If
End Function