cmenuitems.cls

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

Public Property Get SystemMenu() As Long
' ========================================================================
' Returns the system menu handle
' ========================================================================
SystemMenu = hSysMenu
End Property

Public Property Get ShowTips() As Long
' ========================================================================
' Returns status of whether tips should be returned or not
' ========================================================================
ShowTips = TipCallBackProc
End Property

Public Function Tips(MenuID As Long, hMenu As Long) As String
' ========================================================================
' Function returns the menu items Tip as a string
' See GetMenuItem for more detailed information on referencing the gMenu collection
' System menu will provide the hMenu parameter of zero
' ========================================================================
On Error Resume Next
Dim mIndex As Integer
' see if we have this menu item cached
mIndex = cItems(MenuID & "." & hMenu)
If Err = 0 Then
    Tips = vItems(mIndex).Tip
    Exit Function
End If
' if not cached, then most likely an item in a child class
Tips = gMenus("g" & hMenu).Tips(MenuID, hMenu)
Err.Clear
'Debug.Print "Tips = "; Tips; "<"
End Function

Public Property Get ImageListObject() As Control
' ========================================================================
' Only used when automatically subclassing a MDI child in the SetMenu function
' This allows all MDI children to use same ImageList as MDI Parent
' ========================================================================
' return MDI Parent's imagelist control
     Set ImageListObject = imgList
End Property

Public Property Let hPrevProc(hProc As Long)
' ========================================================================
' Returns/sets the previous window procedure for the form
' ========================================================================
    PrevProc = hProc
End Property
Public Property Get hPrevProc() As Long
    hPrevProc = PrevProc
End Property

Public Function RestrictSize(lParam As Long, bSet As Boolean) As Boolean
' ========================================================================
' Function restricts the size of a window to that defined by the user
' ========================================================================

' lparam is pointer to a MinMax Structure
If bSet Then    ' setting the size restrictions
    CopyMemory uMinMax, ByVal lParam, Len(uMinMax)
Else            ' applying the size restrictions
    ' if the size wasn't set, bug out & let windows handle it
    ' note that uMinMax.ptMaxSize.X was set to -1 during class initialization
    If uMinMax.ptMaxSize.X < 0 Then Exit Function
    ' otherwise return the sizes the user defined
    CopyMemory ByVal lParam, uMinMax, Len(uMinMax)
    RestrictSize = True
End If
End Function

Public Function MenuSelected(Index As Long, hMenu As Long, lParam As Long) As Boolean
' ========================================================================
' See CreateSubMenu routine for more information....
' A little tricky. Remember that a menu class can create another menu class (child class) for
' generated menus created from list/combo boxes. If we didn't create the submenu ID passed here,
' then we don't process the menu command. If we did create a gMenu, then its data only exists
' in the gMenu collection (child class) not in this normal collection within this class.
' So we need to pass these parameters along to the child class. The child class menu items
' were created with 2 special flags to help update the list/combo box: gControl which is the
' handle to the list/combo box and gType which is the control's style.

' So what do we have?
' the gMenu special flag LIndex is the ListIndex value (this was added to the menu item caption)
' the gMenu item's gControl reference= hWnd to the list/combobox
' the gMenu item's gType reference= simple list/combo or multiselect listbox
' That's all we need to update the list/combobox

' This routine also processes the 7 custom menus
' ========================================================================

Dim mIndex As Long, pParam1 As Long, pParam2 As Long
Dim msgParam As String, sUserID As String, sDefValue As String
Dim I As Integer, sTarget As String, sValue As String, wCaption As String

' windows messages used to fire a click event on a list/combo box
Const CB_SETCURSEL As Long = &H14E
Const LB_SETCURSEL As Long = &H186
Const LB_SETSEL As Long = &H185
' the color dialog box constants used
Const CC_RGBINIT         As Long = &H1
Const CC_FULLOPEN        As Long = &H2
Const CC_ANYCOLOR        As Long = &H100

On Error Resume Next
If lParam Then    ' sent from parent class, otherwise it is zero when sent as a result of clicking on a menu
    mIndex = cItems(Index & "." & hMenu)        ' see if menu item in our collection
    If Err = 0 Then
        ' the menu exists in this child class
        MenuSelected = True
        'Debug.Print "Testing click on custom menu"; hMenu; Index
        ' the gMenu could be a list/combo box or a custom menu.
        ' we'll check for custom menu first
        SeparateCaption vItems(mIndex).Caption, "", wCaption, ""
        For I = 1 To 7  ' custom menus will have these undocumented tags
            sTarget = Choose(I, "LColor:", "LMonth:", "LState:", "LDay:", "LDate:", "LFont:", "LDrv:")
            ReturnComponentValue wCaption, sTarget, sValue
            If Len(sValue) Then Exit For
        Next
        If Len(sValue) Then ' we have a custom menu
            ' extract the user supplied ID
            ReturnComponentValue wCaption, "lvID:", sUserID
            ' build a reference to the user's cTip class
            Dim oTipClass As cTips
            CopyMemory oTipClass, TipCallBackProc, 4&
            ' simply send the menu selection to the class
            Select Case sTarget
                Case "LColor:"
                    ' if value is -1, then user wants a custom color
                    If Val(sValue) = -1 Then
                        Dim CC As CHOOSECOLORSTRUCT, cCusGray As Long, lGrays(0 To 15) As Long
                        ' API requires a value for the .lpCustColors property, so
                        ' instead of supplying all black values, we'll give some grays
                        For cCusGray = 240 To 15 Step -15
                           lGrays((cCusGray \ 15) - 1) = RGB(cCusGray, cCusGray, cCusGray)
                        Next
                        ' see if there was a checked color & if so, show that in color dialog
                        ReturnComponentValue wCaption, "LDefClr:", sDefValue
                        With CC         'set the flags
                          .hInstance = App.hInstance
                          If Val(sDefValue) > -1 Then   ' set checked color
                            .Flags = CC_RGBINIT
                            .rgbResult = Val(sDefValue)
                          Else                          ' not color set
                            .Flags = CC_ANYCOLOR
                          End If
                          ' finish up the structure & send to API
                          .Flags = .Flags Or CC_FULLOPEN
                          .lStructSize = Len(CC)
                          .hwndOwner = FormHwnd
                          .lpCustColors = VarPtr(lGrays(0))
                        End With
                        If ChooseColor(CC) = 0 Then
                            MenuSelected = False        ' if user cancelled out
                        Else
                            oTipClass.SendCustomSelection sUserID, "Color", CC.rgbResult
                        End If
                    Else
                        oTipClass.SendCustomSelection sUserID, "Color", Val(sValue)
                    End If
                Case "LDay:": oTipClass.SendCustomSelection sUserID, "WeekDay", Val(sValue)
                Case "LMonth:": oTipClass.SendCustomSelection sUserID, "Month", Val(sValue)
                Case "LState:": oTipClass.SendCustomSelection sUserID, "State", sValue
                Case "LDate:": oTipClass.SendCustomSelection sUserID, "DayOfMonth", CDate(sValue)
                Case "LFont:": oTipClass.SendCustomSelection sUserID, "Font", sValue
                Case "LDrv:": oTipClass.SendCustomSelection sUserID, "Drive", Left$(sValue, 3)
            End Select
            CopyMemory oTipClass, 0&, 4&
            Set oTipClass = Nothing
        Else    ' no custom menu, should be a list/combo box control then
            If IsNumeric(vItems(mIndex).gControl) = False Then Exit Function
            If vItems(mIndex).gControl = 0 Then Exit Function ' it is not a control
            If IsWindow(vItems(mIndex).gControl) = 0 Then Exit Function
            ReturnComponentValue wCaption, "LIndex:", sValue
            If vItems(mIndex).ControlType = 2 Then          ' style of control
                ' with multiselect listboxes, the listindex is passed as the
                ' 2nd parameter, otherwise listindex is passed as 1st one
                pParam2 = Val(sValue)
                ' if item was not selected, we will mutliselect it now
                ' otherwise it will no longer be selected (pParam1 = 0)
                If ((vItems(mIndex).Status And lv_mChk) <> lv_mChk) Then pParam1 = 1
            Else
                pParam1 = Val(sValue)
            End If
            If Err Then Exit Function      ' couldn't find it, bye-bye
            ' determine the proper message to send to the list/combobox & update the control
            Select Case vItems(mIndex).ControlType
            Case 0: msgParam = CB_SETCURSEL
            Case 1: msgParam = LB_SETCURSEL
            Case 2: msgParam = LB_SETSEL
            End Select
            With vItems(mIndex)
                SendMessage .gControl, msgParam, pParam1, ByVal pParam2
                ' the above will select/unselect the list/combobox item, but it does not fire a "Clicked" event for the item
                ' the next call fires the "Click" event. WM_Command wparam is LoWord of control ID, HiWord of message (1=list change)
                SendMessage GetParent(.gControl), WM_COMMAND, MakeLong(CInt(GetWindowLong(.gControl, GWL_ID)), 1), ByVal .gControl
            End With
        End If
    End If
Else   ' sent from the message processor
    ' pass the menu ID, submenu ID and ListIndex to the gMenu.
    ' If we don't have a gMenu, then error will just pass the command back to Windows
    MenuSelected = gMenus("g" & hMenu).MenuSelected(Index, hMenu, 1)
End If
Err.Clear       ' clear any errors
End Function

Public Sub GetMenuItem(ID As Long, hMenu As Long)
Dim MenuData As MenuComponentData, Index As Long
' ========================================================================
' Function pouplates a general use MenuComponentData structure with the requested menu item
' This is called each time a menu item is measured for display, selected, or unselected
' System menu will return a hMenu of zero
' ========================================================================

On Error Resume Next
XferMenuData = MenuData                        ' blank out the general use -- just in case
'Debug.Print "retrievining item for "; hMenu; ID
Index = cItems(ID & "." & hMenu)               ' find our copy in our array
If Err = 0 Then
    XferMenuData = vItems(Index)               ' and if so, then we set the general use structure
Else
    gMenus("g" & hMenu).GetMenuItem ID, hMenu   ' see if a child class has the item
End If
Err.Clear
End Sub

Public Sub UpdateMenuItems(hMenu As Long)
' ========================================================================
' General use. Update any menu items, do clean up, whatever.
' This routine called each time the user exits the menu loop.

' For now, the only needed action is to force a remeasure of the Sidebar, if it exists
' ========================================================================

Dim MIS As MENUITEMINFO_string, Looper As Integer
Dim pIndex As Long, mMode As Integer
Dim bUpdated As Boolean, nrMenus As Integer
Dim Index As Long
' first see if we have this panel in this form -- should never error
' cause one is always created; but just in case
On Error Resume Next
pIndex = cPanels("p" & hMenu)