#include <resource.h> #define IDM_BOLD 1000 #define IDM_REGULAR 1001 #define IDM_ITALIC 1002 #define IDM_ULINE 1003 MY_TRAY ICON MY_TRAY.ICO 100 DIALOG 1, 1, 1, 1 STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE BEGIN //*** dumb... END POPUPMENU MENU BEGIN POPUP "&Tray" BEGIN MENUITEM "Regular Font", IDM_REGULAR MENUITEM "Italic Font", IDM_ITALIC MENUITEM "Underlined Font", IDM_ULINE MENUITEM "Bold Font", IDM_BOLD MENUITEM SEPARATOR MENUITEM "Exit", IDCANCEL END END FontAccel ACCELERATORS BEGIN "B", IDM_BOLD, CONTROL, VIRTKEY END
Tweet
#COMPILE EXE
#RESOURCE "FONT.PBR"
$INCLUDE "WIN32API.INC"
%IDM_BOLD=1000 '...???
%IDM_REGULAR=1001 '...???
%IDM_ITALIC=1002 '...???
%IDM_ULINE=1003 '...???
%BOLD = 0
%REGULAR = 1
%ITALIC = 2
%ULINE = 3
%WM_TRAYICON = %WM_USER + 400
GLOBAL mDialog AS LONG
TYPE MYITEM
hfont AS LONG
psz AS ASCIIZ PTR
END TYPE ' structure FOR item font AND STRING
DECLARE FUNCTION GetAFont(fnFont AS INTEGER) AS LONG
'=====================================================
FUNCTION WINMAIN (BYVAL CurInst AS LONG, _
BYVAL PrvInst AS LONG, _
CmdLine AS ASCIIZ PTR, _
BYVAL CmdShow AS LONG) EXPORT AS LONG
mDialog = CurInst
DialogBox mDialog, BYVAL 100&, %HWND_DESKTOP, CODEPTR(DialogProc)
END FUNCTION
'=====================================================
FUNCTION DialogProc(BYVAL hDlg AS LONG, _
BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, _
BYVAL lParam AS LONG) AS LONG
STATIC ti AS NOTIFYICONDATA
STATIC p AS POINTAPI
LOCAL pmyitem AS MYITEM PTR ' pointer TO item's font and string
STATIC my_item() AS MYITEM ' ARRAY of MYITEMS
STATIC hmenu AS LONG ' HANDLE TO main MENU
STATIC crSelText AS LONG ' TEXT COLOR of selected item
STATIC crSelBkgnd AS LONG ' background COLOR of selected item
LOCAL crText AS LONG ' TEXT COLOR of unselected item
LOCAL crBkgnd AS LONG ' background COLOR unselected item
LOCAL lpmis AS MEASUREITEMSTRUCT PTR ' pointer TO item of DATA
LOCAL lpdis AS DRAWITEMSTRUCT PTR ' pointer TO item drawing DATA
LOCAL hdc AS LONG ' HANDLE TO screen DC
LOCAL sSize AS apiSIZE ' MENU-item TEXT extents
LOCAL wCheckX AS WORD ' checkmark width
LOCAL nTextX AS INTEGER ' width of MENU item
LOCAL nTextY AS INTEGER ' height of MENU item
'LOCAL i AS INTEGER ' LOOP counter
LOCAL hfontOld AS LONG ' HANDLE TO old font
'LOCAL fSelected AS INTEGER ' MENU-item selection flag
STATIC szBoldMenuText AS ASCIIZ*24
STATIC szItalicMenuText AS ASCIIZ*24
STATIC szUlineMenuText AS ASCIIZ*24
IF (UBOUND(my_item) = -1) THEN REDIM my_item(0 TO 3)
SELECT CASE wMsg
CASE %WM_INITDIALOG
PostMessage hDlg, %WM_USER, 0, 0
hMenu = GetSubMenu(LoadMenu(mDialog, "POPUPMENU"), 0)
GetMenuString hmenu, _
%IDM_BOLD, _
BYVAL VARPTR(szBoldMenuText), _
SIZEOF(szBoldMenuText), _
BYVAL %MF_BYCOMMAND
GetMenuString hmenu, _
%IDM_ITALIC, _
BYVAL VARPTR(szItalicMenuText), _
SIZEOF(szItalicMenuText), _
BYVAL %MF_BYCOMMAND
GetMenuString hmenu, _
%IDM_ULINE, _
BYVAL VARPTR(szUlineMenuText), _
SIZEOF(szUlineMenuText), _
BYVAL %MF_BYCOMMAND
ModifyMenu hmenu, %IDM_BOLD, %MF_BYCOMMAND OR _
%MF_OWNERDRAW, %IDM_BOLD, BYVAL VARPTR(my_item(%BOLD))
my_item(%BOLD).hfont = GetAFont(%BOLD)
my_item(%BOLD).psz = VARPTR(szBoldMenuText)
ModifyMenu hmenu, %IDM_ITALIC, %MF_BYCOMMAND OR _
%MF_OWNERDRAW, %IDM_ITALIC, BYVAL VARPTR(my_item(%ITALIC))
szItalicMenuText = "Italic"
my_item(%ITALIC).hfont = GetAFont(%ITALIC)
my_item(%ITALIC).psz = VARPTR(szItalicMenuText)
ModifyMenu hmenu, %IDM_ULINE, %MF_BYCOMMAND OR _
%MF_OWNERDRAW, %IDM_ULINE, BYVAL VARPTR(my_item(%ULINE))
szUlineMenuText = "Underlined"
my_item(%ULINE).hfont = GetAFont(%ULINE)
my_item(%ULINE).psz = VARPTR(szUlineMenuText)
ti.cbSize = SIZEOF(ti)
ti.hWnd = hDlg
ti.uID = mDialog
ti.uFlags = %NIF_ICON OR %NIF_MESSAGE OR %NIF_TIP
ti.uCallbackMessage = %WM_TRAYICON
ti.hIcon = LoadIcon(mDialog, "MY_TRAY")
ti.szTip = "My_Tray Example"
Shell_NotifyIcon %NIM_ADD, ti
DestroyIcon ti.hIcon
FUNCTION = 1
CASE %WM_USER
DIALOG SHOW STATE hDlg, %SW_HIDE
CASE %WM_TRAYICON
SELECT CASE LOWRD(lParam)
' Right button press
CASE %WM_RBUTTONDOWN
IF IsWindowVisible(hDlg) = %FALSE THEN
SetForegroundWindow hDlg
GetCursorPos p
TrackPopupMenu hMenu, 0, p.x, p.y, 0, hDlg, BYVAL %NULL
Postmessage hDlg, %WM_NULL, 0, 0
END IF
END SELECT
CASE %WM_DESTROY
' Destroy the MENU items' font handles.
FOR i = 0 TO 3
DeleteObject my_item(i).hfont
NEXT
Shell_NotifyIcon %NIM_DELETE, ti
CASE %WM_MEASUREITEM
' Retrieve a device context FOR the main window.
hdc = GetDC(hdlg)
' Retrieve pointers TO the MENU item's
' MEASUREITEMSTRUCT structure AND MYITEM structure.
lpmis = lParam
pmyitem = @lpmis.itemData
' SELECT the font associated WITH the item into
' the main window's device context.
hfontOld = SelectObject(hdc, @pmyitem.hfont)
' Retrieve the width AND height of the item's string,
' AND THEN copy the width AND height into the
' MEASUREITEMSTRUCT structure's itemWidth and
' itemHeight members.
GetTextExtentPoint32 hdc, _
BYVAL @pmyitem.psz, _
BYVAL LEN(@[email protected]), _
BYVAL VARPTR(sSize)
@lpmis.itemWidth = sSize.cx
@lpmis.itemHeight = sSize.cy
' SELECT the old font back into the device context,
' AND THEN release the device context.
SelectObject hdc, hfontOld
ReleaseDC hdlg, hdc
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_DRAWITEM
' GET pointers TO the MENU item's DRAWITEMSTRUCT
' structure AND MYITEM structure.
lpdis = lParam
pmyitem = @lpdis.itemData
' SELECT the font associated WITH the item into the
' item's device context, and then draw the string.
hfontOld = SelectObject(@lpdis.hDC, @pmyitem.hfont)
wCheckX = GetSystemMetrics(%SM_CXMENUCHECK)
nTextX = wCheckX + @lpdis.rcItem.nleft
nTextY = @lpdis.rcItem.ntop
TextOut @lpdis.hDC, _
nTextX, _
nTextY, _
BYVAL @pmyitem.psz, _
LEN(@[email protected])
' SELECT the previous font back into the device
' context.
SelectObject @lpdis.hDC, hfontOld
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_BOLD
MSGBOX "OK. My_Tray Example"
CASE %IDCANCEL
EndDialog hDlg, 0
FUNCTION = 1
END SELECT
CASE %WM_SYSCOMMAND
SELECT CASE LOWRD(wParam)
CASE %SC_MINIMIZE
ShowWindow hDlg, %SW_HIDE
FUNCTION = 1
EXIT FUNCTION
CASE %SC_CLOSE
ShowWindow hDlg, %SW_HIDE
FUNCTION = 1
EXIT FUNCTION
END SELECT
END SELECT
END FUNCTION
FUNCTION GetAFont(fnFont AS INTEGER) AS LONG
LOCAL lf AS LOGFONT ' structure FOR font information
LOCAL lResult AS LONG
LOCAL sFontName AS STRING
' GET a HANDLE TO the ANSI fixed-pitch font, AND copy
' information about the font TO a LOGFONT structure.
lResult = GetStockObject(%ANSI_VAR_FONT)
GetObject lResult, SIZEOF(lf), BYVAL VARPTR(lf)
' SET the font attributes, AS appropriate.
IF (fnFont = %BOLD) THEN ' BOLD
lf.lfHeight = -14
lf.lfWeight = %FW_BOLD
lf.lfFaceName = "Arial"
ELSE
lf.lfWeight = %FW_NORMAL
END IF
lf.lfItalic = (fnFont = %ITALIC)
lf.lfUnderline = (fnFont = %ULINE)
' CREATE the font, AND THEN RETURN its handle.
FUNCTION = CreateFontIndirect(lf)
END FUNCTION
Comment