clsframecontrol.cls

AeroSuite--一组非常漂亮的VISTA控件集

    rtnVal = HTNOWHERE
End If
ConvertHitTest = rtnVal
End Function

Private Function SetHitTestAction(ByVal wMsg As Long, ByVal wParam As Long) As Long
' sets the custom movesize structure
' TODO: need to code for ht_buttons & sysmenu & HTBORDER (unsizable)
' TOOD: if used for MDI Child, the next function isn't screen orientated

GetCursorPos m_Position.mPts
Dim btnID As Integer

Select Case wParam
    Case HTNOWHERE, HTCLIENT, HTBORDER
        m_Position.Action = 0 ' no action
    Case HTLEFT To HTBOTTOMRIGHT    ' borders
        If sysMenuEnabled(smSize) Then
            m_Position.Action = 2
            UpdateUserResize True
        Else
            m_Position.Action = -1
        End If
    Case HTCAPTION
        If IsZoomed(mainHwnd) = 0 And sysMenuEnabled(smMove) Then
            m_Position.Action = 1
        Else
            m_Position.Action = -1
        End If
    Case HTMenuPlus ' menu
        c_MBar.TrackMenuBar m_Position.Tag - 1, True, (tBarIcon(0).tRgn <> 0), True, , , , -2
        m_Position.Action = 0
    Case HTMINBUTTON, HTMAXBUTTON, HTCLOSE
        btnID = GetButtonRef(wParam, True)
        If sysMenuEnabled(Choose(btnID, smClose, smMaximize, smMinimize)) Then
            m_Position.Action = wParam
            tBarIcon(btnID).tState = IIf(wMsg = WM_NCMOUSEMOVE, 1, 2)
            DrawBarIcons 0, btnID, IIf(wMsg = WM_NCMOUSEMOVE, bsHover, bsDown)
'            tBarIcon(btnID).tState = 2
'            DrawBarIcons 0, btnID, bsDown
        Else
            m_Position.Action = -1
            tBarIcon(btnID).tState = 3
            DrawBarIcons 0, btnID, bsDisabled
        End If
    Case Is > HTMenuPlus ' custom button
        m_Position.Action = wParam
        tBarIcon(wParam - HTMenuPlus).tState = 1
        DrawBarIcons 0, wParam - HTMenuPlus, bsDown
    Case HTSYSMENU
        If sysMenuEnabled(smSysIcon) Then
            m_Position.Tag = -GetTickCount()
            m_Position.Action = 0
        Else
            m_Position.Action = -1
        End If
    Case Else
        m_Position.Action = -1
End Select
If m_Position.Action = 1 Or m_Position.Action = 2 Then ' either moving or resizing
    Dim wRect As RECT
    ' determine clipping area for the desktop excluding toolbars
    SystemParametersInfo SPI_GETWORKAREA, 0, wRect, 0
    ClipCursor wRect    ' set clipping area for cursor
    SetCapture mainHwnd     ' capture the cursor
End If
m_Position.HitTest = wParam               ' cache the hittest code & action
If m_Position.Action < 0 Then
    m_Position.Action = HTNOWHERE
    SetHitTestAction = m_Position.Action
Else
    SetHitTestAction = wParam
End If
End Function

Private Function SetNewWindowPos(wParam As Long) As Long

Dim mPt As POINTAPI, newRect As RECT, bRecAdjusted As Boolean, bValidSize As Boolean

GetCursorPos mPt            ' get current mouse points

Select Case m_Position.Action

    Case 1  ' moving
    
    ' simply offset the top/left coords vs recalculating all edges & regions
    Dim xOffset As Long, yOffset As Long
    xOffset = (mPt.X - m_Position.mPts.X)
    yOffset = (mPt.Y - m_Position.mPts.Y)
    m_Position.mPts = mPt
        OffsetRect m_Position.wRect, xOffset, yOffset
        OffsetRgn m_Position.wRgn, xOffset, yOffset
        OffsetRgn hRgn_Client, xOffset, yOffset
        OffsetRgn hRgn_Title, xOffset, yOffset
        OffsetRect hRect_Menu, xOffset, yOffset
        CalculateButtonRect
    bRecAdjusted = True
    
    Case 2  ' resizing
    
    newRect = m_Position.wRect  ' start window rect with last window rect
    ' left & right adjustments
    bValidSize = True
    Select Case m_Position.HitTest
    Case HTRIGHT, HTTOPRIGHT, HTBOTTOMRIGHT ' all require right edge adjusting
        newRect.Right = m_Position.wRect.Right + (mPt.X - m_Position.mPts.X)
    Case HTLEFT, HTTOPLEFT, HTBOTTOMLEFT    ' all require left edge adjusting
        newRect.Left = m_Position.wRect.Left + (mPt.X - m_Position.mPts.X)
    Case Else
        bValidSize = False
    End Select
    If bValidSize Then
        ' test to see if resized window within minimum sizes per sys settings (X)
        If (m_tbarAlign Or 1) = m_tbarAlign Then
            bValidSize = GetSystemMetrics(SM_CYMINTRACK) <= newRect.Right - newRect.Left
        Else
            bValidSize = GetSystemMetrics(SM_CXMINTRACK) <= newRect.Right - newRect.Left
        End If
        If bValidSize Then
            m_Position.wRect.Right = newRect.Right
            m_Position.wRect.Left = newRect.Left
            m_Position.mPts.X = mPt.X
            bRecAdjusted = True
        End If
    End If
    ' top & bottom adjustments
    bValidSize = True
        Select Case m_Position.HitTest
        Case HTTOP, HTTOPLEFT, HTTOPRIGHT       ' all require top edge adjusting
            newRect.Top = m_Position.wRect.Top + (mPt.Y - m_Position.mPts.Y)
        Case HTBOTTOM, HTBOTTOMLEFT, HTBOTTOMRIGHT  ' all require bottom edge adjusting
            newRect.Bottom = m_Position.wRect.Bottom + (mPt.Y - m_Position.mPts.Y)
        Case Else
            bValidSize = False
        End Select
        If bValidSize Then
            ' test to see if resized window within minimum sizes per sys settings (Y)
            If (m_tbarAlign Or 1) = m_tbarAlign Then
                bValidSize = GetSystemMetrics(SM_CXMINTRACK) <= newRect.Bottom - newRect.Top
            Else
                bValidSize = GetSystemMetrics(SM_CYMINTRACK) <= newRect.Bottom - newRect.Top
            End If
            If bValidSize Then
                m_Position.wRect.Bottom = newRect.Bottom
                m_Position.wRect.Top = newRect.Top
                m_Position.mPts.Y = mPt.Y
                bRecAdjusted = True
            End If
        End If
            
    Case Else
        
'        'Debug.Print m_Position.Action; m_Position.hitTest
End Select
' set the new window position
If bRecAdjusted Then
    ' inflate region, but for now
'    If m_Position.wRgn Then DeleteObject m_Position.wRgn
'    m_Position.wRgn = CreateRectRgnIndirect(wRect)
'    If hRgn_Client Then DeleteObject hRgn_Client
'    hRgn_Client = CreateRectRgn(wRect.Left + m_SizingBorder, _
'        wRect.Right - m_SizingBorder, wRect.Top + m_SizingBorder + 16, _
'        wRect.Bottom - m_SizingBorder)
    
    
    ' apply new region
    
    'With m_Position.wRect
    SetWindowPos mainHwnd, 0, m_Position.wRect.Left, m_Position.wRect.Top, m_Position.wRect.Right - m_Position.wRect.Left, m_Position.wRect.Bottom - m_Position.wRect.Top, 0 '&H400
    'End With
    SetNewWindowPos = 1
End If
End Function

Friend Sub BeginSubclass(hWnd As Long)
If mainHwnd Then
    EndSubclass
    Set Font = Nothing
End If
' stil playing with this & may go to the wayside later on...

' now start preparing for subclassing
mainHwnd = hWnd   ' get hwnd reference & set ref to this class
SetSmallIcon
' determine if window is active/inactive: todo: disabled status
m_bIsActive = (GetForegroundWindow() = mainHwnd)
MenuBar.ParentWIndow = mainHwnd ' create a menubar as needed
ReDim tBarIcon(0 To 3) ' min/max/close/sysicon
SetRect m_Position.wRect, 0, 0, -1, -1 ' reset to invalid value used in next line
CalculateInitialStyles  ' calculate new window areas & modify passed window

' begin subclassing & drawing
m_Terminating = False

hOldWndProc = SetWindowLong(mainHwnd, GWL_WNDPROC, GetSubClassAddr())
TweakSysMenu False   ' disable menu items per user-defined options
c_MBar.WindowMenu("beginclass") = 0
UpdateWindowStyles False, False, -3, 0  ' force a complete redraw
End Sub

Friend Sub EndSubclass()
Dim I As Integer, bToggleVisibility As Boolean

'Debug.Print ">>>>>>>>> received END SUBCLASS <<<<<<<<<<"; mainHwnd

If mainHwnd Then    ' clean up here
    ' remove pointer to user-defined drawing routines
    RemoveProp mainHwnd, "lvImpCB_Ptr"
    ' unsubclass the window
    SetWindowLong mainHwnd, GWL_WNDPROC, hOldWndProc
    ' remove pointer to this class for subclassing
    RemoveProp mainHwnd, "lvCFrame_Optr"
    ' return the menubar if needed
    If Not c_MBar Is Nothing Then Set c_MBar = Nothing
    ' add these flags if window is now maximized or minimized
    If IsZoomed(mainHwnd) Then
        m_OriginalStyle = m_OriginalStyle Or WS_MAXIMIZE
    ElseIf IsIconic(mainHwnd) Then
        m_OriginalStyle = m_OriginalStyle Or WS_MINIMIZE
    End If
    ' remove item from taskbar if originally not on taskbar
    If (GetWindowLong(mainHwnd, GWL_STYLE) And WS_VISIBLE) = WS_VISIBLE Then
        If GetWindowLong(mainHwnd, GWL_EXSTYLE) <> m_OriginalStyleEX Then
             ShowWindow mainHwnd, 0 ' to remove item from taskbar if needed
        End If
    End If
    ' update/replace appropriate Style & ExStyle properties
    SetWindowLong mainHwnd, GWL_EXSTYLE, m_OriginalStyleEX
    UpdateWindowStyles False, False, -2, m_OriginalStyle
    ' return the original small icon if replaced
    If m_SmallIcon.ToBeReplaced Then SendMessage mainHwnd, WM_SETICON, 0, ByVal m_SmallIcon.hOriginalIcon
    DrawMenuBar mainHwnd    ' update the menubar
    AdjustImplementSize True    ' resize window to account for removal of custom settings
    TweakSysMenu True       ' re-enable all system menu items
    For I = 0 To UBound(tBarIcon)   ' delete regions
        If tBarIcon(I).tRgn Then DeleteObject tBarIcon(I).tRgn
    Next
End If
' continue with clean up
If m_SmallIcon.ToBeDeleted Then DestroyIcon m_SmallIcon.Handle
If m_DCuser Then DeleteDC m_DCuser
If m_bmpMenuBar Then DeleteObject m_bmpMenuBar
If m_bmpTitlebar Then DeleteObject m_bmpTitlebar
If hRgn_Client Then DeleteObject hRgn_Client
If hRgn_Title Then DeleteObject hRgn_Title
If m_Position.wRgn Then DeleteObject m_Position.wRgn
If hClipRgn Then DeleteObject hClipRgn
If m_Font Then DeleteObject m_Font
m_Font = 0
m_DCuser = 0
m_bmpMenuBar = 0
m_bmpTitlebar = 0
hRgn_Client = 0
hRgn_Title = 0
hClipRgn = 0
m_Position.wRgn = 0
m_SmallIcon.ToBeDeleted = False
m_SmallIcon.ToBeReplaced = False
m_SmallIcon.Handle = 0
m_KeepActive = 0
m_OriginalStyle = 0
m_OriginalStyleEX = 0
mainHwnd = 0
m_sysMenu = 0
SetRect hRect_Menu, 0, 0, 0, 0
Erase tBarIcon()
m_fColor(0) = vbActiveTitleBarText
m_fColor(1) = vbInactiveTitleBarText
End Sub

Friend Function NewWndProc(wMsg As Long, wParam As Long, lParam As Long) As Long

Dim SS As StyleStructure        ' used to test applied window styles
Dim bWasIntercepted As Boolean  ' flag prevents forwarding message on
Dim lRtnVal As Long             ' general use variable
Dim lSysMenuMsg As Long         ' used to identify which msg is calling sysmenu
Dim IsMinimized As Boolean      ' is window iconic
Static p_LockUpdate As Boolean  ' internal for SetCursor hack
Dim callBack As CustomWindowCalls

''Debug.Print mainHwnd, wMsg, wParam; lParam

If Not m_Terminating Then