It is currently Mon Nov 20, 2017 1:05 am

All times are UTC + 1 hour




Post new topic Reply to topic  [ 4 posts ] 
Author Message
 Post subject: Pop-up Menu Font
PostPosted: Tue Jun 20, 2017 3:07 pm 
Offline
Always Here
Always Here

Joined: Fri Oct 23, 2009 2:33 am
Posts: 5686
Location: Wales, UK
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.


Top
 Profile  
Reply with quote  
 Post subject: Re: Pop-up Menu Font
PostPosted: Thu Jun 22, 2017 5:43 am 
Offline
PureBasic Bullfrog
PureBasic Bullfrog
User avatar

Joined: Wed Jul 06, 2005 5:42 am
Posts: 7954
Location: Kelowna, BC, Canada
Howzis?
Code:
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

Can't really get away from owner drawing the menu. But it's not difficult as you can see.

_________________
Veni, vidi, vici.


Top
 Profile  
Reply with quote  
 Post subject: Re: Pop-up Menu Font
PostPosted: Thu Jun 22, 2017 7:32 am 
Offline
Addict
Addict

Joined: Sun Apr 12, 2009 6:27 am
Posts: 2842
I did that long time back
You have 2 options now :)
Have fun

Code:
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


Top
 Profile  
Reply with quote  
 Post subject: Re: Pop-up Menu Font
PostPosted: Thu Jun 22, 2017 12:49 pm 
Offline
Always Here
Always Here

Joined: Fri Oct 23, 2009 2:33 am
Posts: 5686
Location: Wales, UK
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.

Code:
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.


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 4 posts ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 2 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye