// **************************************************************************** // // ** ** // // ** Class : cPopupMenu ** // // ** ** // // ** Purpose : Owner-draw popup menu ** // // ** ** // // ** Author : Ulbe Stellema ** // // ** Data Access Worldwide ** // // ** ** // // ** Date : April 1, 2000 ** // // ** ** // // **************************************************************************** // Define DDDESKTOP For -1 Define DDCLIENTAREA For -2 Define DDSELF For -3 Use DfAbout.pkg Use cCollection.pkg Use cPopupMenuItem.pkg Class cPopupMenu Is A cWinControl // Procedure : Construct_Object // Purpose : Object constructor Procedure Construct_Object Integer iResult Handle hMenu Set External_Class_Name "DFPopupMenu" To "static" Forward Send Construct_Object // Owner draw messages Set External_Message WM_MEASUREITEM To Msg_MeasureItem Set External_Message WM_DRAWITEM To Msg_DrawItem Set External_Message WM_MENUCHAR To Msg_MenuChar // Menu messages Set External_Message WM_MENUSELECT To Msg_MenuSelect Set External_Message WM_COMMAND To Msg_Command Set External_Message WM_INITMENUPOPUP To Msg_InitMenuPopup Set External_Message WM_UNINITMENUPOPUP To Msg_UninitMenuPopup // Public properties Property Boolean pbShortcutMenu True Property Boolean pbAutoLocate True Property Handle phoDestination 0 Property Handle phoImageList 0 Property Handle phoItems 0 // Private properties Property Handle Private.phMenu 0 Property Handle Private.phoOldItem 0 Property Boolean Private.pbActivateFirst False // Create the menu Move (CreatePopupMenu()) To hMenu If (hMenu = 0) Error 500 (FormatMessage(GetLastError())) Set Private.phMenu To hMenu // Create menu item collection Object oMenuItems Is A cCollection End_Object // oMenuItems Set phoItems To (oMenuItems(Self)) Set Focus_Mode To Pointer_Only End_Procedure // Construct_Object // Procedure : End_Construct_Object // Purpose : End object constructor Procedure End_Construct_Object Handle hoObject Forward Send End_Construct_Object // Register menu (parent can be a cPopupMenuItem or cRebarToolbarButton object) If (pbShortcutMenu(Self) = 0) Begin Move Self To hoObject Delegate Set phoMenu To hoObject End // If (pbShortcutMenu(Self) = 0) Begin End_Procedure // End_Construct_Object // Procedure : Destroy_Object // Purpose : Object destructor Procedure Destroy_Object Integer iResult // Destroy the menu and free memory If (Private.phMenu(Self)) Begin Move (DestroyMenu(Private.phMenu(Self))) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) End // If (Private.phMenu(Self)) Begin // Destroy the VDF part of the object Forward Send Destroy_Object End_Procedure // Destroy_Object // Procedure : Private.RegisterItem // Purpose : Registers a menu item in the oMenuItems collection Procedure Private.RegisterItem Handle hoObject If (Object_Id(phoItems(Self))) Send DoAppendObject To (phoItems(Self)) hoObject End_Procedure // Private.RegisterItem // Procedure : Private.UnregisterItem // Purpose : Un-registers a menu item in the oMenuItems collection Procedure Private.UnregisterItem Handle hoObject If (Object_Id(phoItems(Self))) Send DoRemoveObject To (phoItems(Self)) hoObject End_Procedure // Private.UnregisterItem // Function : FindTab // Purpose : Finds tab '\a' character in string and returns position Function FindTab String sText Returns Integer Integer iLength iCount Move (Length(sText)) To iCount While iCount Gt 0 If (Mid(sText,1,Length(sText)-iCount) = "\") Begin If (Mid(sText,1,Length(sText)-iCount-1) <> "\" And Uppercase(Mid(sText,1,Length(sText)-iCount+1)) = "A") Function_Return (Length(sText)-iCount) End // If (Mid(sText,1,Length(sText)-iCount) = "\") Begin Decrement iCount Loop // While iCount Gt 0 Function_Return 0 End_Function // FindTab // Procedure : MeasureItem // Purpose : Handle WM_MEASUREITEM Procedure MeasureItem Integer wParam Integer lParam Returns Integer String sMeasureItemStruct sNonClientMetrics sRect sLabel sLogFont Integer iResult iLogFont iObject iHeight iWidth iType Integer iTop iBottom iLeft iRight Handle hDC hLogFont hOldFont // Get the MEASUREITEMSTRUCT ZeroType MEASUREITEMSTRUCT To sMeasureItemStruct Move (CopyMemory(AddressOf(sMeasureItemStruct),lParam,MEASUREITEMSTRUCT_Size)) To iResult GetBuff From sMeasureItemStruct At MEASUREITEMSTRUCT.itemData To iObject GetBuff From sMeasureItemStruct At MEASUREITEMSTRUCT.CtlType To iType If (iType <> ODT_MENU) Procedure_Return False // Not handled // Create a RECT ZeroType tRECT To sRect // Check if item is a separator If (pbSeparator(iObject)) Begin Move (GetSystemMetrics(SM_CYMENU)/2) To iHeight // Make height even If (Mod(iHeight,2) <> 0) Move (iHeight+1) To iHeight Put iHeight To sMeasureItemStruct At MEASUREITEMSTRUCT.itemHeight Put 0 To sMeasureItemStruct At MEASUREITEMSTRUCT.itemWidth End // If (pbSeparator(iObject)) Begin Else Begin // Get the device context for the entire screen Move (GetWindowDC(0)) To hDC //If (hDC = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) // Items with submenu are not ownerdraw, calculate for non-submenu items only //If (phoMenu(iObject) = 0) Begin // Get the menu font ZeroType NONCLIENTMETRICS To sNonClientMetrics Put NONCLIENTMETRICS_Size To sNonClientMetrics At NONCLIENTMETRICS.cbSize Move (SystemParametersInfo(SPI_GETNONCLIENTMETRICS,NONCLIENTMETRICS_Size,AddressOf(sNonClientMetrics),0)) To iResult //If (iResult = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) // Now we must pass the address of the lfMenuFont member to CreateFontIndirect ZeroType LogFont To sLogFont Offset_Of_Field NONCLIENTMETRICS.lfMenuFont To iLogFont Move (CopyMemory(AddressOf(sLogFont),AddressOf(sNonClientMetrics)+iLogFont-1,LogFont_Size)) To iResult If (pbDefault(iObject)) Put FW_BOLD To sLogFont At LogFont.lfWeight // Create the menu font Move (CreateFontIndirect(AddressOf(sLogFont))) To hLogFont //If (hLogFont = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) // Select the menu font Move (SelectObject(hDC,hLogFont)) To hOldFont // Get label Get psLabel Of iObject To sLabel Move (ToAnsi(sLabel)) To sLabel // Draw text Move (DrawText(hDC,AddressOf(sLabel),-1,AddressOf(sRect),(DT_SINGLELINE Ior DT_LEFT Ior DT_VCENTER Ior DT_CALCRECT))) To iResult // If (iResult = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) // Select the old font Move (SelectObject(hDC,hOldFont)) To iResult // Delete the menu font Move (DeleteObject(hLogFont)) To iResult //End // If (phoMenu(iObject) = 0) Begin // Calculate height of menu item GetBuff From sRect At tRECT.bottom To iBottom GetBuff From sRect At tRECT.top To iTop Move (GetSystemMetrics(SM_CYMENU)) To iHeight If (iHeight < (iBottom-iTop)) Move (iBottom-iTop) To iHeight If (iHeight < (16+(CYBUTTONMARGIN*2))) Move (16+(CYBUTTONMARGIN*2)) To iHeight // Calculate width of menu item GetBuff From sRect At tRECT.Right To iRight GetBuff From sRect At tRECT.Left To iLeft Move (iRight-iLeft) To iWidth Move (iWidth+(CXTEXTMARGIN*2)) To iWidth Move (iWidth+CXGAP) To iWidth Move (iWidth+((16+(CXBUTTONMARGIN*2))*2)) To iWidth Move (iWidth-(GetSystemMetrics(SM_CXMENUCHECK))-1) To iWidth // Items with submenu are not ownerdraw, returns size of bitmap only // TODO, find a good solution for shadowed sub-menu items // If (phoMenu(iObject)) Begin // Move (16+(CXBUTTONMARGIN*2)) To iWidth // Move (iWidth-(GetSystemMetrics(SM_CXMENUCHECK))-1) To iWidth // End // If (phoMenu(iObject)) Begin // Set the width and height Put iHeight To sMeasureItemStruct At MEASUREITEMSTRUCT.itemHeight Put iWidth To sMeasureItemStruct At MEASUREITEMSTRUCT.itemWidth // Release the device context Move (ReleaseDC(0,hDC)) To iResult End // Else Begin // Copy the structure back to lParam Move (CopyMemory(lParam,AddressOf(sMeasureItemStruct),MEASUREITEMSTRUCT_Size)) To iResult Set Windows_Override_State To True Procedure_Return True // Handled End_Procedure // MeasureItem // Procedure : DrawItem // Purpose : Handle WM_DRAWITEM Procedure DrawItem Integer wParam Integer lParam Returns Integer Integer iResult iObject iType iState iAction iImage iImageList iLogFont Integer iColor iTextColor iBgColor iX iY iDC iOldMode iPos iOldColor Boolean bDisabled bSelected bChecked Handle hDC hBrush hOldBrush hImageList hBitmap hIcon hLogFont hOldFont String sDrawItemStruct sRect sLabel sText sLogFont sNonClientMetrics Integer iButtonTop iButtonBottom iButtonLeft iButtonRight // Button RECT Integer iTextTop iTextBottom iTextLeft iTextRight // Type RECT Integer iTop iBottom iLeft iRight // Item RECT // Get the MEASUREITEMSTRUCT ZeroType RdsDRAWITEMSTRUCT To sDrawItemStruct Move (CopyMemory(AddressOf(sDrawItemStruct),lParam,RdsDRAWITEMSTRUCT_Size)) To iResult GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.CtlType To iType If (iType <> ODT_MENU) Procedure_Return False // Not handled // Save complete DC state //Move (SaveDC(hDC)) To iDC GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.itemData To iObject GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.hDC To hDC GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.itemAction To iAction GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.itemState To iState // Get rect GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.rcItem.Top To iTop GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.rcItem.Bottom To iBottom GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.rcItem.Left To iLeft GetBuff From sDrawItemStruct At RdsDRAWITEMSTRUCT.rcItem.Right To iRight // Get the menu font ZeroType NONCLIENTMETRICS To sNonClientMetrics Put NONCLIENTMETRICS_Size To sNonClientMetrics At NONCLIENTMETRICS.cbSize Move (SystemParametersInfo(SPI_GETNONCLIENTMETRICS,NONCLIENTMETRICS_Size,AddressOf(sNonClientMetrics),0)) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) // Now we must pass the address of the lfMenuFont member to CreateFontIndirect ZeroType LogFont To sLogFont Offset_Of_Field NONCLIENTMETRICS.lfMenuFont To iLogFont Move (CopyMemory(AddressOf(sLogFont),AddressOf(sNonClientMetrics)+iLogFont-1,LogFont_Size)) To iResult If (pbDefault(iObject)) Put FW_BOLD To sLogFont At LogFont.lfWeight // Create the menu font Move (CreateFontIndirect(AddressOf(sLogFont))) To hLogFont //If (hLogFont = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) //If (phoMenu(iObject)) Procedure_Return True // Draw separator If (pbSeparator(iObject)) Begin // Calculate middle of rect Move (iTop+((iBottom-iTop)/2)-1) To iTop // Set rect to paint ZeroType RECT To sRect Put iLeft To sRect At tRECT.Left Put iRight To sRect At tRECT.Right Put iBottom To sRect At tRECT.bottom Put iTop To sRect At tRECT.top // Draw the separator line Move (DrawEdge(hDC,AddressOf(sRect),EDGE_ETCHED,BF_TOP)) To iResult //If (iResult = 0) Error DFERR_WINDOWS_MENU (FormatMessage(GetLastError())) End // If (pbSeparator(iObject)) Begin Else Begin // Get item state If (iState Iand ODS_GRAYED) Move 1 To bDisabled If (iState Iand ODS_SELECTED) Move 1 To bSelected If (iState Iand ODS_CHECKED) Move 1 To bChecked Move iLeft To iButtonLeft Move iTop To iButtonTop Move (iTop+16+(CYBUTTONMARGIN*2)) To iButtonBottom Move (iLeft+16+(CXBUTTONMARGIN*2)) To iButtonRight // If the item has a bitmap draw it If ((piImage(iObject) <> -1) Or (piCheckedImage(iObject) <> -1 And bChecked) Or (piUncheckedImage(iObject) <> -1 And Not(bChecked))) Begin // Calculate point to start drawing Move (iButtonTop+CYBUTTONMARGIN) To iY Move (iButtonLeft+CXBUTTONMARGIN) To iX // Get imagelist info Get phoImageList Of iObject To iImageList If iImageList Get Window_Handle Of iImageList To hImageList If (piImage(iObject) <> -1) Get piImage Of iObject To iImage Else If (piCheckedImage(iObject) <> -1 And bChecked) Get piCheckedImage Of iObject To iImage Else If (piUncheckedImage(iObject) <> -1 And (Not(bChecked))) Get piUncheckedImage Of iObject To iImage If (Not(bDisabled)) Begin If (bChecked And (Not(bSelected))) Move (GetSysColor(COLOR_3DLIGHT)) To iColor Else Move (GetSysColor(COLOR_MENU)) To iColor Move (CreateSolidBrush(iColor)) To hBrush Move (SelectObject(hDC,hBrush)) To hOldBrush Move (PatBlt(hDC,iButtonLeft,iButtonTop,(iButtonRight-iButtonLeft),(iButtonBottom-iButtonTop),PATCOPY)) To iResult Move (SelectObject(hDC,hOldBrush)) To iResult Move (DeleteObject(hBrush)) To iResult If (bSelected Or bChecked) Begin Put iButtonLeft To sRect At tRECT.Left Put iButtonBottom To sRect At tRECT.bottom Put iButtonTop To sRect At tRECT.top Put iButtonRight To sRect At tRECT.Right If (bChecked) Move (DrawEdge(hDC,AddressOf(sRect),BDR_SUNKENOUTER,BF_RECT)) To iResult Else Move (DrawEdge(hDC,AddressOf(sRect),BDR_RAISEDINNER,BF_RECT)) To iResult End // If (bSelected Or bChecked) Begin Move (ImageList_Draw(hImageList,iImage,hDC,iX,iY,ILD_TRANSPARENT)) To iResult End // If (Not(bDisabled)) Begin Else Begin Move (ImageList_GetIcon(hImageList,iImage,0)) To hIcon Move (DrawState(hDC,0,0,(Low(hIcon)),0,iX,iY,16,16,(DST_ICON Ior DSS_DISABLED))) To iResult Move (DestroyIcon(hIcon)) To iResult End // Else Begin End // If (Image(iObject) <> -1) Begin //If (phoMenu(iObject)) Procedure_Return True // Paint text, start with background Get psLabel Of iObject To sLabel Move (ToAnsi(sLabel)) To sLabel If (bSelected) Move (GetSysColor(COLOR_HIGHLIGHT)) To iBgColor Else Move (GetSysColor(COLOR_MENU)) To iBgColor If (bSelected Or (iAction=ODA_SELECT)) Begin Move (CreateSolidBrush(iBgColor)) To hBrush Move (SelectObject(hDC,hBrush)) To hOldBrush If (piImage(iObject) <> -1) Move (iLeft+16+(CXBUTTONMARGIN*2)+CXGAP) To iTextLeft Else If ((piCheckedImage(iObject) <> -1) And bChecked) Move (iLeft+16+(CXBUTTONMARGIN*2)+CXGAP) To iTextLeft Else If ((piUncheckedImage(iObject) <> -1) And Not(bChecked)) Move (iLeft+16+(CXBUTTONMARGIN*2)+CXGAP) To iTextLeft Move (PatBlt(hDC,iTextLeft,iTop,(iRight-iTextLeft),(iBottom-iTop),PATCOPY)) To iResult Move (SelectObject(hDC,hOldBrush)) To iResult Move (DeleteObject(hBrush)) To iResult End // If (bSelected Or iAtion=ODA_SELECT) Begin // Calculate text rectangle and colors Move (iLeft+16+(CXBUTTONMARGIN*2)+CXGAP+CXTEXTMARGIN) To iTextLeft Move (iRight-16-(CYBUTTONMARGIN*2)) To iTextRight Move iBottom To iTextBottom Move iTop To iTextTop Move (SetBkMode(hDC,TRANSPARENT)) To iOldMode //Result If (bDisabled) Move (GetSysColor(COLOR_GRAYTEXT)) To iTextColor Else If (bSelected) Move (GetSysColor(COLOR_HIGHLIGHTTEXT)) To iTextColor Else Move (GetSysColor(COLOR_MENUTEXT)) To iTextColor // Now paint the menu text If (bDisabled And (Not(bSelected) Or iTextColor = iBgColor)) Begin ZeroType RECT To sRect Put iTextLeft+1 To sRect At tRECT.Left Put iTextTop+1 To sRect At tRECT.top Put iTextRight To sRect At tRECT.Right Put iTextBottom To sRect At tRECT.bottom // Select the menu font Move (SelectObject(hDC,hLogFont)) To hOldFont // Draw text 1 pixel down and to the right of actuall text to get shadow Move (SetTextColor(hDC,GetSysColor(COLOR_3DHILIGHT))) To iOldColor Get FindTab sLabel To iPos If (iPos <> 0) Move (Left(sLabel,iPos-1)) To sText Else Move sLabel To sText Move (DrawText(hDC,AddressOf(sText),-1,AddressOf(sRect),(DT_SINGLELINE Ior DT_LEFT Ior DT_VCENTER))) To iResult If (iPos <> 0) Begin Move (Right(sLabel,Length(sLabel)-iPos-1)) To sText Move (DrawText(hDC,AddressOf(sText),-1,AddressOf(sRect),(DT_SINGLELINE Ior DT_RIGHT Ior DT_VCENTER))) To iResult End // If (Pos("\A",UpperCase(sLabel))) Begin // Select old text color Move (SetTextColor(hDC,iOldColor)) To iResult // Select the old font Move (SelectObject(hDC,hOldFont)) To iResult End // If (bDisabled And (Not(bSelected) Or iTextColor = iBgColor)) Begin // Now paint actuall text ZeroType RECT To sRect Put iTextLeft To sRect At tRECT.Left Put iTextTop To sRect At tRECT.top Put iTextRight To sRect At tRECT.Right Put iTextBottom To sRect At tRECT.bottom // Select the menu font Move (SelectObject(hDC,hLogFont)) To hOldFont Move (SetTextColor(hDC,iTextColor)) To iOldColor Get FindTab sLabel To iPos If (iPos <> 0) Move (Left(sLabel,iPos-1)) To sText Else Move sLabel To sText Move (DrawText(hDC,AddressOf(sText),-1,AddressOf(sRect),(DT_SINGLELINE Ior DT_LEFT Ior DT_VCENTER))) To iResult If (iPos <> 0) Begin Move (Right(sLabel,Length(sLabel)-iPos-1)) To sText Move (DrawText(hDC,AddressOf(sText),-1,AddressOf(sRect),(DT_SINGLELINE Ior DT_RIGHT Ior DT_VCENTER))) To iResult End // If (Pos("\A",UpperCase(sLabel))) Begin // Select old text color Move (SetTextColor(hDC,iOldColor)) To iResult // Select the old font Move (SelectObject(hDC,hOldFont)) To iResult Move (DeleteObject(hLogFont)) To iResult // Select old background mode Move (SetBkMode(hDC,iOldMode)) To iOldMode //Result End // Else Begin // Restore complete DC state //Move (RestoreDC(hDC,iDC)) To iDC Set Windows_Override_State To True Procedure_Return True // Handled End_Procedure // DrawItem // Procedure : MenuChar // Purpose : Handle WM_MENUCHAR Procedure MenuChar Integer wParam Integer lParam Returns Integer Integer iCount iItems iObject iItem iState iCurrent iResult iFound iFirst String sMenuItemInfo sLabel sKey sChar // Get typed character Move (CharUpper(Character(Low(wParam)))) To sKey // Initialize to -1 Move -1 To iFirst Move -1 To iItem // Get all mnemonics Move (GetMenuItemCount(lParam)) To iItems If (iItems = -1) Error 500 (FormatMessage(GetLastError())) // Find all mnemonics For iCount From 0 To (iItems-1) ZeroType MENUITEMINFO To sMenuItemInfo Put MENUITEMINFO_Size To sMenuItemInfo At MENUITEMINFO.cbSize Put (MIIM_DATA Ior MIIM_STATE) To sMenuItemInfo At MENUITEMINFO.fMask Move (GetMenuItemInfo(lParam,iCount,MF_BYPOSITION,AddressOf(sMenuItemInfo))) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) GetBuff From sMenuItemInfo At MENUITEMINFO.dwItemData To iObject GetBuff From sMenuItemInfo At MENUITEMINFO.fState To iState Get psLabel Of iObject To sLabel If (Pos("&",sLabel)) Begin Move (CharUpper(ToAnsi(Mid(sLabel,1,(Pos("&",sLabel)+1))))) To sChar If (sChar = sKey) Begin Increment iFound If (iFirst = -1) Move iCount To iFirst // First mnemonic If (iCurrent <> 0 And iItem = -1) Move iCount To iItem // First mnemonic past current item End // If (sChar = sKey) Begin End // If (Pos("&",sLabel)) Begin If (iState Iand MFS_HILITE) Move iCount To iCurrent Loop // For iCount From 0 To (iItems-1) // Make sure the value is returned to Windows by setting Windows_Override_State Set Windows_Override_State To True If (iFirst = -1) Procedure_Return (MNC_IGNORE*65536) Else If (iFound = 1) Procedure_Return ((MNC_EXECUTE*65536)+iFirst) Else If (iItem <> -1) Procedure_Return ((MNC_SELECT*65536)+iItem) Else Procedure_Return ((MNC_SELECT*65536)+iFirst) End_Procedure // MenuChar // Procedure : Command // Purpose : Handle WM_COMMAND Procedure Command Integer wParam Integer lParam Returns Integer Integer iObject iMessage iDestination Move (Low(wParam)) To iObject Get phmMessage Of iObject To iMessage If (iMessage <> 0) Begin // Get destination from menu item Get phoDestination Of iObject To iDestination // Get default destination from menu If (iDestination = 0) Get phoDestination To iDestination // Handle constant destinations If (iDestination = DDCLIENTAREA) Move (Client_Id(Self)) To iDestination If (iDestination = DDDESKTOP) Move (Focus(Desktop)) To iDestination If (iDestination = DDSELF) Move (Self) To iDestination // Send message If (iDestination <> 0) Send iMessage To iDestination Else Send iMessage To (Focus(Desktop)) End // If (iMessage <> 0) Begin Else Begin Get phmOnClick Of iObject To iMessage If (iMessage = Msg_OnClick) Send iMessage To iObject // WM_COMMAND is recieved by the top-most cPopupMenu object, but the message can be defined // in a cascading popup menu. Send the message to the cPopupMenuItem object and let DataFlex // delegation do the rest. Else Send iMessage To iObject iObject End // Else Begin Procedure_Return 0 // processed End_Procedure // Command // Procedure : MenuSelect // Purpose : Handles WM_MENUSELECT Procedure MenuSelect Integer wParam Integer lParam Returns Integer Integer iResult iState iStatusBar iObject String sMenuItemInfo sHelp Boolean bPosition // Send OnLeaving to old item If (Private.phoOldItem(Self) <> 0) Send OnLeaving To (Private.phoOldItem(Self)) If (lParam <> 0) Begin ZeroType MENUITEMINFO To sMenuItemInfo Put MENUITEMINFO_Size To sMenuItemInfo At MENUITEMINFO.cbSize Put (MIIM_DATA Ior MIIM_STATE) To sMenuItemInfo At MENUITEMINFO.fMask // If the item contains a submenu the zero-based index is returned If (Hi(wParam) Iand MF_POPUP) Move (True) To bPosition Else Move (False) To bPosition Move (GetMenuItemInfo(lParam,Low(wParam),bPosition,AddressOf(sMenuItemInfo))) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) GetBuff From sMenuItemInfo At MENUITEMINFO.dwItemData To iObject GetBuff From sMenuItemInfo At MENUITEMINFO.fState To iState If (iObject <> 0) Begin // Update statusbar Delegate Get StatusBar_Id To iStatusBar If (iStatusBar <> 0) Begin Send Initialize_Menu To iStatusBar Get psStatusHelp Of iObject To sHelp If (sHelp <> "" And (iState Iand MFS_DISABLED)) Move (sHelp * psShadowStatusHelp(iObject)) To sHelp Send Show_Status_Help To iStatusBar sHelp End // If (iStatusBar <> 0) Begin // Send OnEntering to selected item Send OnEntering To iObject End // If (iObject <> 0) Begin End // If (lParam = 0) Begin // Set phoOldItem to currently selected item, if there is no item phoOldItem will be 0 Set Private.phoOldItem To iObject If (pbShortcutMenu(Self) = 0) Delegate Send MenuSelect wParam lParam End_Procedure // MenuSelect // Procedure : InitMenuPopup // Purpose : Handle WM_INITMENUPOPUP Procedure InitMenuPopup Integer wParam Integer lParam Returns Integer Integer iResult iObject String sMenuItemInfo If (wParam <> Private.phMenu(Self)) Begin ZeroType MENUITEMINFO To sMenuItemInfo Put MENUITEMINFO_Size To sMenuItemInfo At MENUITEMINFO.cbSize Put MIIM_DATA To sMenuItemInfo At MENUITEMINFO.fMask Move (GetMenuItemInfo(wParam,0,1,AddressOf(sMenuItemInfo))) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) GetBuff From sMenuItemInfo At MENUITEMINFO.dwItemData To iObject If (Private.pbActivateFirst(iObject)) Begin Move (Keybd_Event(VK_DOWN,0,0,0)) To iResult Move (Keybd_Event(VK_DOWN,0,KEYEVENTF_KEYUP,0)) To iResult End // If (Private.pbActivateFirst(iObject)) Begin Send OnActivate To iObject End // If (wParam <> Private.phMenu(Self)) Begin Else Begin If (Private.pbActivateFirst(Self)) Begin Move (Keybd_Event(VK_DOWN,0,0,0)) To iResult Move (Keybd_Event(VK_DOWN,0,KEYEVENTF_KEYUP,0)) To iResult End // If (Private.pbActivateFirst(Self)) Begin Send OnActivate End // Else Begin End_Procedure // InitMenuPopup // Procedure : UninitMenuPopup // Purpose : Handle WM_UNINITMENUPOPUP Procedure UninitMenuPopup Integer wParam Integer lParam Returns Integer Integer iResult iObject String sMenuItemInfo If (wParam <> Private.phMenu(Self)) Begin ZeroType MENUITEMINFO To sMenuItemInfo Put MENUITEMINFO_Size To sMenuItemInfo At MENUITEMINFO.cbSize Put MIIM_DATA To sMenuItemInfo At MENUITEMINFO.fMask Move (GetMenuItemInfo(wParam,0,1,AddressOf(sMenuItemInfo))) To iResult If (iResult = 0) Error 500 (FormatMessage(GetLastError())) GetBuff From sMenuItemInfo At MENUITEMINFO.dwItemData To iObject Send OnDeactivate To iObject End // If (wParam <> Private.phMenu(Self)) Begin Else Send OnDeactivate End_Procedure // UninitMenuPopup // Procedure : Notify // Purpose : Handle WM_NOTIFY Procedure Notify Integer wParam Integer lParam Returns Integer End_Procedure // Notify // Procedure : OnActivate // Purpose : This event is sent when a menu is activated Procedure OnActivate End_Procedure // OnActivate // Procedure : OnDeactivate // Purpose : This event is sent when a menu is deactivated, you will NOT recieve this event on Win95 & NT4 Procedure OnDeactivate End_Procedure // OnDeactivate // Function : ItemCount // Purpose : Returns the number of menu items Function ItemCount Returns Integer Function_Return (CountOfObjects(phoItems(Self))) End_Function // ItemCount // Function : ObjectFromIndex // Purpose : Returns object id for passed zero based index Function ObjectFromIndex Integer iItem Returns Handle Function_Return (ObjectFromIndex(phoItems(Self),iItem)) End_Function // ObjectFromIndex // Function : IndexFromObject // Purpose : Returns zero based index for passed object id Function IndexFromObject Handle hoObject Returns Integer Function_Return (IndexFromObject(phoItems(Self),hoObject)) End_Function // IndexFromObject // Procedure : Popup // Purpose : Used to display a shortcut menu (pbShortcutMenu = true) Procedure Popup Integer iX iY iFlags iResult String sPoint Send Page_Object True If (pbAutoLocate(Self)) Begin ZeroType POINT To sPoint Move (GetCursorPos(AddressOf(sPoint))) To iResult GetBuff From sPoint At POINT.x To iX GetBuff From sPoint At POINT.y To iY Move (TPM_LEFTALIGN Ior TPM_RIGHTBUTTON) To iFlags Move (TrackPopupMenuEx(Private.phMenu(Self),iFlags,iX,iY,Window_Handle(Self),0)) To iResult // Remove statusbar information If (StatusBar_Id(Self)) Send Exit_Menu To (StatusBar_Id(Self)) If (iResult = 0) Error 500 (FormatMessage(GetLastError())) End // If (pbAutoLocate(Self)) Begin Else Begin Move (TPM_LEFTALIGN Ior TPM_RIGHTBUTTON) To iFlags Move (TrackPopupMenuEx(Private.phMenu(Self),iFlags,Low(GUILocation(Self)),Hi(GUILocation(Self)),Window_Handle(Self),0)) To iResult // Remove statusbar information If (StatusBar_Id(Self)) Send Exit_Menu To (StatusBar_Id(Self)) If (iResult = 0) Error 500 (FormatMessage(GetLastError())) End // Else Begin End_Procedure // Popup End_Class // cPopupMenu