' I had to do this experimentation for a project I'm working on.
' I thought I'd share the end results.
' I thought I'd share the end results.
Code:
'-------------------------------------------------------------------------------
'
' Font Investigation Program
' by Ian Cairns - February 15/2000
'-------------------------------------------------------------------------------
$DIM ALL
$COMPILE EXE
$DEBUG ERROR ON
$OPTION VERSION4
#INCLUDE "WIN32API.INC"
#INCLUDE "COMDLG32.INC"
' Define Menu ID codes:
%IDM_SELECTFONT = 1
%IDM_CHANGEBACKGROUND = 2
%IDM_EXIT = 3
'------------------------------------------------------------------------------
GLOBAL szAppName AS ASCIIZ*21
'------------------------------------------------------------------------------
FUNCTION WINMAIN (BYVAL hInstance AS LONG, _
BYVAL hPrevInstance AS LONG, _
lpCmdLine AS ASCIIZ PTR, _
BYVAL iCmdShow AS LONG) AS LONG
LOCAL Msg AS tagMsg
LOCAL wClass AS WndClassEx
LOCAL hWndMain AS DWORD
' Initialize
'~~~~~~~~~~~
szAppName = "Font Display Program"
' Fill window class structure
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
wClass.cbSize = SIZEOF(wClass)
wClass.style = %CS_HREDRAW OR %CS_VREDRAW
wClass.lpfnWndProc = CODEPTR(MainWndProc)
wClass.cbClsExtra = 0
wClass.cbWndExtra = 0
wClass.hInstance = hInstance
wClass.hIcon = LoadIcon (%NULL, BYVAL %IDI_APPLICATION)
wClass.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wClass.hbrBackground = GetStockObject(%WHITE_BRUSH)
wClass.lpszMenuName = VARPTR(szAppName)
wClass.lpszClassName = VARPTR(szAppName)
wClass.hIConSm = LoadIcon (%NULL, BYVAL %IDI_APPLICATION)
' Register the window-class
' ~~~~~~~~~~~~~~~~~~~~~~~~~
RegisterClassEx wClass
' Create a window using the registered class
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
hWndMain = CreateWindow(szAppName, _ ' window class name
"Font Selection and Display", _ ' window caption
%WS_OVERLAPPEDWINDOW OR _
%WS_VSCROLL OR %WS_HSCROLL,_ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%HWND_DESKTOP, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
' Show Window
'~~~~~~~~~~~~
ShowWindow hWndMain, iCmdShow
UpdateWindow hWndMain
WHILE GetMessage(Msg, %NULL, 0, 0)
TranslateMessage Msg
DispatchMessage Msg
WEND
FUNCTION = msg.wParam
END FUNCTION ' WinMain
'------------------------------------------------------------------------------
FUNCTION MainWndProc (BYVAL hWnd AS DWORD, BYVAL wMsg AS LONG, _
BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
STATIC cxCaps AS LONG,_
cxChar AS LONG,_
cyChar AS LONG,_
cxClient AS LONG,_
cyClient AS LONG,_
iMaxWidth AS LONG,_
iVscrollPos AS LONG,_
iVscrollMax AS LONG,_
iHscrollPos AS LONG,_
iHscrollMax AS LONG,_
sz_Max AS LONG,_
hMenu AS LONG, _
hMenuPopup AS LONG,_
tm AS TEXTMETRIC,_
cf AS CHOOSEFONTAPI, _
lfFont AS LOGFONT, _
lfFontRGB AS LONG,_
hFont AS LONG,_
BackgroundKolor AS CHOOSECOLORAPI
DIM FontInfo(1 : 15) AS STATIC STRING, _
tmpCustColors(0 : 15) AS STATIC DWORD
LOCAL hdc AS LONG,_
ps AS PAINTSTRUCT,_
si AS SCROLLINFO,_
x AS LONG,_
y AS LONG,_
i AS LONG,_
iPaintBeg AS LONG,_
iPaintEnd AS LONG,_
iVscrollInc AS LONG,_
iHscrollInc AS LONG,_
pointSize AS LONG
SELECT CASE wMsg
' ~~~~~~~~~~~~~~~~
CASE %WM_CREATE
' ~~~~~~~~~~~~~~~
cf.lStructSize = SIZEOF(cf)
cf.hWndOwner = hWnd
cf.hDC = %NULL
cf.lpLogFont = VARPTR(lfFont)
cf.iPointSize = 0
cf.Flags = %CF_INITTOLOGFONTSTRUCT OR %CF_EFFECTS OR %CF_BOTH' _
' OR %CF_TTONLY OR %CF_SCRIPTSONLY
cf.rgbColors = lfFontRGB
cf.lCustData = 0
cf.lpfnHook = %NULL
cf.lpTemplateName = %NULL
cf.hInstance = %NULL
cf.lpszStyle = %NULL
cf.nFontType = 0
cf.nSizeMin = 0
cf.nSizeMax = 0
CALL GetObject(GetStockObject(%SYSTEM_FONT), SIZEOF(lfFont), lfFont)
hFont = CreateFontIndirect (lfFont)
CALL SendMessage (hWnd, %WM_SETFONT, hFont, 0)
BackgroundKolor.lStructSize = SIZEOF(BackgroundKolor)
BackgroundKolor.hwndOwner = %NULL
BackgroundKolor.hInstance = %NULL
BackgroundKolor.rgbResult = RGB(&HFF, &HFF, &HFF)
BackgroundKolor.lpCustColors = VARPTR(tmpCustColors())
BackgroundKolor.Flags = %CC_RGBINIT OR %CC_FULLOPEN
BackgroundKolor.lCustData = 0
BackgroundKolor.lpfnHook = %NULL
BackgroundKolor.lpTemplateName = %NULL
' Get Text Metrics
hdc = GetDC (hWnd)
CALL GetTextMetrics (hdc, tm) 'Get font parameters
cxChar = tm.tmAveCharWidth 'Average character width
IF (tm.tmPitchAndFamily AND 1) THEN 'Average uppercase width
cxCaps = cxChar * 3 \ 2 '(same as cxChar for fixed
ELSE ' pitch, 150% for variable)
cxCaps = cxChar
END IF
cyChar = tm.tmHeight + tm.tmExternalLeading 'Line spacing
CALL ReleaseDC (hWnd, hdc)
iMaxWidth = 30 * cxChar + cxCaps
sz_Max = 15
' Create Menu
hMenu = CreateMenu ()
hMenuPopup = CreateMenu ()
CALL AppendMenu (hMenuPopup, %MF_STRING, %IDM_SELECTFONT, "&Select Font ...")
CALL AppendMenu (hMenuPopup, %MF_STRING, %IDM_CHANGEBACKGROUND, "&Change Background Color ...")
CALL AppendMenu (hMenuPopup, %MF_STRING, %IDM_EXIT, "E&xit")
CALL AppendMenu (hMenu, %MF_POPUP, hMenuPopup, "&Menu")
CALL SetMenu (hWnd, hMenu)
' Resize resets Scrollbars
CASE %WM_SIZE
' ~~~~~~~~~~~~~
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
' Set Vertical Scroll bar Range and page Size
si.cbSize = LEN(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = MAX%(1, sz_Max)
si.nPage = cyClient / cyChar
CALL SetScrollInfo(hWnd, %SB_VERT, si, %TRUE)
' Set Horizontal Scroll bar Range and page Size
si.cbSize = LEN(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = MAX%(1, 1 + iMaxWidth / cxChar)
si.nPage = cxClient / cxChar
CALL SetScrollInfo(hWnd, %SB_HORZ, si, %TRUE)
FUNCTION = 0
CASE %WM_VSCROLL
' ~~~~~~~~~~~~~~~~
si.cbSize = LEN(si)
si.fMask = %SIF_ALL
CALL GetScrollInfo(hWnd, %SB_VERT, si)
iVscrollPos = si.nPos
SELECT CASE LOWRD(wParam)
CASE %SB_TOP
si.nPos = si.nMin
CASE %SB_BOTTOM
si.nPos = si.nMax
CASE %SB_LINEUP
DECR si.nPos
CASE %SB_LINEDOWN
INCR si.nPos
CASE %SB_PAGEUP
si.nPos = si.nPos - si.nPage
CASE %SB_PAGEDOWN
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBTRACK
si.nPos = si.nTrackPos
END SELECT
si.fMask = %SIF_POS
CALL SetScrollInfo(hWnd, %SB_VERT, si, %TRUE)
CALL GetScrollInfo(hWnd, %SB_VERT, si)
IF si.nPos <> iVscrollPos THEN
CALL ScrollWindow(hWnd, 0, cyChar * (iVscrollPos - si.nPos), BYVAL %NULL, BYVAL %NULL)
CALL UpdateWindow(hWnd)
END IF
FUNCTION = 0
CASE %WM_HSCROLL
' ~~~~~~~~~~~~~~~~
si.cbSize = LEN(si)
si.fMask = %SIF_ALL
CALL GetScrollInfo(hWnd, %SB_HORZ, si)
iHscrollPos = si.nPos
SELECT CASE LOWRD(wParam)
CASE %SB_LEFT
si.nPos = si.nMin
CASE %SB_RIGHT
si.nPos = si.nMax
CASE %SB_LINELEFT
DECR si.nPos
CASE %SB_LINERIGHT
INCR si.nPos
CASE %SB_PAGELEFT
si.nPos = si.nPos - si.nPage
CASE %SB_PAGERIGHT
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBTRACK
si.nPos = si.nTrackPos
END SELECT
si.fMask = %SIF_POS
CALL SetScrollInfo(hWnd, %SB_HORZ, si, %TRUE)
CALL GetScrollInfo(hWnd, %SB_HORZ, si)
IF si.nPos <> iHscrollPos THEN
CALL ScrollWindow(hWnd, cxChar * (iHscrollPos - si.nPos), 0,BYVAL %NULL, BYVAL %NULL)
CALL UpdateWindow(hWnd)
END IF
FUNCTION = 0
' Translate Key messages into Scroll Messages
CASE %WM_KEYDOWN
' ~~~~~~~~~~~~~~~~
SELECT CASE (wParam)
CASE %VK_HOME
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_TOP, 0)
CASE %VK_END
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_BOTTOM, 0)
CASE %VK_PRIOR 'PgUp
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_PAGEUP, 0)
CASE %VK_NEXT 'PgDn
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_PAGEDOWN, 0)
CASE %VK_UP
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_LINEUP, 0)
CASE %VK_DOWN
CALL SendMessage (hWnd, %WM_VSCROLL, %SB_LINEDOWN, 0)
CASE %VK_LEFT
CALL SendMessage (hWnd, %WM_HSCROLL, %SB_LINEUP, 0)
CASE %VK_RIGHT
CALL SendMessage (hWnd, %WM_HSCROLL, %SB_LINEDOWN, 0)
END SELECT
CASE %WM_PAINT
' ~~~~~~~~~~~~~~
ps.fErase = 0
hdc = BeginPaint(hWnd, ps) 'initiates window painting
CALL SelectObject (hdc, CreateFontIndirect(lfFont))
CALL SetBkColor (hdc, BackgroundKolor.rgbResult)
CALL FillRect(hdc,ps.rcPaint, CreateSolidBrush (BackgroundKolor.rgbResult) )
CALL SetBkMode (hdc, %TRANSPARENT)
CALL SetTextColor (hdc, lfFontRGB)
' Get Vertical ScrollBar position
si.cbSize = LEN(si)
si.fMask = %SIF_ALL
CALL GetScrollInfo(hWnd, %SB_VERT, si)
iVscrollPos = si.nPos
' Get Horizontal ScrollBar position
si.cbSize = LEN(si)
si.fMask = %SIF_ALL
CALL GetScrollInfo(hWnd, %SB_HORZ, si)
iHscrollPos = si.nPos
' Set area for painting
iPaintBeg = MAX%(0, iVscrollPos + ps.rcPaint.nTop / cyChar)
iPaintEnd = MIN (sz_Max, iVscrollPos + ps.rcPaint.nBottom /cyChar +1)
x = cxChar * (1 - iHscrollPos) - cxChar
y = cyChar * (i - iVscrollPos) - cyChar
FOR i = iPaintBeg TO iPaintEnd
y = cyChar * (i - iVscrollPos) - cyChar
CALL TextOut (hdc, x, y, BYCOPY FontInfo(i), LEN(FontInfo(i)))
NEXT i
CALL EndPaint(hWnd, ps) 'ends window painting
FUNCTION = 0
' Actions based on Menu Choices:
CASE %WM_COMMAND
' ~~~~~~~~~~~~~~~~
hMenu = GetMenu (hWnd)
SELECT CASE LOWRD(wParam)
CASE %IDM_SELECTFONT
' ~~~~~~~~~~~~~~~~~~~~
IF ChooseFont (cf) THEN
lfFontRGB = cf.rgbColors
CALL DeleteObject (hFont)
hFont = CreateFontIndirect (lfFont)
hdc = GetDC (hWnd)
CALL SelectObject (hdc, hFont)
' Get Text Metrics
CALL GetTextMetrics (hdc, tm) 'Get font parameters
' Alternate method of getting point size without going through ChooseFont:
' pointSize = (tm.tmHeight - tm.tmInternalLeading) * (72 / GetDeviceCaps(hdc, %LOGPIXELSY) )
CALL ReleaseDC (hWnd, hdc)
cxChar = tm.tmAveCharWidth 'Average character width
IF (tm.tmPitchAndFamily AND 1) THEN 'Average uppercase width
cxCaps = cxChar * 3 \ 2 '(same as cxChar for fixed
ELSE ' pitch, 150% for variable)
cxCaps = cxChar
END IF
cyChar = tm.tmHeight + tm.tmExternalLeading 'Line spacing
FontInfo(1) = "FaceName: " + lfFont.lfFacename
FontInfo(2) = "Point Size: " + STR$( cf.iPointSize/10)
FontInfo(3) = "PitchAndFamily: " + LTRIM$(STR$(lfFont.lfPitchAndFamily))
FontInfo(4) = "Height: " + LTRIM$(STR$(lfFont.lfHeight))
FontInfo(5) = "Width: " + LTRIM$(STR$(lfFont.lfWidth))
FontInfo(6) = "Escapement: " + LTRIM$(STR$(lfFont.lfEscapement))
FontInfo(7) = "Orientation: " + LTRIM$(STR$(lfFont.lfOrientation))
FontInfo(8) = "Weight: " + LTRIM$(STR$(lfFont.lfWeight))
FontInfo(9) = "Italic: " + LTRIM$(STR$(lfFont.lfItalic))
FontInfo(10) = "Underline: " + LTRIM$(STR$(lfFont.lfUnderline))
FontInfo(11) = "Strikeout: " + LTRIM$(STR$(lfFont.lfStrikeout))
FontInfo(12) = "CharSet: " + LTRIM$(STR$(lfFont.lfCharSet))
FontInfo(13) = "OutPrecision: " + LTRIM$(STR$(lfFont.lfOutPrecision))
FontInfo(14) = "ClipPrecision: " + LTRIM$(STR$(lfFont.lfClipPrecision))
FontInfo(15) = "Quality: " + LTRIM$(STR$(lfFont.lfQuality))
iMaxWidth = 1
FOR i = 1 TO 15
iMaxWidth = MAX(iMaxWidth,LEN(FontInfo(i)) )
NEXT i
iMaxWidth = (iMaxWidth+1) * cxChar + cxCaps
CALL InvalidateRect(hWnd, BYVAL %NULL, 1) ' Paint Entire Client Window
CALL SendMessage(hWnd, %WM_SIZE, cxClient, cyClient) ' Reset Scroll Bars
END IF
FUNCTION = 0
CASE %IDM_CHANGEBACKGROUND
' ~~~~~~~~~~~~~~~~~~~~~~~~~~
' Select Colored Brush into Device Context
IF ChooseColor ( BackgroundKolor ) > 0 THEN
CALL InvalidateRect(hWnd, BYVAL %NULL, 1) 'Paint Entire Client Window
END IF
FUNCTION = 0
CASE %IDM_EXIT
' ~~~~~~~~~~~~~~
CALL DeleteObject(hFont)
PostQuitMessage 0
FUNCTION = 0
END SELECT
CASE %WM_DESTROY
' ~~~~~~~~~~~~~~~~
CALL DeleteObject(hFont)
PostQuitMessage 0
FUNCTION = 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
END FUNCTION
'-----------------------------------------------------------------------------