cmenuitems.cls

Address Book implemented in VB 6,can be use for storing person information

                sTarget = StringFromBuffer(sTarget)
                If Len(sTarget) Then
                    If .Tip = "Network/Mapped Drive" Then
                        .Display = .Display & "  (" & sTarget & ")"
                    Else
                        .Display = .Display & " " & sTarget
                    End If
                End If
            End If
        End If
    End If
    ' Remove any other conflicting status codes for submenu items
    If ((.Status And lv_mSubmenu) = lv_mSubmenu) Then
        .HotKey = ""       ' no hotkeys displayed for submenus
        ' but allow everything else, including check marks if user wants them
    End If
End With
GetMeasurements:
If ((mComponent.Status And lv_mSBar) = lv_mSBar) = False Then   ' skip for sidebars (for now)
    ' =====================================================================
    ' Routine gets the meaurements of the submenu items
    ' =====================================================================
    Dim tDC As Long, tRect As RECT
    tDC = GetDC(FormHwnd)
    With mComponent
        'Debug.Print "measuring "; .Display
        ' ========================================================================
        ' Calculate heights needed
        ' ========================================================================
        ' supply the proper font for measuring
        If ((.Status And lv_mSep) = lv_mSep) Then   ' bar with text
            ApplyMenuFont 3, tDC                      ' use the smaller font for these
        Else         ' otherwise, use normal font or bold if needed
            ApplyMenuFont 1 + Abs(CInt((.Status And lv_mDefault) = lv_mDefault)), tDC
        End If
        ' now we calculate the height & width of the text needed
        If ((.Status And lv_mFont) = lv_mFont) Then ' an lvFonts custom menu
            sTarget = .Display
            ' with the DT_CALCRECT flag, no text is actually drawn, it only calculates the rectangle passed to it
            DrawText tDC, sTarget, Len(sTarget), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP
            ' store height/width for now, we'll use the largest when compared against the sample font
            .Dimension.X = tRect.Right
            .Dimension.Y = tRect.Bottom
            ApplyMenuFont 0, tDC    ' replace DC font
            ReturnComponentValue wCaption, "LFont:", sValue
            ' now create and load a "Sample" using the actual font name
            CreateDestroyMenuFont True, False, sValue
            ApplyMenuFont 6, tDC
            ' the word Sample is the hotkey
            sTarget = .HotKey
            DrawText tDC, sTarget, Len(sTarget), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP
            ' here we ue the largest setting between the non-sample font & sample font
            tRect.Right = tRect.Right + .Dimension.X
            If tRect.Bottom > .Dimension.Y Then tRect.Bottom = .Dimension.Y
        Else
            sTarget = .Display & .HotKey    ' want total width first
            ' with the DT_CALCRECT flag, no text is actually drawn, it only calculates the rectangle passed to it
            DrawText tDC, sTarget, Len(sTarget), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP
        End If
        If ((.Status And lv_mSep) = lv_mSep) = True And Len(.Display) = 0 Then
            tRect.Bottom = 4        ' standard separators will be hardcoded as a rect 4 pixels high
            .Dimension.X = tRect.Right
        Else
            ' give a 1 pixel separation top/bottom from next menu items
            ' this is more for icons then the text
            If ((.Status And lv_mSep) <> lv_mSep) Then
                ' ensure height is at least 16 + 4 pixel edge for icons
                ' -- 16 for icon, 1 pix for frame, 1 pix separation btwn frame and icon
               If tRect.Bottom < 20 Then tRect.Bottom = 20
            End If
            ' 20 pixel buffer on both sides of caption for checks/icons & submenu arrows
            .Dimension.X = tRect.Right + 40
        End If
        .Dimension.Y = tRect.Bottom + 2
        ApplyMenuFont 0, tDC ' return to default menu font
    End With
    ReleaseDC FormHwnd, tDC
End If

DoCustomMenus:
' ========================================================================
' Calls function to create submenus if this item is ref'ing list/combobox
' or one of the several custom menus (lvColors, lvDrives, etc)
' ========================================================================
With mComponent
    ' for custom menus, we look for these flags in the caption
    For IdX = 1 To 7
        sTarget = Choose(IdX, "lvColors:", "lvMonths:", "lvDays:", "lvStates:", "lvMonth:", "lvFonts:", "lvDrives:")
        ReturnComponentValue wCaption, sTarget, sValue
        If Len(sValue) Then Exit For
    Next
    If Len(sValue) Then
        ' one of the custom tags was found and we will process that
        CreateSubMenuCustom MenuID, menuPos, hMenu, NewSubmenuID, sTarget, sValue, .Tip
        .Status = .Status Or lv_mCustom ' flag to force reprocess if shown again
    Else    ' otherwise we test to see if this will ref a combo/listbox
        If .hControl Then   ' call function to create a new submenu on the fly
            CreateSubMenu MenuID, menuPos, hMenu, .ControlType, .hControl, NewSubmenuID, wCaption
        End If
    End If
    If NewSubmenuID Then ' only update following if a submenu was created
        .Status = .Status Or lv_mSubmenu
        If Len(.HotKey) Then
            ' if the menu item had a displayed hotkey, we need to remove
            ' the width it was taking up 'cause submenu menus don't have 'em
            sTarget = .HotKey
            tDC = GetDC(FormHwnd)
            ApplyMenuFont 1, tDC
            ' with the DT_CALCRECT flag, no text is actually drawn, it only calculates the rectangle passed to it
            DrawText tDC, sTarget, Len(sTarget), tRect, DT_CALCRECT Or DT_LEFT Or DT_SINGLELINE Or DT_NOCLIP
            .Dimension.X = .Dimension.X - tRect.Right
            ApplyMenuFont 0, tDC
            ReleaseDC FormHwnd, tDC
        End If
        .HotKey = ""
    End If
End With
DoIconReference:
' ref to menu image. This needs to be rechecked every single time to ensure the handle for the
' source image didn't change. FYI: ImageList's ExtractIcon function will change this handle
  With mComponent
    ' excpetions are separator bars (don't have icons) and custom menus where icons already determined
    .ShowBKG = False
    If bChildClass = False And ((.Status And lv_mSep) <> lv_mSep) Then
        .Icon = CStr(ValidateImage(wCaption, IdX))
        If .Icon = "0" Then
            .Icon = ""
        Else
            ' see if image is forced to not be transparent
            ' << n/a for Icons, only valid for Bitmaps (IDX=1) >>
            ReturnComponentValue wCaption, "IMGBKG", sValue
            If Len(sValue) And IdX = 1 Then .ShowBKG = True
        End If
    End If
  End With
' ========================================================================
' The End.  Simply update the array and index
' ========================================================================
If NewIndex = 0 Then                        ' new menu item, we need an index to the array entry
    NewIndex = UBound(vItems) + 1
    ReDim Preserve vItems(0 To NewIndex)
    cItems.Add NewIndex, MenuID & "." & hMenu
End If
mComponent.ID = MenuID
vItems(NewIndex) = mComponent
' if a gMenu or custom menu was created, we need to cross-reference it
' by the new submenu handle in order for the routines herein to correctly
' identify the menu item
If NewSubmenuID Then cItems.Add NewIndex, NewSubmenuID & "." & hMenu
ItemHeight = mComponent.Dimension.Y     ' return item height
'Debug.Print FormHwnd; " current class vArray count="; UBound(vItems)
End Sub

Private Sub GetPanelMetrix(hMenu As Long, bIsSysMenu As Boolean, _
    Items2Check() As Long, PageBreaks() As Long)
' ========================================================================
' Function primarily tallies up the overall height of menu items and bumps
' that up against the existing height of a sidebar (if used). This will
' determine if we need to reprocess a sidebar.
' Function also calculates menu item widths and offsets to display a more
' uniform menu across all Window systems.
' ========================================================================

Dim Looper As Integer, lItem As Long
Dim NewIndex As Long, NextPage As Long
Dim IdxStart As Long, IdxStop As Long
Dim tIndex As Integer, lSideBar As Long
Dim Xoffset As Integer, Win98MEoffset As Integer
Dim pData As PanelData
Dim maxHeight As Integer, MaxWidth As Integer
Dim bHasTabs As Boolean, bHasSubs As Boolean
Dim bHasHotKey As Boolean, bHideSidebarCheck As Boolean
Dim bNonSbar As Boolean, bReprocessSideBar As Boolean

On Error Resume Next
' The Win98MEoffset is used currently for Win98 & WinME. These systems seem
' to tack on some extra pixels to menu items. We will account for those pixels
Win98MEoffset = modMenus.Win98MEoffset
' See if the menu panel already exists
NewIndex = cPanels("p" & hMenu)
pData.SubmenuID = hMenu
If Err Then
    NewIndex = 0
    Err.Clear
Else
    ' we copy the existing sidebar reference to the new pData structure
    ' otherwise we lose it & can't delete it when needed
    pData.PanelIcon = vPanels(NewIndex).PanelIcon
End If
IdxStart = 1                    ' range of items to apply offsets
IdxStop = UBound(Items2Check)
Items2Check(0) = 0              ' reset sidebar ID if any
' here we set a measuring point for the sidebar if we have multiple
' columns to display. The total height at this point will be the sidebar height
If UBound(PageBreaks) > 1 Then NextPage = 2
' now loop thru the subset, extracting key values

If UBound(PageBreaks) > 1 Then NextPage = 2
' now loop thru the subset, extracting key values

For Looper = 1 To UBound(Items2Check)
    tIndex = cItems(Items2Check(Looper) & "." & hMenu)
    With vItems(tIndex)
        ' we don't add or include sidebars in any of our calculations
      If ((.Status And lv_mSBar) <> lv_mSBar) Then
        If (Items2Check(Looper) = PageBreaks(NextPage)) And NextPage > 1 Then
            ' we hit a column break
            IdxStop = Looper - 1     ' reset last item to apply offsets
            GoSub UpdateItemOffsets  ' apply the offsets
            bHasSubs = False         ' reset flag
            bHasHotKey = False       ' reset flag
            MaxWidth = 0             ' reset
            ' here we store the MaxHeight value to use for the sidebar
            If NextPage = 2 Then Items2Check(0) = maxHeight
            ' now we set the next page to stop and apply offsets
            If NextPage > UBound(PageBreaks) Then NextPage = 0 Else NextPage = NextPage + 1
            IdxStart = Looper        ' reset start & stop indexes
            IdxStop = UBound(Items2Check)
            maxHeight = 0
        End If
            ' keep track of whether or not the panel has any icons at all,
            ' whether or not it is a system menu panel and the widest item on the panel
            If Len(.Icon) Then pData.HasIcons = True
            If ((.Status And lv_mSubmenu) = lv_mSubmenu) Then bHasSubs = True
            If .ID >= &HF000& And ((.Status And lv_mSubmenu) <> lv_mSubmenu) Then pData.IsSystem = True
            If Len(.HotKey) Then bHasHotKey = True
            ' running sum of estimated menu panel width & height
            If .Dimension.X > MaxWidth Then MaxWidth = .Dimension.X
            maxHeight = maxHeight + .Dimension.Y
        'End If
      End If
    End With
Next

If Items2Check(0) > 0 Then maxHeight = Items2Check(0)
If NextPage = 0 Then GoSub UpdateItemOffsets            ' apply offsets
' update flag to indicate this submenu is the system menu
If bIsSysMenu Then pData.IsSystem = True
' Now we append/update the panel array and collection
If