clsframecontrol.cls

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

    Else
        If mainHwnd Then    ' subclassed & doable
            If (exStyle Or WS_EX_APPWINDOW) = exStyle Then
                If bToggleVisibility Then ShowWindow mainHwnd, 0
                SetWindowLong mainHwnd, GWL_EXSTYLE, exStyle Or WS_EX_APPWINDOW
                SetWindowLong mainHwnd, GWL_EXSTYLE, exStyle And Not WS_EX_APPWINDOW
                If bToggleVisibility Then SetWindowPos mainHwnd, 0, 0, 0, 0, 0, &H40 Or 551
            End If
        Else    ' not subclassed yet, let's flag a variable to do this later
            m_OriginalStyleEX = 1
        End If
    End If
Else
    ' quickie -- see if window is a taskbar item or not
    If mainHwnd Then
        SetInTaskBar = ((GetWindowLong(mainHwnd, GWL_EXSTYLE) And WS_EX_APPWINDOW) = WS_EX_APPWINDOW)
    End If
End If
End Function

Public Function SetSizingHandle(bSet As Boolean, newSize As Byte) As Byte
' set optional size. Making this larger allows a greater chunk of the
' window edges to be marked for sizing windows
If bSet Then
    If newSize > 0 Then m_SizingBorder = newSize
Else
    SetSizingHandle = m_SizingBorder
End If
End Function


Public Function SetBorderStyle(bSet As Boolean, newStyle As WindowBorderStyleConstants) As WindowBorderStyleConstants
If bSet Then
    If newStyle < wbBlackEdge Or newStyle > wbCustom Or m_BorderStyle = newStyle + 0 Then Exit Function
    ' simply apply a standard-type border around a basic window
    Dim edgeThickness As Long
    Select Case newStyle
    Case 1: ' border only
        edgeThickness = 1
    Case 2: ' thin
        edgeThickness = GetSystemMetrics(SM_CXDLGFRAME) - 1
    Case 3: ' dialog
        edgeThickness = GetSystemMetrics(SM_CXDLGFRAME)
    Case 4: ' thick frame
        edgeThickness = GetSystemMetrics(SM_CXDLGFRAME) + 1
    Case Else   ' custom
        edgeThickness = 8
        ' todo: used for skinning forms
'        Exit Function
    End Select
    m_BorderStyle = newStyle
    SetRect m_BorderXY, edgeThickness, edgeThickness, edgeThickness, edgeThickness
    SetRect m_Position.wRect, 0, 0, -1, -1
    UpdateWindowStyles False, False, -3, 0
Else
    SetBorderStyle = m_BorderStyle + 0
End If
End Function

Public Function SetFontColor(bSet As Boolean, bActive As Boolean, newColor As Long) As Long
If bSet Then
    m_fColor(Abs(bActive = False)) = newColor
    DoDrawTitleBar True, False, "setfontcolor"
Else
    SetFontColor = m_fColor(Abs(bActive = False))
End If
End Function

Public Function SetKeepActive(bSet As Boolean, AlwaysActive As Boolean, AllThreads As Boolean) As Boolean
' property allows a window to not be shown as inactive in various scenarios
' if alwaysActive is false, then window only shown when it has the focus
If bSet Then
    ' when m_KeepActiveAlways is true, it never is displayed as inactive;
    ' however when set to false, it will remain active when any window in
    ' the same thread gets the focus. This option is kinda neat for message
    ' boxes that make the calling form inactive
    If AlwaysActive Then
        m_KeepActive = 2
        m_KeepActive = m_KeepActive Or (4 + Abs(4 * AllThreads))
    Else
        m_KeepActive = 0
    End If
    ' just in case it was changed from a timer or outside source....
    If mainHwnd Then DoDrawTitleBar m_bIsActive, True, "keepactive"
Else
    If AllThreads Then
        SetKeepActive = (m_KeepActive Or 8) = m_KeepActive
    Else
        SetKeepActive = (m_KeepActive Or 4) = m_KeepActive
    End If
End If
End Function

Friend Sub SetTitle(sCaption As String, ByVal hWnd As Long)
If mainHwnd Then hWnd = mainHwnd
If hWnd <> 0 Then SendMessage hWnd, WM_SETTEXT, 0&, ByVal sCaption
End Sub

Friend Sub AddToolBarButton(ByVal btnID As String, ByVal newPos As Long, _
        Optional PosType As TitlelBarBtnPosition, _
        Optional X As Long, Optional Y As Long, _
        Optional Width As Long, Optional Height As Long)

' NewPos has these meanings
' = 0 : add button before minimize button
'       - X/Y/Width/Height not used if PosType = tbPosDefault
' > 0 : add button # of items left of minimize button.
'       - X/Y/Width/Height not used if PosType = tbPosDefault
' < 0 : add button at far left from minimize button
'       - X/Y/Width/Height not used if PosType = tbPosDefault
' PosType is used this way & is for custom placement of buttons....
'   PosType = tbPosDefault : button positioned before minimize button using NewPos
'   PosType = tbPosStatic : the location does not change ever regardless of size/movement
'       - this setting overrides tbPosLockX and/or tbPosLockY if used
'       - X,Y are required, Width/Height are optional
'   PosType = tbPosLockX : location changes with reference to right edge of window
'       - X,Y are required, Width/Height are optional
'   PosType = tbPosLockY : location changes with reference to bottom edge of window
'       - X,Y are required, Width/Height are optional
'   PosType = tbNoFrame : if not used, a button will be drawn
' X & Y : are the top left coordinates of the custom placement
' Width & Height are optional dimensions of the custom button.
'       - If either one is zero, then dimension is calcualted by the project
' ID is a 10 character-max user-defined string value to help reference the
'   button in callback routines and to delete/edit the button

If btnID = "" Then Exit Sub

Dim I As Integer, J As Integer
Dim inID As String * 11
    
inID = Left$(btnID, 10)
ReDim Preserve tBarIcon(0 To UBound(tBarIcon) + 1)
If PosType = tbPosDefault Then
    If newPos = 0 Then  ' add as 1st button left of minimize
        newPos = 4
    ElseIf newPos > UBound(tBarIcon) - 5 Or newPos < 0 Then
        newPos = UBound(tBarIcon)   ' add as furthest left of minimize
    Else    ' insert somewhere between
        newPos = newPos + 4
        For I = UBound(tBarIcon) To newPos + 1 Step -1
            tBarIcon(I) = tBarIcon(I - 1)
        Next
    End If
Else    ' custom placement, the actual position doesn't matter
    newPos = UBound(tBarIcon)
End If
With tBarIcon(newPos)
    .ID = inID
    .tDefault = False
    .tPosition = PosType
    .CurXY.X = X
    .CurXY.Y = Y
    .Size.X = Width
    .Size.Y = Height
    .tRgn = 0
End With
CalculateButtonRect
DoDrawTitleBar m_bIsActive, False, "addtoolbarbutton"
End Sub

Friend Sub DeleteToolBarButton(ByVal btnID As String)

If btnID = "" Then Exit Sub
Dim I As Integer, J As Integer, inID As String * 10
inID = btnID
For I = 4 To UBound(tBarIcon)
    If tBarIcon(I).ID = inID Then ' found it
        For J = I + 1 To UBound(tBarIcon) - 1
            tBarIcon(J) = tBarIcon(J + 1)
        Next
        ReDim Preserve tBarIcon(0 To UBound(tBarIcon) - 1)
    End If
    Exit For
Next
End Sub


Private Function ConvertHitTest(wParam As Long, inMenuLoop As Boolean) As Long

' function returns the hittest for our custom window
' wParam is the overriding return value if we do not get a valid hittest
Debug.Assert m_Position.wRgn <> 0

Dim mPts As POINTAPI, cRect As RECT
Dim I As Integer, rtnVal As Long, bGotHit As Boolean

GetCursorPos mPts   ' always use current X,Y coords
rtnVal = HTNOWHERE  ' default return value


' test to see if pt is even in our window....
If PtInRegion(m_Position.wRgn, mPts.X, mPts.Y) Then
    ' test the menubar
    If hRect_Menu.Bottom > hRect_Menu.Top Then
        ' check the menu
        If PtInRect(hRect_Menu, mPts.X, mPts.Y) Then
            rtnVal = c_MBar.GetHitTest(mPts.X - hRect_Menu.Left, mPts.Y - hRect_Menu.Top)
            If rtnVal Then
                m_Position.Tag = rtnVal
                rtnVal = HTMenuPlus
            Else
                rtnVal = HTCAPTION
            End If
        End If
    End If
    If rtnVal = HTNOWHERE Then
        ' not on menubar, let's look at the titlebar
        If PtInRegion(hRgn_Title, mPts.X, mPts.Y) Then
            rtnVal = HTCAPTION
            ' in the title bar area, check for hits on the title bar buttons
            For I = 0 To UBound(tBarIcon)
                With tBarIcon(I)
                    If .tRgn Then
                        If PtInRegion(.tRgn, mPts.X, mPts.Y) Then
                            If I < 4 Then ' min/max/close/sysmenu
                                If sysMenuEnabled(Choose(I + 1, smSysIcon, smClose, smMaximize, smMinimize)) Then
                                    rtnVal = Choose(I + 1, HTSYSMENU, HTCLOSE, HTMAXBUTTON, HTMINBUTTON)
                                Else
                                    rtnVal = -1
                                End If
                            Else    ' custom buttons
                                ''Debug.Print "hit test on custom button "; I - 4
                                rtnVal = HTMenuPlus + I
                            End If
                            Exit For
                        End If
                    End If
                End With
            Next
        End If
    End If
    If rtnVal = HTNOWHERE Then ' not on titlebar, see if in client area
' added functionality. Since windows with thin borders don't have much of a
' sizing edge, the optional property SizingHandle can be adjusted to give
' the user a much larger, user-defined, edge for sizing purposes...
' When this option is used and the window is sizable, we increase the
' actual sizing edge.
        GetRgnBox hRgn_Client, cRect
        If sysMenuEnabled(smSize) Then   'sizable
            ' if window is not sizable, no need tweaking hotspots
            With cRect
                If m_SizingBorder > m_BorderXY.Right Then .Right = .Right - m_SizingBorder - m_BorderXY.Right
                If m_SizingBorder > m_BorderXY.Bottom Then .Bottom = .Bottom - m_SizingBorder - m_BorderXY.Bottom
                If (m_tbarAlign Or 1) = m_tbarAlign Then ' vertical titlebar
                    If m_SizingBorder > m_BorderXY.Top Then .Top = .Top + m_SizingBorder - m_BorderXY.Top
                Else
                    If m_SizingBorder > m_BorderXY.Left Then .Left = .Left + m_SizingBorder - m_BorderXY.Left
                End If
            End With
        End If
        If PtInRect(cRect, mPts.X, mPts.Y) Then ' test for client region
            rtnVal = HTCLIENT
        ' not inside client region; let's look at borders
        ElseIf sysMenuEnabled(smSize) And IsZoomed(mainHwnd) = 0 Then ' if sizable, then continue
            ' check for hits on the borders
            If PtInRegion(m_Position.wRgn, mPts.X - m_SizingBorder, mPts.Y) = 0 Then
                ' on the left side of the window
                rtnVal = HTLEFT
            ElseIf PtInRegion(m_Position.wRgn, mPts.X + m_SizingBorder, mPts.Y) = 0 Then
                ' on the right side of the window
                rtnVal = HTRIGHT
            End If
            If PtInRegion(m_Position.wRgn, mPts.X, mPts.Y - m_SizingBorder) = 0 Then
                ' on the top side of the window, include topright & topleft
                rtnVal = HTTOP + ((rtnVal > 0) * (HTMAXBUTTON - rtnVal))
            ElseIf PtInRegion(m_Position.wRgn, mPts.X, mPts.Y + m_SizingBorder) = 0 Then
                ' on the bottom side of window, include botright & botleft
                rtnVal = HTBOTTOM + ((rtnVal > 0) * (HTMAXBUTTON - rtnVal))
            End If
        End If
    Else
        If rtnVal < 0 Then rtnVal = HTNOWHERE
    End If
End If
''Debug.Print "converted hittest to "; wParam; rtnVal
' return overriding value if no return value was calculated
If inMenuLoop Then
    If rtnVal = HTMenuPlus Then
        m_Position.HitTest = rtnVal
    Else
        m_Position.HitTest = 0
    End If