Problem in WM_PAINT
22 views
Skip to first unread message
stapper
Dec 23, 2011, 3:54:13 AM12/23/11
to xblite
Hi,
I have a problem with a program (sysmets) from Petzolds book.
Its only displays 1 line in in the GUI but in the console it displays
4 lines like it should.
Here is an extract from the program. Can someone help me ?
Thanks in advance
FUNCTION WndProc (hWnd, msg, wParam, lParam)
STATIC XLONG cxChar,cyChar,test,cxCaps,teller,numlines
STRING test$
PAINTSTRUCT ps
RECT wRect
TEXTMETRIC tm
DIM sysmetrics_label$[3]
DIM sysmetrics_desc$[3]
sysmetrics_label$[0] = "SM_CXSCREEN"
sysmetrics_label$[1] = "SM_CYSCREEN"
sysmetrics_label$[2] = "SM_CXVSCROLL"
sysmetrics_label$[3] = "SM_CYHSCROLL"
sysmetrics_desc$[0] = "Screen width in pixels"
sysmetrics_desc$[1] = "Screen heigth in pixels"
sysmetrics_desc$[2] = "Vertical scroll width"
sysmetrics_desc$[3] = "Vertical scroll heigth"
numlines = 4
SELECT CASE msg
CASE $$WM_CREATE:
hdc = GetDC(hWnd)
GetTextMetricsA(hdc,&tm)
cxChar = tm.avgCharWidth
test = tm.pitchAndFamily
IF test = $$TMPF_FIXED_PITCH THEN
cxCaps = cxChar
ELSE
cxCaps = cxChar / 2 + cxChar
ENDIF
cyChar = tm.weight + tm.externalLeading
ReleaseDC(hWnd,hdc)
CASE $$WM_PAINT:
hdc = BeginPaint (hWnd, &ps) ' prepare window for painting, drawing,
filling
DO WHILE (teller < numlines)
test$ = STR$(GetSystemMetrics(teller))
TextOutA (hdc, 0, cyChar * teller, &sysmetrics_label$[teller],
LENN(CSIZE$(sysmetrics_label$[teller])))
TextOutA (hdc, 22 * cxCaps, cyChar * teller,
&sysmetrics_desc$[teller], LEN(CSIZE$(sysmetrics_desc$[teller])))
SetTextAlign(hdc, TA_RIGHT | TA_TOP)
TextOutA (hdc, 22 * cxCaps + 40 * cxChar, cyChar * teller, &test$,
LEN(CSIZE$(test$)))
' TextOutA (hdc, 22 * cxCaps + 40 * cxChar, cyChar * teller, STR$
(GetSystemMetrics[teller]), 10)
SetTextAlign(hdc, TA_LEFT | TA_TOP)
PRINT teller
PRINT sysmetrics_label$[teller]
PRINT sysmetrics_desc$[teller]
PRINT STR$(GetSystemMetrics(teller))
INC teller
LOOP
EndPaint (hWnd, &ps) ' finished painting window
CASE $$WM_DESTROY:
PostQuitMessage(0)
CASE ELSE :
RETURN DefWindowProcA (hWnd, msg, wParam, lParam)
END SELECT
END FUNCTION
I have a problem with a program (sysmets) from Petzolds book.
Its only displays 1 line in in the GUI but in the console it displays
4 lines like it should.
Here is an extract from the program. Can someone help me ?
Thanks in advance
FUNCTION WndProc (hWnd, msg, wParam, lParam)
STATIC XLONG cxChar,cyChar,test,cxCaps,teller,numlines
STRING test$
PAINTSTRUCT ps
RECT wRect
TEXTMETRIC tm
DIM sysmetrics_label$[3]
DIM sysmetrics_desc$[3]
sysmetrics_label$[0] = "SM_CXSCREEN"
sysmetrics_label$[1] = "SM_CYSCREEN"
sysmetrics_label$[2] = "SM_CXVSCROLL"
sysmetrics_label$[3] = "SM_CYHSCROLL"
sysmetrics_desc$[0] = "Screen width in pixels"
sysmetrics_desc$[1] = "Screen heigth in pixels"
sysmetrics_desc$[2] = "Vertical scroll width"
sysmetrics_desc$[3] = "Vertical scroll heigth"
numlines = 4
SELECT CASE msg
CASE $$WM_CREATE:
hdc = GetDC(hWnd)
GetTextMetricsA(hdc,&tm)
cxChar = tm.avgCharWidth
test = tm.pitchAndFamily
IF test = $$TMPF_FIXED_PITCH THEN
cxCaps = cxChar
ELSE
cxCaps = cxChar / 2 + cxChar
ENDIF
cyChar = tm.weight + tm.externalLeading
ReleaseDC(hWnd,hdc)
CASE $$WM_PAINT:
hdc = BeginPaint (hWnd, &ps) ' prepare window for painting, drawing,
filling
DO WHILE (teller < numlines)
test$ = STR$(GetSystemMetrics(teller))
TextOutA (hdc, 0, cyChar * teller, &sysmetrics_label$[teller],
LENN(CSIZE$(sysmetrics_label$[teller])))
TextOutA (hdc, 22 * cxCaps, cyChar * teller,
&sysmetrics_desc$[teller], LEN(CSIZE$(sysmetrics_desc$[teller])))
SetTextAlign(hdc, TA_RIGHT | TA_TOP)
TextOutA (hdc, 22 * cxCaps + 40 * cxChar, cyChar * teller, &test$,
LEN(CSIZE$(test$)))
' TextOutA (hdc, 22 * cxCaps + 40 * cxChar, cyChar * teller, STR$
(GetSystemMetrics[teller]), 10)
SetTextAlign(hdc, TA_LEFT | TA_TOP)
PRINT teller
PRINT sysmetrics_label$[teller]
PRINT sysmetrics_desc$[teller]
PRINT STR$(GetSystemMetrics(teller))
INC teller
LOOP
EndPaint (hWnd, &ps) ' finished painting window
CASE $$WM_DESTROY:
PostQuitMessage(0)
CASE ELSE :
RETURN DefWindowProcA (hWnd, msg, wParam, lParam)
END SELECT
END FUNCTION
Guy1954
Dec 26, 2011, 9:47:19 AM12/26/11
to xblite
Hi Stapper,
Your problem occurs because of a wrong nYStart for API TextOutA (hdc,
x, nYStart, &text$, LEN (text$))
Replacing nYStart = cyChar * teller
by nYStart = 20 * teller makes it work.
Follows my version of your sysmets.
Bye! Guy
PROGRAM "sysmets"
VERSION "1.00"
'
' sysmets - pb with TextOutA
' Copyright © GPL 2011 Guy Lonne.
'
' ***** Description *****
' Stappler-23dec11
' Your problem occurs because of a wrong nYStart for API TextOutA
(hdc, x, nYStart, &text$, LEN (text$))
' Replacing nYStart = cyChar * teller
' by nYStart = 20 * teller makes it work.
'
' ***** Notes *****
' - Use constants $$TA_RIGHT and $$TA_TOP
' - Don't use CSIZE$(*)
' - Don't use cyChar == 700
' nYStart = cyChar * teller
' nYStart = 20 * teller
'
' ***** Versions *****
' 1.00-26dec11-Guy-original version.
'
'
' ##############################
' ##### Import Libraries #####
' ##############################
'
'
' Win32API DLL headers
'
IMPORT "kernel32" ' operating system
'
' ---Note: import gdi32 BEFORE shell32 and user32
IMPORT "gdi32" ' Graphic Device Interface
IMPORT "shell32" ' interface to the operating system
IMPORT "user32" ' Windows management
'
' ---Note: import comctl32 BEFORE comdlg32
IMPORT "comctl32" ' common controls; ==> initialize w/
InitCommonControlsEx ()
' IMPORT "comdlg32" ' standard dialog boxes (opening and saving
files ...)
'
' xblite DLL headers
'
IMPORT "xst" ' xblite Standard Library
IMPORT "xsx" ' xblite Extended Standard Library
IMPORT "xio" ' console
'
'
'
'
' ############################################
' ##### Internal Function Declarations #####
' ############################################
'
'
DECLARE FUNCTION Entry () ' program entry point
DECLARE FUNCTION CleanUp () ' application cleanup
DECLARE FUNCTION CreateWindows () ' create the windows of the
application
DECLARE FUNCTION GetNotifyMsg (lParam, @hwndFrom, @idFrom, @code) '
get event that has occurred in a control
DECLARE FUNCTION GuiTellApiError (msg$) ' displays an API error
message
DECLARE FUNCTION GuiTellRunError (msg$) ' displays an execution error
message
DECLARE FUNCTION InitGui () ' initialize win32 controls and libraries
DECLARE FUNCTION InitWindows () ' for initializations after
CreateWindows()
DECLARE FUNCTION MessageLoop () ' main message loop
DECLARE FUNCTION NewChild (className$, text$, style, x, y, w, h,
parent, id, exStyle) ' create a child window
DECLARE FUNCTION NewWindow (className$, titleBar$, style, x, y, w, h,
exStyle) ' create a window
DECLARE FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu
$) ' register the window class
DECLARE FUNCTION StartUp () ' application setup
DECLARE FUNCTION WapiGetText$ (hCtr) ' get the text from a control
DECLARE FUNCTION WapiKillFont (@hFont) ' release a font created by
WapiNewFont
DECLARE FUNCTION WapiNewFont (fontName$, pointSize, weight, italic,
underline, strikeOut) ' create a new logical font
DECLARE FUNCTION WapiSetFont (hCtr, hFont) ' apply font to control
DECLARE FUNCTION WndProc (hWnd, wMsg, wParam, lParam) ' callback
function for window #winMain
'
'
' #########################################
' ##### Shared Constant Definitions #####
' #########################################
'
'
' ***** Constants used as control identificators for window #winMain
*****
'
' control identificators for #winMain
$$mleSysMets = 101 ' multiline edit
'
' ***** Shared Program Constants *****
'
'
'
' #################################
' ##### Program Entry Point #####
' #################################
'
FUNCTION Entry ()
STATIC entry ' ensure Entry is entered only one time
IF entry THEN RETURN ' enter once
entry = $$TRUE ' enter occured
XioCreateConsole ("", 100) ' create console, if console is not
wanted, comment out this line
IF StartUp () THEN XstAbend ("Can't initialize the
application")
IF InitGui () THEN XstAbend ("Can't initialize the GUI")
IF CreateWindows () THEN XstAbend ("Can't create the window(s)")
InitWindows () ' for initializations after CreateWindows()
MessageLoop () ' monitor the events
CleanUp () ' application cleanup
XioFreeConsole () ' free console
QUIT (0)
END FUNCTION
FUNCTION CleanUp () ' application cleanup
SHARED hInst
SHARED hFontDefault ' default control font
IF #winMain THEN
SetLastError (0)
ret = DestroyWindow (#winMain) ' destroy window #winMain
IFZ ret THEN ' fail
msg$ = "DestroyWindow: Can't destroy window #winMain"
GuiTellApiError (msg$)
ENDIF
'
ENDIF
#winMain = 0
className$ = #winMain_class$
SetLastError (0)
ret = UnregisterClassA (&className$, hInst) ' unregister window
class #winMain_class$
IFZ ret THEN ' fail
msg$ = "UnregisterClassA: Can't unregister window class
#winMain_class$"
GuiTellApiError (msg$)
ENDIF
WapiKillFont (@hFontDefault) ' release the default control font
END FUNCTION
'
'
' ##############################
' ##### CreateWindows () #####
' ##############################
'
FUNCTION CreateWindows () ' create the windows of the application
SHARED hInst
' ***************** Begin window #winMain Generation
*****************
' register the window class for window #winMain
#winMain_class$ = "winMainClass"
addrWndProc = &WndProc ()
icon$ = "" ' no icon
menu$ = "" ' no menu
SetLastError (0)
bErr = RegisterWinClass (#winMain_class$, addrWndProc, icon$, menu
$) ' register window class \"winMainClass\"
IF bErr THEN ' fail
msg$ = "RegisterWinClass: Can't register window class
\"winMainClass\""
GuiTellApiError (msg$)
ENDIF
' create window #winMain
titleBar$ = "Problem with TextOutA"
style = $$WS_OVERLAPPEDWINDOW
#winMain = NewWindow (#winMain_class$, titleBar$, style, 0, 0, 500,
500, 0) ' create window #winMain
IFZ #winMain THEN ' fail: null handle
msg$ = "NewWindow: Can't create window #winMain"
XstAlert (msg$)
RETURN $$TRUE ' fail
ENDIF
' ***************** End window #winMain Generation *****************
XstCenterWindow (#winMain) ' auto-center the window
ShowWindow (#winMain, $$SW_SHOWNORMAL) ' show the window
END FUNCTION
FUNCTION GetNotifyMsg (lParam, @hwndFrom, @idFrom, @code) ' get
event that has occurred in a control
NMHDR nmhdr
' XstCopyMemory (lParam, &nmhdr, SIZE(nmhdr)) 'Xsx library function
RtlMoveMemory (&nmhdr, lParam, SIZE (nmhdr)) 'kernel32 library
function
hwndFrom = nmhdr.hwndFrom
idFrom = nmhdr.idFrom
code = nmhdr.code
END FUNCTION
FUNCTION GuiTellApiError (msg$) ' display an API error message
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
'
' Usage:
' SetLastError (0)
' hDefaultFont = GetStockObject ($$ANSI_VAR_FONT) ' get the ANSI
default font
' IFZ hDefaultFont THEN ' fail
' msg$ = "Can't get the ANSI default font with 'GetStockObject ($
$ANSI_VAR_FONT)'"
' GuiTellApiError (msg$)
' ENDIF
' get the last error code, then clear it
errNum = GetLastError ()
SetLastError (0)
IFZ errNum THEN RETURN ' was OK!
fmtMsg$ = "Last error code " + STRING$ (errNum) + ": "
lenBuf = 1020
szBuf$ = NULL$ (lenBuf) ' fill szBuf$ with (lenBuf + 1) null
chars
' set up FormatMessageA arguments
dwFlags = $$FORMAT_MESSAGE_FROM_SYSTEM | $
$FORMAT_MESSAGE_IGNORE_INSERTS
' format a message string
ret = FormatMessageA (dwFlags, 0, errNum, 0, &szBuf$, lenBuf, 0)
IFZ ret THEN
fmtMsg$ = fmtMsg$ + "(unknown)"
ELSE
fmtMsg$ = fmtMsg$ + CSTRING$ (&szBuf$)
ENDIF
fmtMsg$ = fmtMsg$ + "\r\n" + msg$
IFZ msg$ THEN fmtMsg$ = fmtMsg$ + "Windows API error"
XstGetOSName (@os$)
XstGetOSVersion (@major, @minor, @platformId, @version$, @platform$)
text$ = "\r\nOS: " + os$ + STR$ (major) + "." + STRING$ (minor) + "
" + platform$
fmtMsg$ = fmtMsg$ + text$
' set up MessageBoxA arguments
title$ = PROGRAM$ (0) + "-API Error"
hwnd = GetActiveWindow ()
MessageBoxA (hwnd, &fmtMsg$, &title$, $$MB_ICONSTOP)
RETURN $$TRUE ' an error really occurred!
END FUNCTION
FUNCTION GuiTellRunError (msg$) ' display the run-time error
message
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
'
' Usage:
' errNum = ERROR (0)
' inFile = OPEN (#inFile$, $$RD)
' IF inFile < 3 THEN
' msg$ = "Can't open input file " + #inFile$
' GuiTellRunError (msg$)
' ENDIF
' get current error, then clear it
errNum = ERROR (0)
IFZ errNum THEN RETURN ' was OK!
fmtMsg$ = "Error code " + STRING$ (errNum) + ": " + ERROR$ (errNum)
+ "\r\n" + msg$
IFZ msg$ THEN fmtMsg$ = fmtMsg$ + "Xblite library error"
' set up MessageBoxA arguments
title$ = PROGRAM$ (0) + "-Execution Error"
hwnd = GetActiveWindow ()
MessageBoxA (hwnd, &fmtMsg$, &title$, $$MB_ICONSTOP)
RETURN $$TRUE ' an error really occurred!
END FUNCTION
FUNCTION InitGui () ' initialize win32 controls and libraries
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
SHARED hInst
SHARED hFontDefault ' default control font
INITCOMMONCONTROLSEX icc
hInst = GetModuleHandleA (0) ' get current instance handle
IFZ hInst THEN XstAbend ("Application TERMINATED! InitGui: Can't get
current instance handle")
' initialize the specific common controls classes
' from the common control dynamic-link library
icc.dwSize = SIZE (icc)
' $$ICC_ANIMATE_CLASS : animate
' $$ICC_BAR_CLASSES : toolbar, statusbar, trackbar, tooltips
' $$ICC_COOL_CLASSES : rebar (coolbar) control
' $$ICC_DATE_CLASSES : month picker, date picker, time picker,
updown
' $$ICC_HOTKEY_CLASS : hotkey
' $$ICC_INTERNET_CLASSES : WIN32_IE >= 0x0400
' $$ICC_LISTVIEW_CLASSES : listview, header
' $$ICC_PAGESCROLLER_CLASS : page scroller (WIN32_IE >= 0x0400)
' $$ICC_PROGRESS_CLASS : progress
' $$ICC_TAB_CLASSES : tab, tooltips
' $$ICC_TREEVIEW_CLASSES : treeview, tooltips
' $$ICC_UPDOWN_CLASS : updown
' $$ICC_USEREX_CLASSES : comboex
' $$ICC_WIN95_CLASSES : everything else
icc.dwICC = $$ICC_ANIMATE_CLASS | _
$$ICC_BAR_CLASSES | _
$$ICC_COOL_CLASSES | _
$$ICC_DATE_CLASSES | _
$$ICC_HOTKEY_CLASS | _
$$ICC_INTERNET_CLASSES | _
$$ICC_LISTVIEW_CLASSES | _
$$ICC_NATIVEFNTCTL_CLASS | _
$$ICC_PAGESCROLLER_CLASS | _
$$ICC_PROGRESS_CLASS | _
$$ICC_TAB_CLASSES | _
$$ICC_TREEVIEW_CLASSES | _
$$ICC_UPDOWN_CLASS | _
$$ICC_USEREX_CLASSES | _
$$ICC_WIN95_CLASSES
InitCommonControlsEx (&icc) ' initialize comctl32.dll library
hFontDefault = GetStockObject ($$ANSI_VAR_FONT) ' get the ANSI
default font
IFZ hFontDefault THEN ' fail
msg$ = "InitGui: Can't get the ANSI default font with
'GetStockObject ($$ANSI_VAR_FONT)'"
XstAlert (msg$)
ENDIF
END FUNCTION
'
'
' ############################
' ##### InitWindows () #####
' ############################
'
FUNCTION InitWindows () ' for initializations after CreateWindows()
ShowWindow (#winMain, $$SW_SHOW) ' show window #winMain
END FUNCTION
FUNCTION MessageLoop () ' main message loop
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE on quit
MSG wMsg ' will be sent to window callback function when an event
occurs
' reserved to a stand-alone application
' IF LIBRARY (0) THEN RETURN ' main program executes message loop
' supervise system messages until
' - the user decides to leave the application (RETURN $$FALSE)
' - an error occurred (RETURN $$TRUE)
DO ' the message loop
' retrieve next message from queue
ret = GetMessageA (&wMsg, 0, 0, 0)
SELECT CASE ret
CASE 0 : RETURN ' received a quit message
CASE -1 : RETURN $$TRUE ' fail
CASE ELSE
' deal with window messages
hWnd = GetActiveWindow ()
'
IF (!IsWindow (hWnd)) || (!IsDialogMessageA (hWnd, &wMsg))
THEN
' send only non-dialog messages
' translate virtual-key messages into character messages
' ex.: SHIFT + a is translated as "A"
TranslateMessage (&wMsg)
'
' send message to window callback function
DispatchMessageA (&wMsg)
ENDIF
END SELECT
LOOP ' forever
END FUNCTION
FUNCTION NewChild (className$, text$, style, x, y, w, h, hParent,
idCtr, exStyle) ' create a child window
'
' Arguments
' - className$: control's class
' - text$ : title
' - style : style
' - x : Left
' - y : Top
' - w : Width
' - h : Height
' - hParent : window or parent control
' - idCtr : control ID
' - exStyle : extended style
'
' Returns
' - The child window's handle if OK!, 0 = error
SHARED hInst
IFZ TRIM$ (className$) THEN
msg$ = "NewChild: Can't create the child window " + text$ + ",
with an empty control class"
XstAlert (msg$)
RETURN ' fail
ENDIF
IFZ hParent THEN
msg$ = "NewChild: Can't create the child window " + text$ + ",
control class " + className$ + " without a parent"
XstAlert (msg$)
RETURN ' fail
ENDIF
' create the child window
newStyle = style | $$WS_CHILD | $$WS_VISIBLE
SetLastError (0)
hCtr = CreateWindowExA (exStyle, &className$, &text$, newStyle, x,
y, w, h, hParent, idCtr, hInst, 0)
IFZ hCtr THEN
msg$ = "NewChild: Can't create the child window " + text$ + " with
CreateWindowExA, control class " + className$
GuiTellApiError (msg$)
ENDIF
RETURN hCtr
END FUNCTION
FUNCTION NewWindow (className$, titleBar$, style, x, y, w, h,
exStyle) ' create a window
'
' Arguments
' - className$: window's class
' - titleBar$ : title
' - style : style
' - x : Left
' - y : Top
' - w : Width
' - h : Height
' - exStyle : extended style
'
' Returns
' - The window's handle if OK!, 0 = error
SHARED hInst
SetLastError (0)
hWin = CreateWindowExA (exStyle, &className$, &titleBar$, style, x,
y, w, h, 0, 0, hInst, 0)
IFZ hWin THEN
msg$ = "NewWindow: Can't create the window " + titleBar$ + " with
CreateWindowExA, window class " + className$
GuiTellApiError (msg$)
ENDIF
RETURN hWin
END FUNCTION
FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu$) '
register the window class
SHARED hInst
WNDCLASS wc ' window class
wc.style = $$CS_HREDRAW | $$CS_VREDRAW | $$CS_OWNDC
wc.lpfnWndProc = addrWndProc
wc.cbClsExtra = 0 ' no extra bytes after the window class
wc.cbWndExtra = 0 ' structure or the window instance
wc.hInstance = hInst
IF icon$ THEN wc.hIcon = LoadIconA (hInst, &icon$)
wc.hCursor = LoadCursorA (0, $$IDC_ARROW)
wc.hbrBackground = $$COLOR_BTNFACE + 1
IF menu$ THEN wc.lpszMenuName = &menu$
wc.lpszClassName = &className$
SetLastError (0)
ret = RegisterClassA (&wc)
IFZ ret THEN
msg$ = "RegisterWinClass: Can't register the window class " +
className$
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
END FUNCTION
FUNCTION StartUp () ' application setup
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
SHARED hInst
SetLastError (0)
hInst = GetModuleHandleA (0) ' get current instance handle
IFZ hInst THEN
msg$ = "GetModuleHandleA: Can't get current instance handle"
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
END FUNCTION
FUNCTION WapiGetText$ (hCtr) ' get the text from a control
' hCtr = the handle to the control
' returns a string containing the control's text
IFZ hCtr THEN RETURN "" ' fail
cch = GetWindowTextLengthA (hCtr) ' get the character count
IF cch < 1 THEN RETURN "" ' empty text
sizeBuf = cch + 1 ' note increment 1!
szBuf$ = NULL$ (sizeBuf)
SetLastError (0)
ret = GetWindowTextA (hCtr, &szBuf$, sizeBuf) ' get the text
IFZ ret THEN RETURN "" ' fail
text$ = CSTRING$ (&szBuf$)
RETURN text$ ' success
END FUNCTION
FUNCTION WapiKillFont (@hFont) ' release a font created by
WapiNewFont
IFZ hFont THEN RETURN $$TRUE ' fail
SetLastError (0)
ret = DeleteObject (hFont) ' release the font
IFZ ret THEN ' fail
msg$ = "DeleteObject: Can't release the font"
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
hFont = 0
END FUNCTION
FUNCTION WapiNewFont (fontName$, pointSize, weight, italic, underline,
strikeOut) ' create a new logical font
' Returns the font handle if success, 0 = fail
LOGFONT oLogFont
' check fontName$ not empty
fontName$ = TRIM$ (fontName$)
IFZ fontName$ THEN
XstAlert ("WapiNewFont: empty font face")
RETURN ' fail
ENDIF
errNum = SetLastError (0)
hfontToClone = GetStockObject ($$DEFAULT_GUI_FONT) ' get a font
to clone
IFZ hfontToClone THEN ' fail: null handle
msg$ = "GetStockObject: Can't get a font to clone"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
' hfontToClone provides with a well-formed font structure
errNum = SetLastError (0)
bytes = GetObjectA (hfontToClone, SIZE (oLogFont), &oLogFont) '
allocate structure font
IFZ bytes THEN ' fail: null handle
msg$ = "GetObjectA: Can't allocate structure font"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
' release the cloned font
DeleteObject (hfontToClone)
hfontToClone = 0
' set the cloned font structure with the passed parameters
oLogFont.faceName = fontName$
IFZ pointSize THEN
oLogFont.height = 0
ELSE
' character height is specified (in points)
IF pointSize > 0 THEN
pointH = pointSize
ELSE
pointH = - pointSize ' make it positive
ENDIF
'
' convert pointSize to pixels
errNum = SetLastError (0)
hdc = GetDC ($$HWND_DESKTOP) ' get the desktop context's handle
IFZ hdc THEN ' fail: null handle
msg$ = "GetDC: Can't get the desktop context's handle"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
'
' Windows expects the font height to be in pixels and negative
oLogFont.height = MulDiv (pointH, GetDeviceCaps (hdc, $
$LOGPIXELSY), -72)
ReleaseDC ($$HWND_DESKTOP, hdc) ' release the handle of the
desktop context
ENDIF
SELECT CASE weight
CASE $$FW_THIN, $$FW_EXTRALIGHT, $$FW_LIGHT, $$FW_NORMAL, $
$FW_MEDIUM, _
$$FW_SEMIBOLD, $$FW_BOLD, $$FW_EXTRABOLD, $$FW_HEAVY, $
$FW_DONTCARE
oLogFont.weight = weight
'
CASE ELSE : oLogFont.weight = $$FW_NORMAL
END SELECT
IF italic THEN
oLogFont.italic = 1
ELSE
oLogFont.italic = 0
ENDIF
IF underline THEN
oLogFont.underline = 1
ELSE
oLogFont.underline = 0
ENDIF
IF strikeOut THEN
oLogFont.strikeOut = 1
ELSE
oLogFont.strikeOut = 0
ENDIF
errNum = SetLastError (0)
hFont = CreateFontIndirectA (&oLogFont) ' create logical font
hFont
IFZ hFont THEN ' fail: null handle
msg$ = "CreateFontIndirectA: Can't create logical font hFont"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
RETURN hFont
END FUNCTION
FUNCTION WapiSetFont (hCtr, hFont) ' apply font to control
IFZ hCtr THEN RETURN ' ignore null control handle
' check hFont not null
IFZ hFont THEN
XstAlert ("WapiSetFont: Ignore null font handle")
RETURN $$TRUE ' fail
ENDIF
' $$WM_SETFONT does not return a value
SendMessageA (hCtr, $$WM_SETFONT, hFont, 0)
END FUNCTION
FUNCTION WndProc (hWnd, wMsg, wParam, lParam) ' callback function
for window #winMain
SHARED hInst
SHARED hFontDefault ' default control font
STATIC XLONG cxChar, cyChar, test, cxCaps, teller, numlines
RECT rect
CASE $$WM_CREATE
hdc = GetDC (hWnd)
'
' ----------------------------------------
GetTextMetricsA (hdc, &tm)
'
ReleaseDC (hWnd, hdc)
RETURN
'
'
---------------------------------------------------------------------------------------------------------
PRINT "cxCaps ="; cxCaps; ", cyChar ="; cyChar
nXStartMiddle = 22 * cxCaps
nXStartRight = 22 * cxCaps + 40 * cxChar
PRINT "nXStartMiddle ="; nXStartMiddle; ", nXStartRight =";
nXStartRight
teller = 0
DO WHILE (teller < numlines)
'nYStart = cyChar * teller
nYStart = 20 * teller ' cyChar == 700
'TextOutA (hdc, x, nYStart, &text$, LEN (text$))
PRINT "nYStart ="; nYStart
'
test$ = STR$ (GetSystemMetrics (teller))
TextOutA (hdc, 0, nYStart, &sysmetrics_label$[teller], LEN
(sysmetrics_label$[teller]))
TextOutA (hdc, nXStartMiddle, nYStart, &sysmetrics_desc$
[teller], LEN (sysmetrics_desc$[teller]))
SetTextAlign (hdc, $$TA_RIGHT | $$TA_TOP)
TextOutA (hdc, nXStartRight, nYStart, &test$, LEN (test$))
' TextOutA (hdc, nXStartRight, nYStart, STR$
(GetSystemMetrics[teller]), 10)
SetTextAlign (hdc, $$TA_LEFT | $$TA_TOP)
'
INC teller
LOOP
'
---------------------------------------------------------------------------------------------------------
'
'
CASE $$WM_CLOSE ' closed by User
DestroyWindow (#winMain) ' destroy the main window
RETURN
'
CASE $$WM_DESTROY ' being destroyed
PostQuitMessage ($$WM_QUIT) ' end execution
#winMain = 0
RETURN
'
CASE $$WM_COMMAND
notifyCode = HIWORD (wParam)
idCtr = LOWORD (wParam)
hCtr = lParam
'
SELECT CASE idCtr
END SELECT
'
END SELECT
RETURN DefWindowProcA (hWnd, wMsg, wParam, lParam) ' message not
processed
END FUNCTION
END PROGRAM
Your problem occurs because of a wrong nYStart for API TextOutA (hdc,
x, nYStart, &text$, LEN (text$))
Replacing nYStart = cyChar * teller
by nYStart = 20 * teller makes it work.
Follows my version of your sysmets.
Bye! Guy
PROGRAM "sysmets"
VERSION "1.00"
'
' sysmets - pb with TextOutA
' Copyright © GPL 2011 Guy Lonne.
'
' ***** Description *****
' Stappler-23dec11
' Your problem occurs because of a wrong nYStart for API TextOutA
(hdc, x, nYStart, &text$, LEN (text$))
' Replacing nYStart = cyChar * teller
' by nYStart = 20 * teller makes it work.
'
' ***** Notes *****
' - Use constants $$TA_RIGHT and $$TA_TOP
' - Don't use CSIZE$(*)
' - Don't use cyChar == 700
' nYStart = cyChar * teller
' nYStart = 20 * teller
'
' ***** Versions *****
' 1.00-26dec11-Guy-original version.
'
'
' ##############################
' ##### Import Libraries #####
' ##############################
'
'
' Win32API DLL headers
'
IMPORT "kernel32" ' operating system
'
' ---Note: import gdi32 BEFORE shell32 and user32
IMPORT "gdi32" ' Graphic Device Interface
IMPORT "shell32" ' interface to the operating system
IMPORT "user32" ' Windows management
'
' ---Note: import comctl32 BEFORE comdlg32
IMPORT "comctl32" ' common controls; ==> initialize w/
InitCommonControlsEx ()
' IMPORT "comdlg32" ' standard dialog boxes (opening and saving
files ...)
'
' xblite DLL headers
'
IMPORT "xst" ' xblite Standard Library
IMPORT "xsx" ' xblite Extended Standard Library
IMPORT "xio" ' console
'
'
'
'
' ############################################
' ##### Internal Function Declarations #####
' ############################################
'
'
DECLARE FUNCTION Entry () ' program entry point
DECLARE FUNCTION CleanUp () ' application cleanup
DECLARE FUNCTION CreateWindows () ' create the windows of the
application
DECLARE FUNCTION GetNotifyMsg (lParam, @hwndFrom, @idFrom, @code) '
get event that has occurred in a control
DECLARE FUNCTION GuiTellApiError (msg$) ' displays an API error
message
DECLARE FUNCTION GuiTellRunError (msg$) ' displays an execution error
message
DECLARE FUNCTION InitGui () ' initialize win32 controls and libraries
DECLARE FUNCTION InitWindows () ' for initializations after
CreateWindows()
DECLARE FUNCTION MessageLoop () ' main message loop
DECLARE FUNCTION NewChild (className$, text$, style, x, y, w, h,
parent, id, exStyle) ' create a child window
DECLARE FUNCTION NewWindow (className$, titleBar$, style, x, y, w, h,
exStyle) ' create a window
DECLARE FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu
$) ' register the window class
DECLARE FUNCTION StartUp () ' application setup
DECLARE FUNCTION WapiGetText$ (hCtr) ' get the text from a control
DECLARE FUNCTION WapiKillFont (@hFont) ' release a font created by
WapiNewFont
DECLARE FUNCTION WapiNewFont (fontName$, pointSize, weight, italic,
underline, strikeOut) ' create a new logical font
DECLARE FUNCTION WapiSetFont (hCtr, hFont) ' apply font to control
DECLARE FUNCTION WndProc (hWnd, wMsg, wParam, lParam) ' callback
function for window #winMain
'
'
' #########################################
' ##### Shared Constant Definitions #####
' #########################################
'
'
' ***** Constants used as control identificators for window #winMain
*****
'
' control identificators for #winMain
$$mleSysMets = 101 ' multiline edit
'
' ***** Shared Program Constants *****
'
'
'
' #################################
' ##### Program Entry Point #####
' #################################
'
FUNCTION Entry ()
STATIC entry ' ensure Entry is entered only one time
IF entry THEN RETURN ' enter once
entry = $$TRUE ' enter occured
XioCreateConsole ("", 100) ' create console, if console is not
wanted, comment out this line
IF StartUp () THEN XstAbend ("Can't initialize the
application")
IF InitGui () THEN XstAbend ("Can't initialize the GUI")
IF CreateWindows () THEN XstAbend ("Can't create the window(s)")
InitWindows () ' for initializations after CreateWindows()
MessageLoop () ' monitor the events
CleanUp () ' application cleanup
XioFreeConsole () ' free console
QUIT (0)
END FUNCTION
FUNCTION CleanUp () ' application cleanup
SHARED hInst
SHARED hFontDefault ' default control font
IF #winMain THEN
SetLastError (0)
ret = DestroyWindow (#winMain) ' destroy window #winMain
IFZ ret THEN ' fail
msg$ = "DestroyWindow: Can't destroy window #winMain"
GuiTellApiError (msg$)
ENDIF
'
ENDIF
#winMain = 0
className$ = #winMain_class$
SetLastError (0)
ret = UnregisterClassA (&className$, hInst) ' unregister window
class #winMain_class$
IFZ ret THEN ' fail
msg$ = "UnregisterClassA: Can't unregister window class
#winMain_class$"
GuiTellApiError (msg$)
ENDIF
WapiKillFont (@hFontDefault) ' release the default control font
END FUNCTION
'
'
' ##############################
' ##### CreateWindows () #####
' ##############################
'
FUNCTION CreateWindows () ' create the windows of the application
SHARED hInst
' ***************** Begin window #winMain Generation
*****************
' register the window class for window #winMain
#winMain_class$ = "winMainClass"
addrWndProc = &WndProc ()
icon$ = "" ' no icon
menu$ = "" ' no menu
SetLastError (0)
bErr = RegisterWinClass (#winMain_class$, addrWndProc, icon$, menu
$) ' register window class \"winMainClass\"
IF bErr THEN ' fail
msg$ = "RegisterWinClass: Can't register window class
\"winMainClass\""
GuiTellApiError (msg$)
ENDIF
' create window #winMain
titleBar$ = "Problem with TextOutA"
style = $$WS_OVERLAPPEDWINDOW
#winMain = NewWindow (#winMain_class$, titleBar$, style, 0, 0, 500,
500, 0) ' create window #winMain
IFZ #winMain THEN ' fail: null handle
msg$ = "NewWindow: Can't create window #winMain"
XstAlert (msg$)
RETURN $$TRUE ' fail
ENDIF
' ***************** End window #winMain Generation *****************
XstCenterWindow (#winMain) ' auto-center the window
ShowWindow (#winMain, $$SW_SHOWNORMAL) ' show the window
END FUNCTION
FUNCTION GetNotifyMsg (lParam, @hwndFrom, @idFrom, @code) ' get
event that has occurred in a control
NMHDR nmhdr
' XstCopyMemory (lParam, &nmhdr, SIZE(nmhdr)) 'Xsx library function
RtlMoveMemory (&nmhdr, lParam, SIZE (nmhdr)) 'kernel32 library
function
hwndFrom = nmhdr.hwndFrom
idFrom = nmhdr.idFrom
code = nmhdr.code
END FUNCTION
FUNCTION GuiTellApiError (msg$) ' display an API error message
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
'
' Usage:
' SetLastError (0)
' hDefaultFont = GetStockObject ($$ANSI_VAR_FONT) ' get the ANSI
default font
' IFZ hDefaultFont THEN ' fail
' msg$ = "Can't get the ANSI default font with 'GetStockObject ($
$ANSI_VAR_FONT)'"
' GuiTellApiError (msg$)
' ENDIF
' get the last error code, then clear it
errNum = GetLastError ()
SetLastError (0)
IFZ errNum THEN RETURN ' was OK!
fmtMsg$ = "Last error code " + STRING$ (errNum) + ": "
lenBuf = 1020
szBuf$ = NULL$ (lenBuf) ' fill szBuf$ with (lenBuf + 1) null
chars
' set up FormatMessageA arguments
dwFlags = $$FORMAT_MESSAGE_FROM_SYSTEM | $
$FORMAT_MESSAGE_IGNORE_INSERTS
' format a message string
ret = FormatMessageA (dwFlags, 0, errNum, 0, &szBuf$, lenBuf, 0)
IFZ ret THEN
fmtMsg$ = fmtMsg$ + "(unknown)"
ELSE
fmtMsg$ = fmtMsg$ + CSTRING$ (&szBuf$)
ENDIF
fmtMsg$ = fmtMsg$ + "\r\n" + msg$
IFZ msg$ THEN fmtMsg$ = fmtMsg$ + "Windows API error"
XstGetOSName (@os$)
XstGetOSVersion (@major, @minor, @platformId, @version$, @platform$)
text$ = "\r\nOS: " + os$ + STR$ (major) + "." + STRING$ (minor) + "
" + platform$
fmtMsg$ = fmtMsg$ + text$
' set up MessageBoxA arguments
title$ = PROGRAM$ (0) + "-API Error"
hwnd = GetActiveWindow ()
MessageBoxA (hwnd, &fmtMsg$, &title$, $$MB_ICONSTOP)
RETURN $$TRUE ' an error really occurred!
END FUNCTION
FUNCTION GuiTellRunError (msg$) ' display the run-time error
message
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
'
' Usage:
' errNum = ERROR (0)
' inFile = OPEN (#inFile$, $$RD)
' IF inFile < 3 THEN
' msg$ = "Can't open input file " + #inFile$
' GuiTellRunError (msg$)
' ENDIF
' get current error, then clear it
errNum = ERROR (0)
IFZ errNum THEN RETURN ' was OK!
fmtMsg$ = "Error code " + STRING$ (errNum) + ": " + ERROR$ (errNum)
+ "\r\n" + msg$
IFZ msg$ THEN fmtMsg$ = fmtMsg$ + "Xblite library error"
' set up MessageBoxA arguments
title$ = PROGRAM$ (0) + "-Execution Error"
hwnd = GetActiveWindow ()
MessageBoxA (hwnd, &fmtMsg$, &title$, $$MB_ICONSTOP)
RETURN $$TRUE ' an error really occurred!
END FUNCTION
FUNCTION InitGui () ' initialize win32 controls and libraries
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
SHARED hInst
SHARED hFontDefault ' default control font
INITCOMMONCONTROLSEX icc
hInst = GetModuleHandleA (0) ' get current instance handle
IFZ hInst THEN XstAbend ("Application TERMINATED! InitGui: Can't get
current instance handle")
' initialize the specific common controls classes
' from the common control dynamic-link library
icc.dwSize = SIZE (icc)
' $$ICC_ANIMATE_CLASS : animate
' $$ICC_BAR_CLASSES : toolbar, statusbar, trackbar, tooltips
' $$ICC_COOL_CLASSES : rebar (coolbar) control
' $$ICC_DATE_CLASSES : month picker, date picker, time picker,
updown
' $$ICC_HOTKEY_CLASS : hotkey
' $$ICC_INTERNET_CLASSES : WIN32_IE >= 0x0400
' $$ICC_LISTVIEW_CLASSES : listview, header
' $$ICC_PAGESCROLLER_CLASS : page scroller (WIN32_IE >= 0x0400)
' $$ICC_PROGRESS_CLASS : progress
' $$ICC_TAB_CLASSES : tab, tooltips
' $$ICC_TREEVIEW_CLASSES : treeview, tooltips
' $$ICC_UPDOWN_CLASS : updown
' $$ICC_USEREX_CLASSES : comboex
' $$ICC_WIN95_CLASSES : everything else
icc.dwICC = $$ICC_ANIMATE_CLASS | _
$$ICC_BAR_CLASSES | _
$$ICC_COOL_CLASSES | _
$$ICC_DATE_CLASSES | _
$$ICC_HOTKEY_CLASS | _
$$ICC_INTERNET_CLASSES | _
$$ICC_LISTVIEW_CLASSES | _
$$ICC_NATIVEFNTCTL_CLASS | _
$$ICC_PAGESCROLLER_CLASS | _
$$ICC_PROGRESS_CLASS | _
$$ICC_TAB_CLASSES | _
$$ICC_TREEVIEW_CLASSES | _
$$ICC_UPDOWN_CLASS | _
$$ICC_USEREX_CLASSES | _
$$ICC_WIN95_CLASSES
InitCommonControlsEx (&icc) ' initialize comctl32.dll library
hFontDefault = GetStockObject ($$ANSI_VAR_FONT) ' get the ANSI
default font
IFZ hFontDefault THEN ' fail
msg$ = "InitGui: Can't get the ANSI default font with
'GetStockObject ($$ANSI_VAR_FONT)'"
XstAlert (msg$)
ENDIF
END FUNCTION
'
'
' ############################
' ##### InitWindows () #####
' ############################
'
FUNCTION InitWindows () ' for initializations after CreateWindows()
ShowWindow (#winMain, $$SW_SHOW) ' show window #winMain
END FUNCTION
FUNCTION MessageLoop () ' main message loop
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE on quit
MSG wMsg ' will be sent to window callback function when an event
occurs
' reserved to a stand-alone application
' IF LIBRARY (0) THEN RETURN ' main program executes message loop
' supervise system messages until
' - the user decides to leave the application (RETURN $$FALSE)
' - an error occurred (RETURN $$TRUE)
DO ' the message loop
' retrieve next message from queue
ret = GetMessageA (&wMsg, 0, 0, 0)
SELECT CASE ret
CASE 0 : RETURN ' received a quit message
CASE -1 : RETURN $$TRUE ' fail
CASE ELSE
' deal with window messages
hWnd = GetActiveWindow ()
'
IF (!IsWindow (hWnd)) || (!IsDialogMessageA (hWnd, &wMsg))
THEN
' send only non-dialog messages
' translate virtual-key messages into character messages
' ex.: SHIFT + a is translated as "A"
TranslateMessage (&wMsg)
'
' send message to window callback function
DispatchMessageA (&wMsg)
ENDIF
END SELECT
LOOP ' forever
END FUNCTION
FUNCTION NewChild (className$, text$, style, x, y, w, h, hParent,
idCtr, exStyle) ' create a child window
'
' Arguments
' - className$: control's class
' - text$ : title
' - style : style
' - x : Left
' - y : Top
' - w : Width
' - h : Height
' - hParent : window or parent control
' - idCtr : control ID
' - exStyle : extended style
'
' Returns
' - The child window's handle if OK!, 0 = error
SHARED hInst
IFZ TRIM$ (className$) THEN
msg$ = "NewChild: Can't create the child window " + text$ + ",
with an empty control class"
XstAlert (msg$)
RETURN ' fail
ENDIF
IFZ hParent THEN
msg$ = "NewChild: Can't create the child window " + text$ + ",
control class " + className$ + " without a parent"
XstAlert (msg$)
RETURN ' fail
ENDIF
' create the child window
newStyle = style | $$WS_CHILD | $$WS_VISIBLE
SetLastError (0)
hCtr = CreateWindowExA (exStyle, &className$, &text$, newStyle, x,
y, w, h, hParent, idCtr, hInst, 0)
IFZ hCtr THEN
msg$ = "NewChild: Can't create the child window " + text$ + " with
CreateWindowExA, control class " + className$
GuiTellApiError (msg$)
ENDIF
RETURN hCtr
END FUNCTION
FUNCTION NewWindow (className$, titleBar$, style, x, y, w, h,
exStyle) ' create a window
'
' Arguments
' - className$: window's class
' - titleBar$ : title
' - style : style
' - x : Left
' - y : Top
' - w : Width
' - h : Height
' - exStyle : extended style
'
' Returns
' - The window's handle if OK!, 0 = error
SHARED hInst
SetLastError (0)
hWin = CreateWindowExA (exStyle, &className$, &titleBar$, style, x,
y, w, h, 0, 0, hInst, 0)
IFZ hWin THEN
msg$ = "NewWindow: Can't create the window " + titleBar$ + " with
CreateWindowExA, window class " + className$
GuiTellApiError (msg$)
ENDIF
RETURN hWin
END FUNCTION
FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu$) '
register the window class
SHARED hInst
WNDCLASS wc ' window class
wc.style = $$CS_HREDRAW | $$CS_VREDRAW | $$CS_OWNDC
wc.lpfnWndProc = addrWndProc
wc.cbClsExtra = 0 ' no extra bytes after the window class
wc.cbWndExtra = 0 ' structure or the window instance
wc.hInstance = hInst
IF icon$ THEN wc.hIcon = LoadIconA (hInst, &icon$)
wc.hCursor = LoadCursorA (0, $$IDC_ARROW)
wc.hbrBackground = $$COLOR_BTNFACE + 1
IF menu$ THEN wc.lpszMenuName = &menu$
wc.lpszClassName = &className$
SetLastError (0)
ret = RegisterClassA (&wc)
IFZ ret THEN
msg$ = "RegisterWinClass: Can't register the window class " +
className$
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
END FUNCTION
FUNCTION StartUp () ' application setup
'
' Returns
' - an error flag: $$TRUE = fail, $$FALSE = success
SHARED hInst
SetLastError (0)
hInst = GetModuleHandleA (0) ' get current instance handle
IFZ hInst THEN
msg$ = "GetModuleHandleA: Can't get current instance handle"
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
END FUNCTION
FUNCTION WapiGetText$ (hCtr) ' get the text from a control
' hCtr = the handle to the control
' returns a string containing the control's text
IFZ hCtr THEN RETURN "" ' fail
cch = GetWindowTextLengthA (hCtr) ' get the character count
IF cch < 1 THEN RETURN "" ' empty text
sizeBuf = cch + 1 ' note increment 1!
szBuf$ = NULL$ (sizeBuf)
SetLastError (0)
ret = GetWindowTextA (hCtr, &szBuf$, sizeBuf) ' get the text
IFZ ret THEN RETURN "" ' fail
text$ = CSTRING$ (&szBuf$)
RETURN text$ ' success
END FUNCTION
FUNCTION WapiKillFont (@hFont) ' release a font created by
WapiNewFont
IFZ hFont THEN RETURN $$TRUE ' fail
SetLastError (0)
ret = DeleteObject (hFont) ' release the font
IFZ ret THEN ' fail
msg$ = "DeleteObject: Can't release the font"
GuiTellApiError (msg$)
RETURN $$TRUE ' fail
ENDIF
hFont = 0
END FUNCTION
FUNCTION WapiNewFont (fontName$, pointSize, weight, italic, underline,
strikeOut) ' create a new logical font
' Returns the font handle if success, 0 = fail
LOGFONT oLogFont
' check fontName$ not empty
fontName$ = TRIM$ (fontName$)
IFZ fontName$ THEN
XstAlert ("WapiNewFont: empty font face")
RETURN ' fail
ENDIF
errNum = SetLastError (0)
hfontToClone = GetStockObject ($$DEFAULT_GUI_FONT) ' get a font
to clone
IFZ hfontToClone THEN ' fail: null handle
msg$ = "GetStockObject: Can't get a font to clone"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
' hfontToClone provides with a well-formed font structure
errNum = SetLastError (0)
bytes = GetObjectA (hfontToClone, SIZE (oLogFont), &oLogFont) '
allocate structure font
IFZ bytes THEN ' fail: null handle
msg$ = "GetObjectA: Can't allocate structure font"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
' release the cloned font
DeleteObject (hfontToClone)
hfontToClone = 0
' set the cloned font structure with the passed parameters
oLogFont.faceName = fontName$
IFZ pointSize THEN
oLogFont.height = 0
ELSE
' character height is specified (in points)
IF pointSize > 0 THEN
pointH = pointSize
ELSE
pointH = - pointSize ' make it positive
ENDIF
'
' convert pointSize to pixels
errNum = SetLastError (0)
hdc = GetDC ($$HWND_DESKTOP) ' get the desktop context's handle
IFZ hdc THEN ' fail: null handle
msg$ = "GetDC: Can't get the desktop context's handle"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
'
' Windows expects the font height to be in pixels and negative
oLogFont.height = MulDiv (pointH, GetDeviceCaps (hdc, $
$LOGPIXELSY), -72)
ReleaseDC ($$HWND_DESKTOP, hdc) ' release the handle of the
desktop context
ENDIF
SELECT CASE weight
CASE $$FW_THIN, $$FW_EXTRALIGHT, $$FW_LIGHT, $$FW_NORMAL, $
$FW_MEDIUM, _
$$FW_SEMIBOLD, $$FW_BOLD, $$FW_EXTRABOLD, $$FW_HEAVY, $
$FW_DONTCARE
oLogFont.weight = weight
'
CASE ELSE : oLogFont.weight = $$FW_NORMAL
END SELECT
IF italic THEN
oLogFont.italic = 1
ELSE
oLogFont.italic = 0
ENDIF
IF underline THEN
oLogFont.underline = 1
ELSE
oLogFont.underline = 0
ENDIF
IF strikeOut THEN
oLogFont.strikeOut = 1
ELSE
oLogFont.strikeOut = 0
ENDIF
errNum = SetLastError (0)
hFont = CreateFontIndirectA (&oLogFont) ' create logical font
hFont
IFZ hFont THEN ' fail: null handle
msg$ = "CreateFontIndirectA: Can't create logical font hFont"
GuiTellApiError (msg$)
RETURN 0 ' invalid handle
ENDIF
RETURN hFont
END FUNCTION
FUNCTION WapiSetFont (hCtr, hFont) ' apply font to control
IFZ hCtr THEN RETURN ' ignore null control handle
' check hFont not null
IFZ hFont THEN
XstAlert ("WapiSetFont: Ignore null font handle")
RETURN $$TRUE ' fail
ENDIF
' $$WM_SETFONT does not return a value
SendMessageA (hCtr, $$WM_SETFONT, hFont, 0)
END FUNCTION
FUNCTION WndProc (hWnd, wMsg, wParam, lParam) ' callback function
for window #winMain
SHARED hInst
SHARED hFontDefault ' default control font
STATIC XLONG cxChar, cyChar, test, cxCaps, teller, numlines
RECT rect
PAINTSTRUCT ps
RECT wRect
TEXTMETRIC tm
DIM sysmetrics_label$[3]
DIM sysmetrics_desc$[3]
sysmetrics_label$[0] = "SM_CXSCREEN"
sysmetrics_label$[1] = "SM_CYSCREEN"
sysmetrics_label$[2] = "SM_CXVSCROLL"
sysmetrics_label$[3] = "SM_CYHSCROLL"
sysmetrics_desc$[0] = "Screen width in pixels"
sysmetrics_desc$[1] = "Screen heigth in pixels"
sysmetrics_desc$[2] = "Vertical scroll width"
sysmetrics_desc$[3] = "Vertical scroll heigth"
numlines = 4
SELECT CASE wMsg
RECT wRect
TEXTMETRIC tm
DIM sysmetrics_label$[3]
DIM sysmetrics_desc$[3]
sysmetrics_label$[0] = "SM_CXSCREEN"
sysmetrics_label$[1] = "SM_CYSCREEN"
sysmetrics_label$[2] = "SM_CXVSCROLL"
sysmetrics_label$[3] = "SM_CYHSCROLL"
sysmetrics_desc$[0] = "Screen width in pixels"
sysmetrics_desc$[1] = "Screen heigth in pixels"
sysmetrics_desc$[2] = "Vertical scroll width"
sysmetrics_desc$[3] = "Vertical scroll heigth"
numlines = 4
CASE $$WM_CREATE
hdc = GetDC (hWnd)
'
' ----------------------------------------
GetTextMetricsA (hdc, &tm)
cxChar = tm.avgCharWidth
test = tm.pitchAndFamily
IF test = $$TMPF_FIXED_PITCH THEN
cxCaps = cxChar
ELSE
cxCaps = cxChar / 2 + cxChar
ENDIF
cyChar = tm.weight + tm.externalLeading
' ----------------------------------------
test = tm.pitchAndFamily
IF test = $$TMPF_FIXED_PITCH THEN
cxCaps = cxChar
ELSE
cxCaps = cxChar / 2 + cxChar
ENDIF
cyChar = tm.weight + tm.externalLeading
'
ReleaseDC (hWnd, hdc)
RETURN
'
CASE $$WM_PAINT
hdc = BeginPaint (hWnd, &ps) ' prepare window for painting,
drawing, filling
'
hdc = BeginPaint (hWnd, &ps) ' prepare window for painting,
drawing, filling
'
---------------------------------------------------------------------------------------------------------
PRINT "cxCaps ="; cxCaps; ", cyChar ="; cyChar
nXStartMiddle = 22 * cxCaps
nXStartRight = 22 * cxCaps + 40 * cxChar
PRINT "nXStartMiddle ="; nXStartMiddle; ", nXStartRight =";
nXStartRight
teller = 0
DO WHILE (teller < numlines)
'nYStart = cyChar * teller
nYStart = 20 * teller ' cyChar == 700
'TextOutA (hdc, x, nYStart, &text$, LEN (text$))
PRINT "nYStart ="; nYStart
'
test$ = STR$ (GetSystemMetrics (teller))
TextOutA (hdc, 0, nYStart, &sysmetrics_label$[teller], LEN
(sysmetrics_label$[teller]))
TextOutA (hdc, nXStartMiddle, nYStart, &sysmetrics_desc$
[teller], LEN (sysmetrics_desc$[teller]))
SetTextAlign (hdc, $$TA_RIGHT | $$TA_TOP)
TextOutA (hdc, nXStartRight, nYStart, &test$, LEN (test$))
' TextOutA (hdc, nXStartRight, nYStart, STR$
(GetSystemMetrics[teller]), 10)
SetTextAlign (hdc, $$TA_LEFT | $$TA_TOP)
'
PRINT teller
PRINT sysmetrics_label$[teller]
PRINT sysmetrics_desc$[teller]
PRINT STR$ (GetSystemMetrics (teller))
'
PRINT sysmetrics_label$[teller]
PRINT sysmetrics_desc$[teller]
PRINT STR$ (GetSystemMetrics (teller))
INC teller
LOOP
'
---------------------------------------------------------------------------------------------------------
'
EndPaint (hWnd, &ps) ' finished painting window
RETURN
'
CASE $$WM_CLOSE ' closed by User
DestroyWindow (#winMain) ' destroy the main window
RETURN
'
CASE $$WM_DESTROY ' being destroyed
PostQuitMessage ($$WM_QUIT) ' end execution
#winMain = 0
RETURN
'
CASE $$WM_COMMAND
notifyCode = HIWORD (wParam)
idCtr = LOWORD (wParam)
hCtr = lParam
'
SELECT CASE idCtr
END SELECT
'
END SELECT
RETURN DefWindowProcA (hWnd, wMsg, wParam, lParam) ' message not
processed
END FUNCTION
END PROGRAM
Reply all
Reply to author
Forward
0 new messages