Pop-up Menu Font
-
- Always Here
- Posts: 6425
- Joined: Fri Oct 23, 2009 2:33 am
- Location: Wales, UK
- Contact:
Pop-up Menu Font
Before I define my own instead, is there a way to apply font and fontsize to a pop-up menu? The default on a high-res tablet screen is way too tiny.
IdeasVacuum
If it sounds simple, you have not grasped the complexity.
If it sounds simple, you have not grasped the complexity.
- netmaestro
- PureBasic Bullfrog
- Posts: 8425
- Joined: Wed Jul 06, 2005 5:42 am
- Location: Fort Nelson, BC, Canada
Re: Pop-up Menu Font
Howzis?
Can't really get away from owner drawing the menu. But it's not difficult as you can see.
Code: Select all
Global Dim options.s(4)
options(1) = "Open"
options(2) = "Save"
options(3) = "Save as"
options(4) = "Quit"
LoadFont(0, "Verdana", 16)
Procedure WinProc(hWnd, Msg, wParam, lParam)
Static selectedbrush
selectedbrush = CreateSolidBrush_(GetSysColor_(#COLOR_MENUHILIGHT))
result = #PB_ProcessPureBasicEvents
Select Msg
Case #WM_DESTROY
DeleteObject_(selectedbrush)
Case #WM_MEASUREITEM:
*lpmis.MEASUREITEMSTRUCT = lParam
With *lpmis
\itemWidth = 200
\itemHeight = 40
EndWith
Case #WM_DRAWITEM:
*lpdis.DRAWITEMSTRUCT = lParam
If *lpdis\itemState & #ODS_SELECTED
bgbrush = selectedbrush
Else
bgbrush = GetStockObject_(#WHITE_BRUSH)
EndIf
With *lpdis
SetBkMode_(\hDC, #TRANSPARENT)
SelectObject_(\hDC, bgbrush)
SelectObject_(\hDC, GetStockObject_(#NULL_PEN))
Rectangle_(\hDC, \rcItem\left, \rcItem\top, \rcItem\right, \rcItem\bottom)
\rcItem\left + 2
\rcItem\top + 2
SelectObject_(\hDC, FontID(0))
DrawText_(\hDC, options(\itemID), -1, @\rcItem, 0)
EndWith
EndSelect
ProcedureReturn result
EndProcedure
If OpenWindow(0, 200, 200, 200, 120, "Popup-Menu Example")
SetWindowCallback(@WinProc())
hMenu = CreatePopupMenu(0) ; creation of the pop-up menu begins...
MenuItem(1, options(1)) ; You can use all commands for creating a menu
MenuItem(2, options(2)) ; just like in a normal menu...
MenuItem(3, options(3))
MenuItem(4, options(4))
For i=0 To 3
With mii.MENUITEMINFO
\cbSize = SizeOf (MENUITEMINFO)
\fMask = #MIIM_TYPE
\fType = #MFT_OWNERDRAW
\dwTypeData = @options(i)
SetMenuItemInfo_(hMenu, i, #True, @mii)
EndWith
Next
Repeat
Event = WaitWindowEvent() ; check for window events
Select Event
Case #PB_Event_RightClick ; right mouse button was clicked =>
DisplayPopupMenu(0, WindowID(0)) ; now display the popup-menu
Case #PB_Event_Menu ; an item of the popup-menu was clicked
Select EventMenu() ; get the clicked menu item...
Case 1 : Debug "Menu: Open"
Case 2 : Debug "Menu: Save"
Case 3 : Debug "Menu: Save as"
Case 4 : End
EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow
EndIf
BERESHEIT
Re: Pop-up Menu Font
I did that long time back
You have 2 options now
Have fun
You have 2 options now
Have fun
Code: Select all
Global i.ICONINFO,curHnd
i\fIcon = #True
LoadFont(0,"MS Sans Serif",16,#PB_Font_Bold)
Procedure SetImage(Menu, index, ico,Text$ ,Color)
CreateImage(10, 120, 30 ,32,#PB_Image_Transparent)
hdc = StartDrawing(ImageOutput(10))
Box(0,0,120,30,$FFFFFF)
DrawingMode(#PB_2DDrawing_Transparent )
DrawingFont(FontID(0))
DrawText(34,2,Text$,Color)
StopDrawing()
i\hbmMask = ImageID(10)
i\hbmColor = ImageID(10)
curHnd = CreateIconIndirect_(i)
ExtractIconEx_("shell32.dll", ico, 0, @iIcon, 1)
im=CreateImage(#PB_Any, 120, 30,32, #PB_Image_Transparent )
StartDrawing(ImageOutput(im))
DrawImage(iIcon, 6, 8)
DrawImage(curHnd, 0, 0)
StopDrawing()
SetMenuItemBitmaps_(Menu,index,#MF_BYPOSITION, ImageID(im),0)
DestroyIcon_(iIcon)
EndProcedure
OpenWindow(0, 0, 0, 600, 300, "TEST",#PB_Window_SystemMenu| #PB_Window_ScreenCentered|#PB_Window_SizeGadget)
hMenu = CreatePopupMenu(1)
MenuItem(3,"")
MenuItem(4,"")
sMenu = OpenSubMenu("")
MenuItem(2,"")
MenuItem(3,"")
MenuItem(4,"")
MenuItem(5,"")
CloseSubMenu()
SetImage(hMenu, 0, 4,"Load",$FF0000)
SetImage(hMenu, 1, 130,"Save As",$00FF00)
SetImage(hMenu, 2, 194,"Options",$0000FF)
SetImage(sMenu, 0,4,"Test #1",$EC07F4)
SetImage(sMenu, 1, 43,"Test #2",$EC07F4)
SetImage(sMenu, 2, 10,"Test #3",$EC07F4)
SetImage(sMenu, 3, 90,"Test #4",$EC07F4)
Repeat
Select WaitWindowEvent()
Case #PB_Event_RightClick
DisplayPopupMenu(1, WindowID(0))
Case #PB_Event_CloseWindow
Quit = 1
EndSelect
Until Quit = 1
Egypt my love
-
- Always Here
- Posts: 6425
- Joined: Fri Oct 23, 2009 2:33 am
- Location: Wales, UK
- Contact:
Re: Pop-up Menu Font
Thanks guys - I thought nobody had a solution and then two buses came along at once!
I have in the meantime tried my own solution, consisting of a borderless window and an oversized single column ListIcon (oversized to have just the one column showing and no scrollbars). This allows me to define the font and apply alternate row colours. Only one pop-up menu at a time, so I define them on-the-fly.
[/size]
I have in the meantime tried my own solution, consisting of a borderless window and an oversized single column ListIcon (oversized to have just the one column showing and no scrollbars). This allows me to define the font and apply alternate row colours. Only one pop-up menu at a time, so I define them on-the-fly.
Code: Select all
Procedure.i GetColWidth(sColTxt.s, iFontID.i)
;#-------------------------------------------
;This Procedure does not draw anything, it just verifies text width in pixels
Protected iColW.i
If StartDrawing(WindowOutput(#WinMain))
DrawingMode(#PB_2DDrawing_Default)
DrawingFont(FontID(iFontID))
iColW = TextWidth(sColTxt)
StopDrawing()
EndIf
ProcedureReturn(iColW)
EndProcedure
Procedure PfPop(List sItemsList.s(), iFontID.i, iColourEven.i, iColourOdd.i, iCursorPosX.i, iCursorPosY.i)
;#--------------------------------------------------------------------------------------------------------
Protected lrc.RECT
Protected iRowH.i, iItemW.i, iListW.i, iListH.i
Protected iRowTotal.i = ListSize(sItemsList())
;Minimum width based on menu item text width
ForEach sItemsList()
iItemW = GetColWidth(sItemsList(), iFontID)
If(iItemW > iListW) : iListW = iItemW : EndIf
Next
;Temp Window to determine ListIcon height from row height
If OpenWindow(#WinTemp, 0, 0, 200, 100, "", #PB_Window_Invisible | #PB_Window_BorderLess)
ListIconGadget(#ListTemp, 0, 0, 200, 100, "", 200, #LVS_NOCOLUMNHEADER)
SetGadgetFont(#ListTemp, FontID(iFontID))
AddGadgetItem(#ListTemp, -1, "TEMP TEXT")
lrc\left = #LVIR_LABEL
SendMessage_(GadgetID(#ListTemp), #LVM_GETITEMRECT, 0, lrc)
iRowH = lrc\bottom - lrc\Top
iListH = (iRowTotal * iRowH)
CloseWindow(#WinTemp)
EndIf
;Define the pop-up Window and display. Magic numbers (40, 2) to enhance appearance
If OpenWindow(#WinPop, iCursorPosX, iCursorPosY, (iListW + 40), (iListH + 2), "", #PB_Window_Invisible | #PB_Window_BorderLess)
;Magic numbers to oversize ListIcon, hiding scroll bars
; x y w h col 0
ListIconGadget(#ListPop, -5, 0, (iListW + 70), (iListH + 35), "", (iListW + 40), #LVS_NOCOLUMNHEADER)
SetGadgetFont(#ListPop, FontID(iFontID))
ForEach sItemsList()
AddGadgetItem(#ListPop, -1, sItemsList())
Next
SendMessage_(GadgetID(#ListPop), #LVM_SETEXTENDEDLISTVIEWSTYLE, 0, #LVS_EX_ONECLICKACTIVATE)
ProfSetListRowColours(#ListPop, iColourEven, iColourOdd, iRowTotal)
HideWindow(#WinPop, #False)
StickyWindow(#WinPop, #True)
EndIf
EndProcedure
IdeasVacuum
If it sounds simple, you have not grasped the complexity.
If it sounds simple, you have not grasped the complexity.