clsframecontrol.cls

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

End Type
Private Type MENUITEMINFO        ' used to retrieve/store menu items
     cbSize As Long              ' this structure is used with all O/S
     fMask As Long
     fType As Long
     fState As Long
     wID As Long
     hSubMenu As Long
     hbmpChecked As Long
     hbmpUnchecked As Long
     dwItemData As Long
     dwTypeData As Long 'String
     cch As Long
End Type
Private Type WindowIcon         ' Custom, used to track creation of 16x icons
    Handle As Long
    ToBeDeleted As Boolean
    hOriginalIcon As Long
    ToBeReplaced As Boolean
End Type
Private Type tbarIconsData      ' Custom, user-defined titlebar buttons
    tRgn As Long
    tDefault As Boolean
    tState As Integer   '0=up, 1=down, 2=disabled
    tPosition As Integer '0=default, 1=lockX, 2=lockY, 128=no frame
    CurXY As POINTAPI   ' most current X,Y for a non-static, no-default custom button
    Size As POINTAPI    ' height & width of a custom button
    toolTip As String * 255
    ID As String * 10
    ' more later
End Type
Private Type MOVESIZE       ' Custom, used to track core window data
    wRgn As Long
    wRect As RECT
    mPts As POINTAPI
    HitTest As Long
    Action As Long
    Tag As Long
End Type

' *** class if created must be properly terminated to destroy memory objects it creates
Private WithEvents c_MBar As clsMenuBarControl
Attribute c_MBar.VB_VarHelpID = -1

' *** These 3 must be destroyed to prevent memory leaks
Private m_DCuser As Long        ' DC passed to user for custom drawing
Private m_bmpTitlebar As Long   ' workarea passed to user for drawing entire titlebar region
Private m_bmpMenuBar As Long    ' workarea passed to user for drawing background menubar

' *** Handle in next UDT if .ToBeDeleted=TRue must be destroyed to prevent memory leaks
Private m_SmallIcon As WindowIcon   ' tracks handle for small icon & delete state
' *** Region in next UDT must be destroyed to prevent memory leaks
Private m_Position As MOVESIZE      ' tracks window size, hittest & current action

' *** Each region in UDT array on next line must be destroyed to prevent memory leaks
Private tBarIcon() As tbarIconsData ' collection of titlebar buttons (min/max/close, etc)
Private m_OriginalStyle As Long     ' used to restore original GWL_STYLE
Private m_OriginalStyleEX As Long   ' used to restore original GWL_EXSTYLE
Private m_CaptionSize As Integer    ' height of titlebar (not including menubar)
Private m_IconCX As Long            ' height of titlebar buttons
Private m_IconCY As Long            ' height of titlebar buttons
Private m_bLockWindow As Boolean    ' used to prevent sending style changes to subclassed window
Private m_InTransition As Boolean   ' used when minimizing/maximizing/restoring
Private m_Terminating As Boolean    ' flag to indicate subclassing terminating
Private m_bIsActive As Boolean      ' track if window is active per O/S
Private m_fColor(0 To 1) As Long    ' active/inactive font color
Private m_tbarFarExtent As Integer  ' caption right offset = left edge of nearest button
Private m_tbarNearExtent As Integer ' caption left offset = right edge of window icon
Private hOldWndProc As Long         ' subclassed window's previous GWL_WNDPROC
Private mainHwnd As Long            ' subclassed window handle

' ------------- PROPERTY VARIABLES -----------
Private m_Font As Long  ' title bar font (LOGFONT)
Private m_SizingBorder As Byte  ' width/height of invisible grab handles
Private m_BorderXY As RECT      ' width/height of 4 border edges (all can be different)
Private m_BorderStyle As Integer ' similar to VB's BorderStyle
Private m_tbarAlign As Integer  '0=horizonal,1=vertical,2=caption centered
Private m_bHideInactiveBtns As Boolean  ' hide disabled buttons vs showing as disabled
Private m_sysMenu As Integer    ' used to track user-opted disabling of system menu items
Private m_KeepActive As Integer     ' option to show as active vs inactive (same thread)
    '0=current thread;1=other thread; 2=option is active,4=thread only,8=all threads
' ------------- REGIONS/RECTS USED FOR HITTEST & PAINTING ------------
' *** These next 3 must be destroyed to prevent memory leaks
Private hRgn_Client As Long
Private hRgn_Title As Long
Private hClipRgn As Long
Private hRect_Menu As RECT

Friend Property Get MenuBar() As clsMenuBarControl
If c_MBar Is Nothing Then   ' create new menubar class if needed
    Set c_MBar = New clsMenuBarControl
End If
Set MenuBar = c_MBar
End Property

' -------------------------- CLASS ADJUSTBLE PROPERTIES

Friend Property Get sysMenuEnabled(mnuIndex As SysMenuItemConstants) As Boolean
If mnuIndex < 0 Or mnuIndex > smSysIcon Then Exit Property
' function returns whether or not a single system menu item is enabled
sysMenuEnabled = Not ((m_sysMenu Or mnuIndex) = m_sysMenu)
End Property
Friend Property Let sysMenuEnabled(mnuIndex As SysMenuItemConstants, isEnabled As Boolean)
' function sets multiple system menu items at once using the OR operand
Dim tIndex As Long
Dim lIndex As Long
Dim exStyle As Long, bToggleVisibility As Boolean

lIndex = mnuIndex ' use as a guide
Do Until lIndex = 0
    ' test to see which were sent to this routine
    If (lIndex Or smClose) = lIndex Then
        tIndex = smClose    ' add/remove close function
    ElseIf (lIndex Or smMaximize) = lIndex Then
        tIndex = smMaximize ' add/remove maximize function
    ElseIf (lIndex Or smMinimize) = lIndex Then
        tIndex = smMinimize ' add/remove minimize function
    ElseIf (lIndex Or smMove) = lIndex Then
        tIndex = smMove ' add/remove move function
    ElseIf (lIndex Or smSize) = lIndex Then
        tIndex = smSize ' add/remove sizing function
    ElseIf (lIndex Or smSysIcon) = lIndex Then
        tIndex = smSysIcon ' add/remove sizing function
    Else    ' stop when all have been done or invalid entry passed
        lIndex = 0
    End If
    If lIndex Then
        If isEnabled Then   ' enable items
            ' when enabled, we remove their flag from the friend variable
            If (m_sysMenu Or tIndex) = m_sysMenu Then
                m_sysMenu = m_sysMenu And Not tIndex
            End If
        Else    ' when disabled we add the flag
            m_sysMenu = m_sysMenu Or tIndex
        End If
        ' remove the tested item from the guide & continue on
        lIndex = lIndex And Not tIndex
    End If
Loop
' settings can be cached before window sublcassed
If mainHwnd Then    ' subclassed & apply now; otherwise apply later
    TweakSysMenu False      ' disable items on the system menu
    CalculateButtonRect     ' adjust button regions as needed
    DoDrawTitleBar m_bIsActive, False, "sysmenuenabled" ' redraw window as needed
End If
End Property

Friend Function SetHideDisabledBtns(bSet As Boolean, isHidden As Boolean) As Boolean
' returns whether disabled buttons are hidden or displayed
If bSet Then
    m_bHideInactiveBtns = isHidden
    If mainHwnd Then
        CalculateButtonRect   ' disable/hide button regions
        DoDrawTitleBar m_bIsActive, False, "hidedisabledbtns" ' redraw as needed
    End If
Else
    SetHideDisabledBtns = m_bHideInactiveBtns
End If
End Function

Friend Property Set Font(newFont As StdFont)
' creates a logical font from a passed standard font
Dim nFont As LOGFONT
If m_Font Then DeleteObject m_Font  ' delete previous font if needed
If newFont Is Nothing Then          ' use default menubar font
    Dim ncm As NONCLIENTMETRICS
    ncm.cbSize = Len(ncm)
    ' this will return the system menu font info
    SystemParametersInfo 41, 0, ncm, 0
    nFont = ncm.lfCaptionFont
    nFont.lfCharSet = 1             ' kinda needed for vertical fonts
    m_Font = CreateFontIndirect(nFont)  ' create the test font
    ' test the font to ensure it cnan be rotated; required for this class
    GetGDIObject m_Font, Len(nFont), nFont
    If nFont.lfCharSet = 0 Then ' nope, can't be rotated select one that can
        nFont.lfFaceName = "Tahoma" & String$(32, 0)
    End If
    DeleteObject m_Font             ' delete the test font
Else
    ' build logical font attributes from standard font
    With newFont
        nFont.lfFaceName = .Name & String$(32, 0)
        nFont.lfHeight = (.Size * -20) / Screen.TwipsPerPixelY
        nFont.lfItalic = Abs(.Italic)
        nFont.lfStrikeOut = Abs(.Strikethrough)
        nFont.lfUnderline = Abs(.Underline)
        nFont.lfWeight = Abs(.Bold) * 300 + 400
    End With
End If
nFont.lfCharSet = 1 ' needed for vertical fonts
If (m_tbarAlign Or 1) = m_tbarAlign Then
    ' vertical title bar; make 90 degrees
    nFont.lfOrientation = 900
    nFont.lfEscapement = 900
End If
m_Font = CreateFontIndirect(nFont)  ' now create the actual logical font
' redraw title bar
If mainHwnd Then
    MeasureCaption
    'DoDrawTitleBar m_bIsActive, False, "font"
End If
End Property

Friend Property Get Font() As StdFont
' routine returns a standard font from a logical font
Dim tFont As StdFont, nFont As LOGFONT

' if we don't have a font yet, pass the standard menu font
If m_Font = 0 Then Set Font = Nothing

' begin building the font attributes
GetGDIObject m_Font, Len(nFont), nFont
Set tFont = New StdFont
With tFont
    If InStr(nFont.lfFaceName, Chr$(0)) Then
        .Name = Left$(nFont.lfFaceName, InStr(nFont.lfFaceName, Chr$(0)) - 1)
    Else
        .Name = nFont.lfFaceName
    End If
    .Bold = nFont.lfWeight > 400
    .Italic = nFont.lfItalic <> 0
    .Underline = nFont.lfUnderline <> 0
    .Strikethrough = nFont.lfStrikeOut <> 0
    If nFont.lfHeight < 0 Then
        .Size = (nFont.lfHeight * Screen.TwipsPerPixelY) / -20
    Else
        .Size = 8.25
    End If
End With
On Error Resume Next ' just in case user call property without Set keyword
Set Font = tFont
End Property

Friend Function SetCenterCaption(bSet As Boolean, isCentered As Boolean) As Boolean
' optional centering of titlebar caption
If bSet Then
    m_tbarAlign = m_tbarAlign Or 2
    If Not isCentered Then m_tbarAlign = m_tbarAlign And Not 2
    ' redraw titlebar as needed
    If mainHwnd Then DoDrawTitleBar m_bIsActive, False, "titlecentered"
Else
    SetCenterCaption = ((m_tbarAlign Or 2) = m_tbarAlign)
End If
End Function
Friend Function SetVerticalCaption(bSet As Boolean, isVertical As Boolean) As Boolean
' optional vertical title bar (basic window frame only; not custom)
If bSet Then
    m_tbarAlign = m_tbarAlign Or 1
    If Not isVertical Then m_tbarAlign = m_tbarAlign And Not 1
    m_bLockWindow = True    ' prevent next line from triggering repaint
    Set Font = Font         ' toggle vertical/horizontal
    m_bLockWindow = False   ' allow repainting/resizing
    If mainHwnd Then
        SetRect m_Position.wRect, 0, 0, -1, -1      ' force complete recalc
        AdjustImplementSize False
        'UpdateWindowStyles False, False, -3, 0  ' trigger resize/repaint
    End If
Else
    SetVerticalCaption = ((m_tbarAlign Or 1) = m_tbarAlign)
End If
End Function

Friend Function SetInTaskBar(bSet As Boolean, AddToTaskBar As Boolean) As Boolean
' place window in taskbar or remove from taskbar
Dim exStyle As Long
If bSet Then
    ' place window in taskbar or remove from taskbar
    Dim bToggleVisibility
    If mainHwnd Then    ' not subclassed yet
        exStyle = GetWindowLong(mainHwnd, GWL_EXSTYLE)
        bToggleVisibility = ((GetWindowLong(mainHwnd, GWL_STYLE) And WS_VISIBLE) = WS_VISIBLE)
    End If
    If AddToTaskBar Then 'put in taskbar
        If mainHwnd Then    ' subclassed, so let's do it
            If (exStyle Or WS_EX_APPWINDOW) <> exStyle Then ' not already there
                If bToggleVisibility Then ShowWindow mainHwnd, 0
                SetWindowLong mainHwnd, GWL_EXSTYLE, exStyle Or WS_EX_APPWINDOW
                SetSmallIcon
                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 = 2
        End If