apiwindow.cls

几个不错的VB例子

If BorderStyle = vbBSNone Then
    BorderWidth = 0
Else
    If IsWindowStyleSet(WS_THICKFRAME, False) Then
        BorderWidth = APIDispenser.System.Metrics(SM_CYFRAME)
    Else
        BorderWidth = APIDispenser.System.Metrics(SM_CYEDGE)
    End If
End If

End Property

Public Property Get CaptionHeight() As Long

    If IsWindowStyleSet(WS_CAPTION, False) Then
        If IsWindowStyleSet(WS_EX_TOOLWINDOW, True) Then
            CaptionHeight = APIDispenser.System.Metrics(SM_CYSMCAPTION)
        Else
            CaptionHeight = APIDispenser.System.Metrics(SM_CYCAPTION)
        End If
    Else
        CaptionHeight = 0
    End If
    
End Property

Public Property Get ChildWindows() As Collection

Dim colChildren As Collection
Dim wndThis As ApiWindow
Dim PrevHwnd As Long

'\\ Initialise the collection
Set colChildren = New Collection

Set wndThis = Me.GetWindow(GW_CHILD)
If Not (wndThis Is Nothing) Then
    colChildren.Add wndThis
    PrevHwnd = wndThis.hwnd
    Set wndThis = Me.GetWindow(GW_HWNDNEXT, PrevHwnd)
    While Not (wndThis Is Nothing)
        If wndThis.hwnd <> PrevHwnd Then
            colChildren.Add wndThis
            PrevHwnd = wndThis.hwnd
            Set wndThis = Me.GetWindow(GW_HWNDNEXT, PrevHwnd)
        Else
            Set wndThis = Nothing
        End If
    Wend
End If

Set ChildWindows = colChildren

End Property


'
Public Property Get ClassName() As String

Dim sClassName As String
Dim lret As Long

'\\ Get the class name
sClassName = String$(1024, 0)
lret = GetClassNameApi(m_hwnd, sClassName, 1024)
If (Err.LastDllError = 0) And (lret > 0) Then
    ClassName = Left$(sClassName, lret)
Else
    ReportError Err.LastDllError, "ApiWindow:Classname", GetLastSystemError
End If

End Property

Public Property Get AttachedClipboard() As ApiClipboard

Dim mClipboard As ApiClipboard

Set mClipboard = New ApiClipboard
mClipboard.ParenthWnd = Me.hwnd
Set AttachedClipboard = mClipboard

End Property

Public Property Let ControlBox(ByVal newSetting As Boolean)

If newSetting Then
    SetWindowStyle WS_SYSMENU, False
Else
    UnSetWindowStyle WS_SYSMENU, False
End If

End Property

'\\ --[ControlBox]----------------------------------------------------------------
'\\ This uses the GetWindowLong() call to mimic the operation of the "ControlBox"
'\\ member of a standard VB form, but for any window
'\\ ------------------------------------------------------------------------------
Public Property Get ControlBox() As Boolean

ControlBox = IsWindowStyleSet(WS_SYSMENU, False)

End Property

Public Property Get ControlBoxRectangle() As APIRect

Dim rcThis As New APIRect

With rcThis
    .Right = (Width - BorderWidth)
    .Top = BorderHeight
    If IsWindowStyleSet(WS_EX_TOOLWINDOW, True) Then
        .Bottom = .Top + APIDispenser.System.Metrics(SM_CYSMSIZE)
        .Left = .Right - APIDispenser.System.Metrics(SM_CXSMSIZE)
    Else
        .Bottom = .Top + APIDispenser.System.Metrics(SM_CYSIZE)
        .Left = .Right - APIDispenser.System.Metrics(SM_CXSIZE)
    End If
End With

Set ControlBoxRectangle = rcThis

End Property

'\\ --[CopyText]----------------------------------------------------
'\\ Copies the text from a window (using the clipboard)
'\\ and returns the result as a string.
'\\ ----------------------------------------------------------------
Public Function CopyText() As String

Dim lret As Long
Dim sText As String

'\\ First copy the text into the clipboard buffer...
lret = SendMessage(WM_COPY, 0, 0)

'\\ Now get that data out of the clipboard data area...
If Clipboard.GetFormat(vbCFText) Then
    sText = Clipboard.GetText()
End If

CopyText = sText

End Function

Public Property Get DeviceContext() As ApiDeviceContext

Dim lret As Long

If mDeviceContext Is Nothing Then
    Set mDeviceContext = New ApiDeviceContext
End If
lret = GetDCApi(m_hwnd)
If Err.LastDllError = 0 And lret <> 0 Then
    mDeviceContext.hdc = lret
End If
Set DeviceContext = mDeviceContext

End Property

'\\ --[DeviceContextNC]-------------------------------------------
'\\ This returns the device context for the whole window, including
'\\ the non client area
'\\ ---------------------------------------------------------------
Public Property Get DeviceContextNC() As ApiDeviceContext

Dim lret As Long

If mDeviceContextNC Is Nothing Then
    Set mDeviceContextNC = New ApiDeviceContext
End If
lret = GetWindowDC(m_hwnd)
If Err.LastDllError = 0 And lret <> 0 Then
    mDeviceContextNC.hdc = lret
End If
Set DeviceContextNC = mDeviceContextNC

End Property


Public Sub DrawMenuBar()

Dim lret As Long

lret = DrawMenuBarApi(m_hwnd)
If (lret = 0) Or (Err.LastDllError > 0) Then
    Call ReportError(Err.LastDllError, "ApiWindow:DrawMenuBar:", GetLastSystemError)
End If

End Sub



Public Function GetParent() As ApiWindow

Dim hWndParent As Long
Dim ParentWindow As ApiWindow

If IsWindowApi(m_hwnd) Then
    hWndParent = GetParentApi(m_hwnd)
    If IsWindowApi(hWndParent) Then
        '\\ If its already subclassed, return that instance...
        Set ParentWindow = AllSubclassedWindows.Item(hWndParent)
        If ParentWindow Is Nothing Then
            '\\ Otherwise create a new instance
            Set ParentWindow = New ApiWindow
            ParentWindow.hwnd = hWndParent
        End If
        Set GetParent = ParentWindow
    End If
End If

End Function


Public Function GetWindow(wCmd As enGetWindow, Optional PrevHwnd As Long) As ApiWindow

Dim hwnd As Long
Dim window As ApiWindow

If PrevHwnd = 0 Then
    hwnd = GetWindowApi(m_hwnd, wCmd)
Else
    hwnd = GetWindowApi(PrevHwnd, wCmd)
End If
If IsWindowApi(hwnd) Then
    '\\ If its already subclassed, return that instance...
    On Error Resume Next
    Set window = AllSubclassedWindows.Item(hwnd)
    On Error GoTo 0
    If window Is Nothing Then
        Set window = New ApiWindow
        window.hwnd = hwnd
    End If
    Set GetWindow = window
End If

End Function

Public Function GetWindowLong(index As enGetWindowLong) As Long

Dim lret As Long

lret = GetWindowLongApi(m_hwnd, index)
If Err.LastDllError = 0 Then
    GetWindowLong = lret
End If

End Function

Public Property Get hdc() As Long

hdc = GetDCApi(m_hwnd)

End Property

Public Property Get Height() As Long

    With RECT
        Height = (.Bottom - .Top)
    End With
    
End Property

'\\ --[HitTest]-------------------------------------------------------------
'\\ Returns the position of the x,y coordinate (in client coordinates)
'\\ in terms of what would be hit if the mouse were clicked there
'\\ ------------------------------------------------------------------------
'\\ (c) 2001 Merrion Computing Ltd
Public Function HitTest(ByVal x As Long, ByVal y As Long) As enHitTestResult

Dim htThis As enHitTestResult

With RECT
    If x < 0 Or y < 0 Or x > Width Or y > Height Then
        htThis = HTNOWHERE
    Else
        If x < BorderWidth Then
            '\\ Somewhere in the lefthand border
            htThis = HTLEFT
        ElseIf x >= (Width - BorderWidth) Then
            '\\ Somewhere in the righthand border
            htThis = HTRIGHT
        Else
            If y < BorderHeight Then
                htThis = HTTOP
            ElseIf y >= Height - BorderHeight Then
                htThis = HTBOTTOM
            ElseIf y <= CaptionHeight Then
                htThis = HTCAPTION
                '\\ If the window has the various caption buttons, test these
                If ControlBox Then
                    If ControlBoxRectangle.ContainsPoint(x, y) Then
                        htThis = HTCLOSE
                    ElseIf SysmenuBoxRectangle.ContainsPoint(x, y) Then
                        htThis = HTSYSMENU
                    End If
                End If
                If MinButton Then
                    If MinimiseBoxRectangle.ContainsPoint(x, y) Then
                        htThis = HTMINBUTTON
                    End If
                End If
                If MaxButton Then
                    If MaximiseBoxRectangle.ContainsPoint(x, y) Then
                        htThis = HTMAXBUTTON
                    End If
                End If
            Else
                htThis = HTCLIENT
            End If
        End If
    End If
End With

HitTest = htThis

End Function

Public Property Get hwnd() As Long

    hwnd = m_hwnd
    
End Property

Public Property Let hwnd(ByVal newHwnd As Long)

Dim lret As Long

    If newHwnd <> m_hwnd Then
        '\\ Must reset the proc address before closing
        If mOldProcAddress > 0 Then
            lret = SetWindowLong(GWL_WNDPROC, mOldProcAddress)
            mOldProcAddress = 0
        End If
        '\\ Must unset the menus...
        Set mSystemMenu = Nothing
        Set mMenu = Nothing
        
        m_hwnd = newHwnd
    End If
    
End Property

Public Sub InvalidateRect(ByVal RectIn As APIRect)

Dim rcThis As RECT
Dim lret As Long

With rcThis
    .Bottom = RectIn.Bottom
    .Left = RectIn.Left
    .Top = RectIn.Top
    .Right = RectIn.Right
End With

lret = InvalidateRectByPointerApi(m_hwnd, VarPtr(rcThis), True)

End Sub


'\\ --[IsWindowStyleSet]----------------------------------------------------------------------
'\\ Checks for the style bit specified in the window specified.
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.