Tweet
' Setting Fonts for Menu-Item Text Strings
'
' This was inspired by discussion in the windows forum:
' http://www.powerbasic.com/support/pb...ad.php?t=35977
'
' The present code is a slightly modified version of a code made by Semen Matusovski, originally presented
' here: http://www.powerbasic.com/support/pb...25MF_OWNERDRAW
' I hade small problems having his code run on PBWin8x, hence this version.
'
' I think the code is inspired by code from this Microsoft link:
' http://msdn2.microsoft.com/en-us/lib...m_Text_Strings
'
' January 6, 2008: Small changes made. Now the menu bar font is also user defined. I think the code can be further
' refined by conforming in greater detail with the Microsoft example referred to above.
'
' This was inspired by discussion in the windows forum:
' http://www.powerbasic.com/support/pb...ad.php?t=35977
'
' The present code is a slightly modified version of a code made by Semen Matusovski, originally presented
' here: http://www.powerbasic.com/support/pb...25MF_OWNERDRAW
' I hade small problems having his code run on PBWin8x, hence this version.
'
' I think the code is inspired by code from this Microsoft link:
' http://msdn2.microsoft.com/en-us/lib...m_Text_Strings
'
' January 6, 2008: Small changes made. Now the menu bar font is also user defined. I think the code can be further
' refined by conforming in greater detail with the Microsoft example referred to above.
Code:
#COMPILE EXE
#REGISTER NONE
#DIM ALL
#INCLUDE "WIN32API.INC"
TYPE MYITEMM
hfont AS LONG
psz AS ASCIIZ * 255
END TYPE
FUNCTION GetAFont(fnFont AS LONG) AS LONG
LOCAL lf AS LOGFONT
LOCAL sFontName AS STRING
GetObject GetStockObject(%ANSI_VAR_FONT), SIZEOF(lf), BYVAL VARPTR(lf)
IF (fnFont = 1) THEN
lf.lfHeight = -14
lf.lfWeight = %FW_BOLD
lf.lfFaceName = "Times New Roman"
ELSE
lf.lfWeight = %FW_NORMAL
END IF
lf.lfItalic = (fnFont = 2)
lf.lfUnderline = (fnFont = 3)
FUNCTION = CreateFontIndirect(lf)
END FUNCTION
FUNCTION MainWndProc(BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS DWORD) EXPORT AS LONG
DIM hMenuPopup AS LONG
DIM pMyItem AS MYITEMM PTR
DIM MyItem(0 TO 4) AS STATIC MYITEMM
STATIC hmenu AS LONG
LOCAL lpmis AS MEASUREITEMSTRUCT PTR
LOCAL lpdis AS DRAWITEMSTRUCT PTR
LOCAL hdc AS LONG
LOCAL SizeA AS SizeL
LOCAL i AS LONG
LOCAL hfontOld AS LONG
SELECT CASE wMsg
CASE %WM_CREATE
hMenu = CreateMenu: hMenuPopup = CreateMenu
FOR i = 0 TO 3: InsertMenu hMenuPopup, %MF_BYCOMMAND, %MF_STRING, 100 + i, "": NEXT
AppendMenu hMenu, %MF_POPUP OR %MF_STRING, hMenuPopup, "&File": SetMenu hWnd, hMenu
'
' modify MENU BAR. Use the %MF_BYPOSITION flag here.
ModifyMenu hmenu, 0, %MF_BYPOSITION OR %MF_OWNERDRAW, i, BYVAL VARPTR(myitem(4))
MyItem(4).hfont = GetAFont(1)
MyItem(4).psz = "&File"
'
FOR i = 0 TO 3 ' modify MENU ITEMS. Use the %MF_BYCOMMAND flag here.
ModifyMenu hmenu, 100 + i, %MF_BYCOMMAND OR %MF_OWNERDRAW, i, BYVAL VARPTR(myitem(i))
MyItem(i).hfont = GetAFont(i)
MyItem(i).psz = TRIM$(MID$("OPT. 1 OPT. 2 OPT. 3 OPT. 4 ", 7 * i + 1, 7))
NEXT
'
CASE %WM_DESTROY
FOR i = 0 TO 4 : DeleteObject MyItem(i).hfont : NEXT
PostQuitMessage 0
EXIT FUNCTION
CASE %WM_MEASUREITEM
hdc = GetDC(hwnd)
lpmis = lParam
pmyitem = @lpmis.itemData
hfontOld = SelectObject(hdc, @pmyitem.hfont)
GetTextExtentPoint32 hdc, @pmyitem.psz, LEN(@pmyitem.psz), SizeA
@lpmis.itemWidth = 8 + sizeA.cx
@lpmis.itemHeight = sizeA.cy
SelectObject hdc, hfontOld
ReleaseDC hwnd, hdc
FUNCTION = %TRUE: EXIT FUNCTION
CASE %WM_DRAWITEM
lpdis = lParam
pmyitem = @lpdis.itemData
IF (@lpdis.itemState AND %ODS_SELECTED) THEN
SetTextColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHTTEXT)
SetBkColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHT)
ELSE
SetTextColor @lpdis.hDC, GetSysColor(%COLOR_MENUTEXT)
SetBkColor @lpdis.hDC, GetSysColor(%COLOR_MENU)
END IF
hfontOld = SelectObject(@lpdis.hDC, @pmyitem.hfont)
ExtTextOut @lpdis.hDC, 8 + @lpdis.rcItem.nleft, @lpdis.rcItem.nTop, %ETO_OPAQUE, _
@lpdis.rcItem, @pmyitem.psz, LEN(@pmyitem.psz), BYVAL 0
SelectObject @lpdis.hDC, hfontOld
FUNCTION = %TRUE: EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, wMsg, wParam, lParam)
END FUNCTION
FUNCTION PBMAIN
LOCAL Msg AS tagMsg
LOCAL wndclass1 AS WndClassEx
LOCAL szClassName AS ASCIIZ * 80
LOCAL hWnd AS LONG
szClassName = "LtrGUITop"
wndclass1.cbSize = SIZEOF(WndClass1)
wndclass1.lpfnWndProc = CODEPTR(MainWndProc)
wndclass1.hInstance = GetModuleHandle (BYVAL 0&)
wndclass1.hbrBackground = GetStockObject(%LTGRAY_BRUSH )
wndclass1.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW )
wndclass1.lpszMenuName = %NULL
wndclass1.lpszClassName = VARPTR(szClassName)
RegisterClassEx wndclass1
hWnd = CreateWindow(szClassName, "Set Menu Font", %WS_SYSMENU OR %WS_MINIMIZEBOX, 250, 150, 300, 300, 0, BYVAL %Null, wndclass1.hInstance, BYVAL %NULL)
ShowWindow hWnd, %SW_SHOW
UpdateWindow hWnd
WHILE GetMessage(Msg, %NULL, 0, 0)
TranslateMessage Msg
DispatchMessage Msg
WEND
FUNCTION = msg.wParam
END FUNCTION
Comment