cmenuitems.cls

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

    For Looper = 1 To UBound(PageIDs)
        ReDim MI(0 To 1023)
        MII.cch = UBound(MI)
        MII.fMask = MIIM_TYPE
        MII.fType = 0
        GetMenuItemInfo hSubMenu, PageIDs(Looper), False, MII
        If Looper = 1 Then
            MII.fType = MII.fType Or MF_OWNERDRAW Or MF_MENUBREAK
        Else
            MII.fType = MII.fType Or MF_OWNERDRAW Or MF_MENUBARBREAK
        End If
        SetMenuItemInfo hSubMenu, PageIDs(Looper), False, MII
    Next
End If
' now add any cx offsets to each of these menu items & calculate sidebar height
GetPanelMetrix hSubMenu, bIsSysMenu, Items2Check(), PageIDs()
Erase Items2Check
Erase PageIDs
DrawMenuBar FormHwnd       ' not needed yet, next version will take control of the menu bar
End Function

Private Sub GetMenuMetrix(Caption As String, Status As Long, NewType As Long, NewState As Long, hMenu As Long, _
    MenuID As Long, menuPos As Integer, IsSideBar As Boolean, _
    ItemHeight As Long, NewSubmenuID As Long, AltMenuSource As Long)
' ========================================================================
' Function to parse caption components, determine menu attributes,
' calculate menu item widths/heights, build gMenus etc
' ========================================================================
Dim bChildClass As Boolean
Dim IdX As Integer, NewIndex As Integer
Dim wCaption As String, sTarget As String
Dim sValue As String, CachedCaption As String
Dim mComponent As MenuComponentData, frmObject As Control

On Error Resume Next
' we'll see if the menu item is already in our local array
NewIndex = cItems(MenuID & "." & hMenu)
IsSideBar = False       ' reset
NewSubmenuID = 0        ' reset
If AltMenuSource And Len(Caption) > 0 Then
' user is using a listbox to store caption flags
    'these need to be rechecked each time to see if the flags in the
    ' listbox has changed
    Dim sHotKey As String
    SeparateCaption Caption, CachedCaption, wCaption, sHotKey
    ReturnComponentValue wCaption, "Cache:", sValue
    If Len(sValue) Then
        mComponent.Cached = Caption
        IdX = SendMessage(AltMenuSource, LB_GETTEXTLEN, Val(sValue), ByVal 0&)
        sTarget = String$(IdX, 0)
        SendMessage AltMenuSource, LB_GETTEXT, Val(sValue), ByVal sTarget
        Caption = CachedCaption & StringFromBuffer(sTarget)
        If Len(sHotKey) Then Caption = Caption & vbTab & sHotKey
    End If
End If
If NewIndex > 0 Then
    ' we have a copy of it, is it the same? Otherwise, we measure everything again
    mComponent = vItems(NewIndex)
    ' captions with OwnerDrawn menus in NT disappear after we take ownership
    ' So our adjusted logic: if it's blank and we have in our array, then it hasn't changed.
    If StrComp(Caption, mComponent.Caption, vbBinaryCompare) = 0 Or Caption = "" Then
        ' it's the same, but if the following menu item options occur
        ' we remeasure because these could affect height/width of an item
        ' We can check for instances when we don't need to remeasure based on default status
        ' 1. If item is not default and it was before but isn't now, menu size is ok
        ' 2. If the default menu item status didn't change
        Caption = mComponent.Caption
        SeparateCaption Caption, "", wCaption, ""
        If (((Status And lv_mDefault) = lv_mDefault) Or ((mComponent.Status And _
            lv_mDefault) = (Status And lv_mDefault))) Then
            With mComponent
                ' here we remove the previous status and add them back if needed
                If ((.Status And lv_mDisabled) = lv_mDisabled) Then .Status = .Status And Not lv_mDisabled     ' remove the disabled property
                If ((.Status And lv_mChk) = lv_mChk) Then .Status = .Status And Not lv_mChk    ' remove the checked property
                If ((.Status And lv_mDefault) = lv_mDefault) Then .Status = .Status And Not lv_mDefault    ' remove the default item property
                .Status = .Status Or Status     ' reset to passed properties
            End With
            ' Still not out of the woods. If the menu item references a
            ' list/combobox, then we need to redo its submenu since the
            ' list/combobox contents/listindex could have changed
            ' Also if this was a custom menu, we redo it since custom menus
            ' have no permanent properties to refer back to.
            If mComponent.hControl = 0 And ((mComponent.Status And lv_mCustom) <> lv_mCustom) Then
                If ((mComponent.Status And lv_mSBar) = lv_mSBar) Then
                    IsSideBar = True
                    mComponent.HotKey = ""
                Else
                    ' No major change. Finalize some properties/attributes and return
                     If ((mComponent.Status And lv_mSep) = lv_mSep) Then NewType = NewType Or MF_SEPARATOR
                End If
                ' we got all the stuff we need and don't need to process much further
                ItemHeight = mComponent.Dimension.Y ' return HT of item
                vItems(NewIndex) = mComponent       ' refresh array item
                GoTo DoIconReference                ' ensure image handle didn't change
            Else    ' menu refs a list/combobox, so we redo it
                GoTo DoCustomMenus   ' skip majority of the process
            End If
        End If
    End If
End If
With mComponent
    .Caption = Caption      ' store original caption
    .Index = menuPos        ' zero-based position on submenu
    .Status = Status        ' all status, mine & windows
    SeparateCaption Caption, .Display, wCaption, sValue
    .Display = Replace$(.Display, "& ", "&& ") ' hack to display "&" in captions
    If Len(sValue) Then .HotKey = sValue
    ' since anything can have Tips, let's look for Tips first
    ' note: tips aren't normally included in Separators, but are allowed if
    '       manually entered in the menu caption
    ReturnComponentValue wCaption, "TIP:", sValue
    If Len(sValue) Then
        .Tip = sValue
    Else
        ' child classes may have this property set & if so, use it
        .Tip = tipDefault
    End If
    ReturnComponentValue wCaption, "SIDEBAR", sValue
    If Len(sValue) Then
        ' for sidebars we only accept the first one and it must be
        ' the first item in the menu panel, otherwise we force it to
        ' look and act like a separator bar
        If menuPos = 0 Then
            .Status = 0
            If ((NewType And MF_SEPARATOR) = MF_SEPARATOR) Then NewType = NewType And Not MF_SEPARATOR
            If ((NewState And MF_DISABLED) = MF_DISABLED) Then .Status = .Status Or lv_mDisabled
            If ((NewState And MF_CHECKED) = MF_CHECKED) Then .Status = .Status Or lv_mChk
            .Status = .Status Or lv_mSBar   ' flag indicating sidebar item
            ReturnComponentValue wCaption, "SBDisabled", sValue
            If Len(sValue) Then
                .Status = .Status Or lv_mDisabled
                NewState = NewState Or MF_DISABLED
            End If
            .HotKey = "Remeasure"       ' not displayed on sidebars
            IsSideBar = True            ' flag to return
            GoTo Check4ControlReference ' process sidebar information
        Else    ' another sidebar on same menu, we can't let it go
            .Display = "" ' reset caption which forces it to be a separator
        End If
    End If
    If Len(.Display) Then   ' see if the caption is a separator bar
        If Left$(.Display, 1) = "-" Then
            ' text separator bar -- update return status
            .Display = Mid$(.Display, 2)
            NewType = NewType Or MF_SEPARATOR
        End If
    Else
        ' no caption, then assume a separator bar
        NewType = NewType Or MF_SEPARATOR
    End If
    ' finally, we finalize the separator bar
    If ((NewType And MF_SEPARATOR) = MF_SEPARATOR) Then
        ' finish processing separator bar & then skip the rest
        .Status = 0
        NewState = 0
        ReturnComponentValue wCaption, "RAISED", sValue
        If Len(sValue) Then .Status = .Status Or lv_mSepRaised
        .Status = .Status Or lv_mSep Or lv_mDisabled   ' separator bar flag
        .HotKey = ""                    ' these can't have hotkeys
        .Icon = ""                       ' these can't have icons
        .hControl = 0                   ' these can't ref list/comboboxes
        NewState = NewState Or MF_DISABLED
        GoTo GetMeasurements
    Else    ' see if the menu item will be bolded
        ReturnComponentValue wCaption, "DEFAULT", sValue
        If Len(sValue) Then .Status = .Status Or lv_mDefault
    End If
    If Len(wCaption) = 0 Then GoTo GetMeasurements
    
    ' let's finish parsing out the working caption
    ' if a hotkey was provided in the coded caption, it overwrites
    ' the actual Menu Editor supplied hotkey, if any
    ReturnComponentValue wCaption, "HotKey:", sValue
    If Len(sValue) Then .HotKey = sValue
    ' now see if a combo/listbox will be used to create another submenu (gMenus)
    ' but if the menu item already has a submenu that isn't a gMenu,
    ' we don't allow it. We will not replace existing submenus.
    If ((.Status And lv_mSubmenu) = lv_mSubmenu) And .hControl <> 0 _
       Or ((.Status And lv_mSubmenu) <> lv_mSubmenu) Then
        ReturnComponentValue wCaption, "LB:", sValue
        If Len(sValue) Then     ' a combo box was chosen
            .ControlType = 1    ' flag indicating listbox, otherwise combobox
        Else    ' if not, test for a listbox
            ReturnComponentValue wCaption, "CB:", sValue
        End If
        If Len(sValue) Then ' if either was chosen, return handle to that control
            If IsNumeric(sValue) Then   ' ensure it's a valid window!
                If IsWindow(CLng(sValue)) Then .hControl = CLng(sValue)
            Else    ' control name passed vs its handle, validate it
                Set frmObject = SplitControlIndex(sValue)
                If Not frmObject Is Nothing Then
                    .hControl = frmObject.hWnd
                    Set frmObject = Nothing
                End If
            End If
        End If
    End If
    
Check4ControlReference:
    ' now we process gMenu items since this class can also be a child class
    ' containing gMenu items. gMenu items will have the undocumented tag gControl
    ReturnComponentValue wCaption, "gControl:", sValue
    If Len(sValue) Then
        bChildClass = True
        .gControl = Val(sValue)
        ' for gMenus that refer to list/combo boxes, this will be the type
        ReturnComponentValue wCaption, "gType:", sValue ' list or combo box
        If Len(sValue) Then .ControlType = Val(sValue)
        ReturnComponentValue wCaption, "LColor:", sValue 'color menu
        If Len(sValue) Then .Status = .Status Or lv_mColor
        ReturnComponentValue wCaption, "LFont:", sValue ' font menu
        If Len(sValue) Then .Status = .Status Or lv_mFont
        ReturnComponentValue wCaption, "LState:", sValue ' state menu
        If Len(sValue) Then .HotKey = sValue
        ReturnComponentValue wCaption, "gEXE:", sValue ' filename item
        If Len(sValue) Then
            ' the Icon becomes the filename so DrawMenuIcon knows to
            ' look for the icon in the file
            .Icon = GetShortFileName(sValue & .Display)
            ' here we just standardize what's displayed on the menu
            sValue = StripFile(.Display, "E")
            .Display = StripFile(.Display, "m")
            ' change all LCase filenames to UCase. But if mixed case, leave as is
            If StrComp(LCase(.Display), .Display, vbBinaryCompare) = 0 Then .Display = UCase(.Display)
            .Display = .Display & "." & LCase(sValue)
            ' a nice touch. We add the file description as a tip
            .Tip = GetFileDescription(.Icon)
            If .Tip = "" Then .Tip = tipDefault
        End If
        ReturnComponentValue wCaption, "LDrv:", sValue  ' drives menu
        If Len(sValue) Then
            IdX = InStr(sValue, "\")
            If IdX Then .Icon = Left$(sValue, IdX) Else .Icon = sValue  ' the value will be A:\, C:\, etc
            If .Tip = "Removable Media" Then
                ' for floppies, we get the cached icon. Otherwise program will
                ' check the floppy each time it draws this icon--unnecessary
                ' repeated reads to the floppy & time-consuming, especially if it's empty
                .Icon = GetFloppyIcon(.Icon)
                .Display = .Display & " Removable"
            Else    ' non floppies. We'll include the volume name with the drive
                If Len(.Icon) > IdX Then IdX = 1 Else IdX = 0
                sTarget = String$(255, 0)
                sValue = String$(55, 0)
                GetVolumeInformation .Icon, sTarget, 255, 0, 0, 0, sValue, 55