Examples from the book Programming Windows, 5th Edition, by Charles Petzold, translated and adapted to PBWIN 10.
This program is a translation of ABOUT1.C -- About Box Demo Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
Even if a Windows program requires no user input, it will often have a dialog box that is invoked by an About option on the menu. This dialog box displays the name and icon of the program, a copyright notice, a push button labeled OK, and perhaps some other information.
' ========================================================================================
' ABOUT1.BAS
' This program is an translation/adaptation of ABOUT1.C -- About Box Demo Program No. 1
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Even if a Windows program requires no user input, it will often have a dialog box that
' is invoked by an About option on the menu. This dialog box displays the name and icon of
' the program, a copyright notice, a push button labeled OK, and perhaps some other
' information.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "about1.res"
%IDM_APP_ABOUT = 40001
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "About1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "About Box Demo Program"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hInstance AS DWORD
LOCAL lpc AS CREATESTRUCT PTR
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_APP_ABOUT
DialogBox hInstance, "AboutBox", hwnd, CODEPTR(AboutDlgProc)
END SELECT
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AboutDlgProc (BYVAL hDlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_INITDIALOG
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDOK, %IDCANCEL
EndDialog hDlg, 0
FUNCTION = %TRUE
EXIT FUNCTION
END SELECT
END SELECT
END FUNCTION
' ========================================================================================
This program is a translation of ABOUT2.C -- About Box Demo Program No. 2 © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
Demonstrates how to manage controls (in this case, radio buttons) within a dialog box procedure and also how to paint on the client area of the dialog box.
' ========================================================================================
' ABOUT2.BAS
' This program is a translation/adaptation of ABOUT2.C -- About Box Demo Program No. 2
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Demonstrates how to manage controls (in this case, radio buttons) within a dialog box
' procedure and also how to paint on the client area of the dialog box.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "about2.res"
%IDC_BLACK = 1000
%IDC_BLUE = 1001
%IDC_GREEN = 1002
%IDC_CYAN = 1003
%IDC_RED = 1004
%IDC_MAGENTA = 1005
%IDC_YELLOW = 1006
%IDC_WHITE = 1007
%IDC_RECT = 1008
%IDC_ELLIPSE = 1009
%IDC_PAINT = 1010
%IDM_APP_ABOUT = 40001
GLOBAL iCurrentColor AS LONG
GLOBAL iCurrentFigure AS LONG
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "About2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "About Box Demo Program"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintWindow (BYVAL hwnd AS DWORD, BYVAL iColor AS LONG, BYVAL iFigure AS LONG)
DIM crColor(0 TO 7) AS STATIC DWORD
STATIC flag AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL rc AS RECT
IF ISFALSE flag THEN
flag = %TRUE
crColor(0) = RGB(0, 0, 0)
crColor(1) = RGB(0, 0, 255)
crColor(2) = RGB(0, 255, 0)
crColor(3) = RGB (0, 255, 255)
crColor(4) = RGB(255, 0, 0)
crColor(5) = RGB(255, 0, 255)
crColor(6) = RGB(255, 255, 0)
crColor(7) = RGB(255, 255, 255)
END IF
hdc = GetDC(hwnd)
GetClientRect hwnd, rc
hBrush = CreateSolidBrush(crColor(iColor - %IDC_BLACK))
hBrush = SelectObject(hdc, hBrush)
IF iFigure = %IDC_RECT THEN
Rectangle hdc, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom
ELSE
Ellipse hdc, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom
END IF
DeleteObject SelectObject(hdc, hBrush)
ReleaseDC hwnd, hdc
END SUB
' ========================================================================================
' ========================================================================================
SUB PaintTheBlock (BYVAL hCtrl AS DWORD, BYVAL iColor AS LONG, BYVAL iFigure AS LONG)
InvalidateRect hCtrl, BYVAL %NULL, %TRUE
UpdateWindow hCtrl
PaintWindow hCtrl, iColor, iFigure
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hInstance AS DWORD
LOCAL lpc AS CREATESTRUCT PTR
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
iCurrentColor = %IDC_BLACK
iCurrentFigure = %IDC_RECT
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_APP_ABOUT
IF DialogBox(hInstance, "AboutBox", hwnd, CODEPTR(AboutDlgProc)) THEN
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
BeginPaint hwnd, ps
EndPaint hwnd, ps
PaintWindow hwnd, iCurrentColor, iCurrentFigure
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AboutDlgProc (BYVAL hDlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hCtrlBlock AS DWORD
STATIC iColor AS LONG
STATIC iFigure AS LONG
SELECT CASE uMsg
CASE %WM_INITDIALOG
iColor = iCurrentColor
iFigure = iCurrentFigure
CheckRadioButton hDlg, %IDC_BLACK, %IDC_WHITE, iColor
CheckRadioButton hDlg, %IDC_RECT, %IDC_ELLIPSE, iFigure
hCtrlBlock = GetDlgItem (hDlg, %IDC_PAINT)
SetFocus GetDlgItem (hDlg, iColor)
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDOK
iCurrentColor = iColor
iCurrentFigure = iFigure
EndDialog hDlg, %TRUE
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDCANCEL
EndDialog hDlg, %FALSE
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_BLACK, %IDC_RED, %IDC_GREEN, %IDC_YELLOW, _
%IDC_BLUE, %IDC_MAGENTA, %IDC_CYAN, %IDC_WHITE
iColor = LO(WORD, wParam)
CheckRadioButton hDlg, %IDC_BLACK, %IDC_WHITE, LO(WORD, wParam)
PaintTheBlock hCtrlBlock, iColor, iFigure
FUNCTION = %TRUE
CASE %IDC_RECT, %IDC_ELLIPSE
iFigure = LO(WORD, wParam)
CheckRadioButton hDlg, %IDC_RECT, %IDC_ELLIPSE, LO(WORD, wParam)
PaintTheBlock hCtrlBlock, iColor, iFigure
FUNCTION = %TRUE
END SELECT
CASE %WM_PAINT
PaintTheBlock hCtrlBlock, iColor, iFigure
END SELECT
END FUNCTION
' ========================================================================================
This program is a translation of ABOUT3.C -- About Box Demo Program No. 3 © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
You can also define your own child window controls and use them in a dialog box. For example, suppose you don't particularly care for the normal rectangular push buttons and would prefer to create elliptical push buttons. You can do this by registering a window class and using your own window procedure to process messages for your customized child window.
' ========================================================================================
' ABOUT3.BAS
' This program is a translation/adaptation of ABOUT3.C -- About Box Demo Program No. 3
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' You can also define your own child window controls and use them in a dialog box. For
' example, suppose you don't particularly care for the normal rectangular push buttons and
' would prefer to create elliptical push buttons. You can do this by registering a window
' class and using your own window procedure to process messages for your customized child
' window.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES "about3.res"
%IDM_APP_ABOUT = 40001
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szClassName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "About3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szClassName = "EllipPush"
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(EllipPushwndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = %NULL
wcex.hCursor = LoadCursor (%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = %COLOR_BTNFACE + 1
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szClassName)
RegisterClassEx wcex
szCaption = "About Box Demo Program"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hInstance AS DWORD
LOCAL lpc AS CREATESTRUCT PTR
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_APP_ABOUT
DialogBox(hInstance, "AboutBox", hwnd, CODEPTR(AboutDlgProc))
END SELECT
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AboutDlgProc (BYVAL hDlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hCtrlBlock AS DWORD
STATIC iColor AS LONG
STATIC iFigure AS LONG
SELECT CASE uMsg
CASE %WM_INITDIALOG
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDOK
EndDialog hDlg, 0
FUNCTION = %TRUE
EXIT FUNCTION
END SELECT
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION EllipPushwndProc (BYVAL hwnd AS DWORD, BYVAL message AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL szText AS ASCIIZ * 40
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE message
CASE %WM_PAINT
GetClientRect hwnd, rc
GetWindowText hwnd, szText, SIZEOF(szText)
hdc = BeginPaint(hwnd, ps)
hBrush = CreateSolidBrush (GetSysColor(%COLOR_WINDOW))
hBrush = SelectObject(hdc, hBrush)
SetBkColor hdc, GetSysColor(%COLOR_WINDOW)
SetTextColor hdc, GetSysColor(%COLOR_WINDOWTEXT)
Ellipse hdc, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom
DrawText hdc, szText, -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
DeleteObject SelectObject(hdc, hBrush)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_KEYUP
IF wParam = %VK_SPACE THEN
SendMessage GetParent(hwnd), %WM_COMMAND, GetWindowLong(hwnd, %GWL_ID), hwnd
END IF
EXIT FUNCTION
CASE %WM_LBUTTONUP
SendMessage GetParent(hwnd), %WM_COMMAND, GetWindowLong(hwnd, %GWL_ID), hwnd
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc (hwnd, message, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the ALTWIND.C-Alternate and Winding Fill Modes Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Displays the figure twice, once using the ALTERNATE filling mode and then using WINDING.
' ========================================================================================
' ALTWIND.BAS
' This program is a translation/adaptation of the ALTWIND.C-Alternate and Winding Fill
' Modes Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Displays the figure twice, once using the ALTERNATE filling mode and then using WINDING.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "AltWind"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Alternate and Winding Fill Modes"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL ps AS PAINTSTRUCT
DIM aptFigure(9) AS STATIC POINTAPI
DIM apt(9) AS POINTAPI
SELECT CASE uMsg
CASE %WM_CREATE
aptFigure(0).x = 10 : aptFigure(0).y = 70
aptFigure(1).x = 50 : aptFigure(1).y = 70
aptFigure(2).x = 50 : aptFigure(2).y = 10
aptFigure(3).x = 90 : aptFigure(3).y = 10
aptFigure(4).x = 90 : aptFigure(4).y = 50
aptFigure(5).x = 30 : aptFigure(5).y = 50
aptFigure(6).x = 30 : aptFigure(6).y = 90
aptFigure(7).x = 70 : aptFigure(7).y = 90
aptFigure(8).x = 70 : aptFigure(8).y = 30
aptFigure(9).x = 10 : aptFigure(9).y = 30
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%GRAY_BRUSH)
FOR i = 0 TO 9
apt(i).x = cxClient * aptFigure(i).x / 200
apt(i).y = cyClient * aptFigure(i).y / 100
NEXT
SetPolyFillMode hdc, %ALTERNATE
Polygon hdc, apt(0), 10
FOR i = 0 TO 9
apt(i).x = apt(i).x + cxClient / 2
NEXT
SetPolyFillMode hdc, %WINDING
Polygon hdc, apt(0), 10
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of APOLLO11.C -- Program for screen captures © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming Windows, 5th Edition.
The program loads two DIBS, named APOLLO11.BMP (the bottom-up version) and APOLLOTD.BMP (the top-down version). Both are 220 pixels wide and 240 pixels high. Note that when the program determines the DIB width and height from the header information structure, it uses the abs function to take the absolute value of the biHeight field. When displaying the DIBs in full size or in the partial views, the xSrc, ySrc, cxSrc, and cySrc coordinates are identical regardless of which bitmap is being displayed.
' ========================================================================================
' APOLLO11.BAS
' This program is a translation/adaptation of APOLLO11.C -- Program for screen captures
' © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming
' Windows, 5th Edition.
' The program loads two DIBS, named APOLLO11.BMP (the bottom-up version) and APOLLOTD.BMP
' (the top-down version). Both are 220 pixels wide and 240 pixels high. Note that when the
' program determines the DIB width and height from the header information structure, it
' uses the abs function to take the absolute value of the biHeight field. When displaying
' the DIBs in full size or in the partial views, the xSrc, ySrc, cxSrc, and cySrc
' coordinates are identical regardless of which bitmap is being displayed.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
FUNCTION DibLoadImage (BYVAL strFileName AS STRING) AS DWORD
LOCAL bSuccess AS LONG
LOCAL dwFileSize AS DWORD
LOCAL dwHighSize AS DWORD
LOCAL dwBytesRead AS DWORD
LOCAL hFile AS DWORD
LOCAL pbmfh AS BITMAPFILEHEADER PTR
hFile = CreateFile(BYCOPY strFileName, %GENERIC_READ, %FILE_SHARE_READ, _
BYVAL %NULL, %OPEN_EXISTING, %FILE_FLAG_SEQUENTIAL_SCAN, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
dwFileSize = GetFileSize(hFile, dwHighSize)
IF dwHighSize THEN
CloseHandle hFile
EXIT FUNCTION
END IF
' Read the contents of the file. Notice that pmfh has been cast as
' BITMAPFILEHEADER PTR to be able to read the header.
pbmfh = CoTaskMemAlloc(dwFileSize)
bSuccess = ReadFile (hFile, BYVAL pbmfh, dwFileSize, dwBytesRead, BYVAL %NULL)
' Check for "BM" (&H4D42, i.e. &H42 = "B", &H4D = "M", they are in reverse order)
IF ISFALSE bSuccess OR dwBytesRead <> dwFileSize OR @pbmfh.bfType <> &H4D42 THEN
CoTaskMemFree pbmfh
CloseHandle hFile
EXIT FUNCTION
END IF
' Close the file handle and return a pointer to the data read
CloseHandle hFile
FUNCTION = pbmfh
END FUNCTION
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Apollo11"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Apollo11"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
DIM pbmfh(1) AS STATIC BITMAPFILEHEADER PTR
DIM pbmi(1) AS STATIC BITMAPINFO PTR
DIM pbits(1) AS STATIC BYTE PTR
DIM cxDib(1) AS STATIC LONG
DIM cyDib(1) AS STATIC LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
' Load the images
pbmfh(0) = DibLoadImage("Apollo11.bmp")
pbmfh(1) = DibLoadImage("ApolloTD.bmp")
IF pbmfh(0) = %NULL OR pbmfh(1) = %NULL THEN
MessageBox hwnd, "Cannot load DIB file", "Apollo11", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
' Get pointers to the info structure & the bits
pbmi(0) = pbmfh(0) + SIZEOF(@pbmfh(0)) ' same as SIZEOF(BITMAPFILEHEADER)
pbmi(1) = pbmfh(1) + SIZEOF(@pbmfh(1)) ' same as SIZEOF(BITMAPFILEHEADER)
pbits(0) = pbmfh(0) + @pbmfh(0).bfOffBits
pbits(1) = pbmfh(1) + @pbmfh(1).bfOffBits
' Get the DIB width and height (assume BITMAPINFOHEADER)
' Note that cyDib is the absolute value of the header value!!!
cxDib(0) = @pbmi(0).bmiHeader.biWidth
cxDib(1) = @pbmi(1).bmiHeader.biWidth
cyDib(0) = ABS(@pbmi(0).bmiHeader.biHeight)
cyDib(1) = ABS(@pbmi(1).bmiHeader.biHeight)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
' Store the width and height of the client area
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
' Draw the bitmaps
hdc = BeginPaint(hwnd, ps)
bSuccess = SetDIBitsToDevice(hdc, 0, cyCLient / 4, cxDib(0), cyDib(0), 0, 0, 0, _
cyDib(0), BYVAL pbits(0), BYVAL pbmi(0), %DIB_RGB_COLORS)
bSuccess = SetDIBitsToDevice(hdc, 240, cyCLient / 4, 80, 166, 80, 60, 0, _
cyDib(0), BYVAL pbits(0), BYVAL pbmi(0), %DIB_RGB_COLORS)
bSuccess = SetDIBitsToDevice(hdc, 340, cyCLient / 4, cxDib(1), cyDib(1), 0, 0, 0, _
cyDib(1), BYVAL pbits(1), BYVAL pbmi(1), %DIB_RGB_COLORS)
bSuccess = SetDIBitsToDevice(hdc, 580, cyCLient / 4, 80, 166, 80, 60, 0, _
cyDib(1), BYVAL pbits(1), BYVAL pbmi(1), %DIB_RGB_COLORS)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
' Free the allocated memory
IF pbmfh(0) THEN CoTaskMemFree pbmfh(0)
IF pbmfh(1) THEN CoTaskMemFree pbmfh(1)
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BACHTOCC.C -- Bach Toccata in D Minor (First Bar) © Charles Petzold, 1998, described and analysed in Chapter 22 of the book Programming Windows, 5th Edition.
Plays the first measure of the toccata section of J. S. Bach's famous Toccata and Fugue in D Minor for organ.
' ========================================================================================
' BACHTOCC.BAS
' This program is a translation/adaptation of BACHTOCC.C -- Bach Toccata in D Minor
' (First Bar) © Charles Petzold, 1998, described and analysed in Chapter 22 of the book
' Programming Windows, 5th Edition.
' Plays the first measure of the toccata section of J. S. Bach's famous Toccata and Fugue
' in D Minor for organ.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
TYPE NOTESEQ_STRUCT
iDur AS LONG
iNote(0 TO 1) AS LONG
END TYPE
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BachTocc"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Bach Toccata in D Minor (First Bar)"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION MidiOutMessage_ (BYVAL hMidi AS DWORD, BYVAL iStatus AS LONG, BYVAL iChannel AS LONG, _
BYVAL iData1 AS LONG, BYVAL iData2 AS LONG) AS DWORD
LOCAL dwMessage AS DWORD
SHIFT LEFT iData1, 8
SHIFT LEFT iData2, 16
dwMessage = iStatus OR iChannel OR iData1 OR iData2
FUNCTION = midiOutShortMsg(hMidi, dwMessage)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM noteseq(19) AS STATIC NOTESEQ_STRUCT
STATIC hMidiOut AS DWORD
STATIC iIndex AS LONG
LOCAL i AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
noteseq( 0).iDur = 110 : noteseq( 0).iNote(0) = 69 : noteseq( 0).iNote(1) = 81
noteseq( 1).iDur = 110 : noteseq( 1).iNote(0) = 67 : noteseq( 1).iNote(1) = 79
noteseq( 2).iDur = 990 : noteseq( 2).iNote(0) = 69 : noteseq( 2).iNote(1) = 81
noteseq( 3).iDur = 220 : noteseq( 3).iNote(0) = -1 : noteseq( 3).iNote(1) = -1
noteseq( 4).iDur = 110 : noteseq( 4).iNote(0) = 67 : noteseq( 4).iNote(1) = 79
noteseq( 5).iDur = 110 : noteseq( 5).iNote(0) = 65 : noteseq( 5).iNote(1) = 77
noteseq( 6).iDur = 110 : noteseq( 6).iNote(0) = 64 : noteseq( 6).iNote(1) = 76
noteseq( 7).iDur = 110 : noteseq( 7).iNote(0) = 62 : noteseq( 7).iNote(1) = 74
noteseq( 8).iDur = 220 : noteseq( 8).iNote(0) = 61 : noteseq( 8).iNote(1) = 73
noteseq( 9).iDur = 440 : noteseq( 9).iNote(0) = 62 : noteseq( 9).iNote(1) = 74
noteseq(10).iDur = 1980 : noteseq(10).iNote(0) = -1 : noteseq(10).iNote(1) = -1
noteseq(11).iDur = 110 : noteseq(11).iNote(0) = 57 : noteseq(11).iNote(1) = 69
noteseq(12).iDur = 110 : noteseq(12).iNote(0) = 55 : noteseq(12).iNote(1) = 67
noteseq(13).iDur = 990 : noteseq(13).iNote(0) = 57 : noteseq(13).iNote(1) = 69
noteseq(14).iDur = 220 : noteseq(14).iNote(0) = -1 : noteseq(14).iNote(1) = -1
noteseq(15).iDur = 220 : noteseq(15).iNote(0) = 52 : noteseq(15).iNote(1) = 64
noteseq(16).iDur = 220 : noteseq(16).iNote(0) = 53 : noteseq(16).iNote(1) = 65
noteseq(17).iDur = 220 : noteseq(17).iNote(0) = 49 : noteseq(17).iNote(1) = 61
noteseq(18).iDur = 440 : noteseq(18).iNote(0) = 50 : noteseq(18).iNote(1) = 62
noteseq(19).iDur = 1980 : noteseq(19).iNote(0) = -1 : noteseq(19).iNote(1) = -1
' Open MIDIMAPPER device
IF midiOutOpen(hMidiOut, %MIDIMAPPER, 0, 0, 0) <> %MMSYSERR_NOERROR THEN
MessageBeep %MB_ICONEXCLAMATION
MessageBox hwnd, "Cannot open MIDI output device!", _
"BachTocc", %MB_ICONEXCLAMATION OR %MB_OK
FUNCTION = -1
EXIT FUNCTION
END IF
' Send Program Change messages for "Church Organ"
MidiOutMessage_ hMidiOut, &HC0, 0, 19, 0
MidiOutMessage_ hMidiOut, &HC0, 12, 19, 0
SetTimer hwnd, %ID_TIMER, 1000, %NULL
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_TIMER
' Loop for 2-note polyphony
FOR i = 0 TO 1
' Note Off messages for previous note
IF iIndex <> 0 THEN
IF noteseq(iIndex - 1).iNote(i) <> -1 THEN
MidiOutMessage_ hMidiOut, &H80, 0, _
noteseq(iIndex - 1).iNote(i), 0
MidiOutMessage_ hMidiOut, &H80, 12, _
noteseq(iIndex - 1).iNote(i), 0
END IF
END IF
' Note On messages for new note
IF iIndex < 19 THEN
IF noteseq(iIndex).iNote(i) <> -1 THEN
MidiOutMessage_ hMidiOut, &H90, 0, _
noteseq(iIndex).iNote(i), 127
MidiOutMessage_ hMidiOut, &H90, 12, _
noteseq(iIndex).iNote(i), 127
END IF
END IF
NEXT
IF iIndex < 19 THEN
SetTimer hwnd, %ID_TIMER, noteseq(iIndex).iDur - 1, %NULL
iIndex = iIndex + 1
ELSE
KillTimer hwnd, %ID_TIMER
DestroyWindow hwnd
END IF
EXIT FUNCTION
CASE %WM_DESTROY
midiOutReset hMidiOut
midiOutClose hMidiOut
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BEEPER1.C -- Timer Demo Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming Windows, 5th Edition.
Sets a timer for 1-second intervals. When it receives a WM_TIMER message, it alternates coloring the client area blue and red and it beeps by calling the function MessageBeep. (Although MessageBeep is often used as a companion to MessageBox, it's really an all-purpose beep function. In PCs equipped with sound boards, you can use the various MB_ICON parameters normally used with MessageBox as parameters to MessageBeep to make different sounds as selected by the user in the Control Panel Sounds applet.)
' ========================================================================================
' BEEPER1.BAS
' This program is a translation/adaptation of BEEPER1.C -- Timer Demo Program No. 1
' © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming
' Windows, 5th Edition.
' Sets a timer for 1-second intervals. When it receives a WM_TIMER message, it alternates
' coloring the client area blue and red and it beeps by calling the function MessageBeep.
' (Although MessageBeep is often used as a companion to MessageBox, it's really an
' all-purpose beep function. In PCs equipped with sound boards, you can use the various
' MB_ICON parameters normally used with MessageBox as parameters to MessageBeep to make
' different sounds as selected by the user in the Control Panel Sounds applet.)
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "Beeper1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
"Beeper1 Timer Demo", _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC fFlipFlop AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
SetTimer hwnd, %ID_TIMER, 1000, %NULL
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_TIMER
MessageBeep -1
fFlipFlop = NOT fFlipFlop
InvalidateRect hwnd, BYVAL %NULL, %FALSE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
hBrush = CreateSolidBrush (IIF&(fFlipFlop <> 0, RGB(255,0,0), RGB(0,0,255)))
FillRect hdc, rc, hBrush
EndPaint(hwnd, ps)
DeleteObject hBrush
EXIT FUNCTION
CASE %WM_DESTROY
KillTimer hwnd, %ID_TIMER
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BEEPER2.C -- Timer Demo Program No. 2 © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming Windows, 5th Edition.
The BEEPER2 program is functionally the same as BEEPER1, except that Windows sends the timer messages to TimerProc rather than to WndProc.
' ========================================================================================
' BEEPER2.BAS
' This program is a translation/adaptation of BEEPER2.C -- Timer Demo Program No. 2
' © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming
' Windows, 5th Edition.
' The BEEPER2 program is functionally the same as BEEPER1, except that Windows sends the
' timer messages to TimerProc rather than to WndProc.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "Beeper2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
"Beeper2 Timer Demo", _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC fFlipFlop AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
SetTimer hwnd, %ID_TIMER, 1000, CODEPTR(TimerProc)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_DESTROY
KillTimer hwnd, %ID_TIMER
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Timer callback procedure
' ========================================================================================
SUB TimerProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL iTimerID AS DWORD, BYVAL dwTime AS DWORD)
STATIC fFlipFlop AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL rc AS RECT
MessageBeep -1
fFlipFlop = NOT fFlipFlop
GetClientRect hwnd, rc
hdc = GetDC(hwnd)
hBrush = CreateSolidBrush(IIF&(fFlipFlop <> 0, RGB(255,0,0), RGB(0,0,255)))
FillRect hdc, rc, hBrush
ReleaseDC hwnd, hdc
DeleteObject hBrush
END SUB
' ========================================================================================
This program is a translation of the BEZIER.C-Bezier Splines Demo © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Interactively draws Bézier splines. The two control points are manipulable, the first by pressing the left mouse button and moving the mouse, the second by pressing the right mouse button and moving the mouse.
' ========================================================================================
' BEZIER.BAS
' This program is a translation/adaptation of the BEZIER.C-Bezier Splines Demo
' © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming
' Windows, 5th Edition.
' Interactively draws Bézier splines. The two control points are manipulable, the first by
' pressing the left mouse button and moving the mouse, the second by pressing the right
' mouse button and moving the mouse.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Bezier"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Bezier Splines"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws the Bézier splines.
' ========================================================================================
SUB DrawBezier (BYVAL hdc AS DWORD, BYREF apt() AS POINTAPI)
PolyBezier hdc, apt(0), 4
MoveToEx hdc, apt(0).x, apt(0).y, BYVAL %NULL
LineTo hdc, apt(1).x, apt(1).y
MoveToEx hdc, apt(2).x, apt(2).y, BYVAL %NULL
LineTo hdc, apt(3).x, apt(3).y
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
DIM apt(3) AS STATIC POINT
SELECT CASE uMsg
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
apt(0).x = cxClient / 4
apt(0).y = cyClient / 2
apt(1).x = cxClient / 2
apt(1).y = cyClient / 4
apt(2).x = cxClient / 2
apt(2).y = 3 * cyClient / 4
apt(3).x = 3 * cxClient / 4
apt(3).y = cyClient / 2
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDOWN, %WM_RBUTTONDOWN, %WM_MOUSEMOVE
IF (wParam AND %MK_LBUTTON) OR (wParam AND %MK_RBUTTON) THEN
hdc = GetDC(hwnd)
SelectObject hdc, GetStockObject(%WHITE_PEN)
DrawBezier hdc, apt()
IF (wParam AND %MK_LBUTTON) THEN
apt(1).x = LO(WORD, lParam)
apt(1).y = HI(WORD, lParam)
END IF
IF (wParam AND %MK_RBUTTON) THEN
apt(2).x = LO(WORD, lParam)
apt(2).y = HI(WORD, lParam)
END IF
SelectObject hdc, GetStockObject(%BLACK_PEN)
DrawBezier hdc, apt()
ReleaseDC hwnd, hdc
END IF
CASE %WM_PAINT
InvalidateRect hwnd, BYVAL %NULL, %TRUE
hdc = BeginPaint(hwnd, ps)
DrawBezier hdc, apt()
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BITBLT.C -- BitBlt Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
The BITBLT program uses the BitBlt function to copy the program's system menu icon (located in the upper left corner of the program's window) to its client area.
' ========================================================================================
' BITBLT.BAS
' This program is a translation/adaptation of BITBLT.C -- BitBlt Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The BITBLT program uses the BitBlt function to copy the program's system menu icon
' (located in the upper left corner of the program's window) to its client area.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BitBlt"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "BitBlt Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxSource AS LONG
STATIC cySource AS LONG
LOCAL hdcClient AS DWORD
LOCAL hdcWindow AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
cxSource = GetSystemMetrics(%SM_CXSIZEFRAME) + GetSystemMetrics(%SM_CXSIZE)
cySource = GetSystemMetrics(%SM_CYSIZEFRAME) + GetSystemMetrics(%SM_CYCAPTION)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
' // Note: The following code only works with Windows classic theme, not with Aero.
CASE %WM_PAINT
hdcClient = BeginPaint(hwnd, ps)
hdcWindow = GetWindowDC(hwnd)
FOR y = 0 TO cyClient - 1 STEP cySource
FOR x = 0 TO cxClient - 1 STEP cxSource
BitBlt hdcClient, x, y, cxSource, cySource, hdcWindow, 0, 0, %SRCCOPY
NEXT
NEXT
ReleaseDC hwnd, hdcWindow
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BITMASK.C -- Bitmap Masking Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
A mask is a monochrome bitmap of the same dimensions as the rectangular bitmap image you want to display. Each mask pixel corresponds with a pixel of the bitmap image. The mask pixels are 1 (white) wherever the original bitmap pixel is to be displayed, and 0 (black) wherever you want to preserve the destination background. (Or the mask bitmap can be opposite this, with some corresponding changes to the raster operations you use.)
' ========================================================================================
' BITMASK.BAS
' This program is a translation/adaptation of BITMASK.C -- Bitmap Masking Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' A mask is a monochrome bitmap of the same dimensions as the rectangular bitmap image you
' want to display. Each mask pixel corresponds with a pixel of the bitmap image. The mask
' pixels are 1 (white) wherever the original bitmap pixel is to be displayed, and 0 (black)
' wherever you want to preserve the destination background. (Or the mask bitmap can be
' opposite this, with some corresponding changes to the raster operations you use.)
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "bitmask.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BitMask"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Bitmap Masking Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hBitmapImag AS DWORD
STATIC hBitmapMask AS DWORD
STATIC hInstance AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxBitmap AS LONG
STATIC cyBitmap AS LONG
LOCAL bmp AS BITMAP
LOCAL hdc AS DWORD
LOCAL hdcMemImag AS DWORD
LOCAL hdcMemMask AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL lpc AS CREATESTRUCT PTR
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
' Load the original image and get its size
hBitmapImag = LoadBitmap (hInstance, "Matthew")
GetObject hBitmapImag, SIZEOF(BITMAP), bmp
cxBitmap = bmp.bmWidth
cyBitmap = bmp.bmHeight
' Select the original image into a memory DC
hdcMemImag = CreateCompatibleDC(%NULL)
SelectObject hdcMemImag, hBitmapImag
' Create the monochrome mask bitmap and memory DC
hBitmapMask = CreateBitmap(cxBitmap, cyBitmap, 1, 1, BYVAL %NULL)
hdcMemMask = CreateCompatibleDC(%NULL)
SelectObject hdcMemMask, hBitmapMask
' Color the mask bitmap black with a white ellipse
SelectObject hdcMemMask, GetStockObject(%BLACK_BRUSH)
Rectangle hdcMemMask, 0, 0, cxBitmap, cyBitmap
SelectObject hdcMemMask, GetStockObject(%WHITE_BRUSH)
Ellipse hdcMemMask, 0, 0, cxBitmap, cyBitmap
' Mask the original image
BitBlt hdcMemImag, 0, 0, cxBitmap, cyBitmap, hdcMemMask, 0, 0, %SRCAND
DeleteDC hdcMemImag
DeleteDC hdcMemMask
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Select bitmaps into memory DCs
hdcMemImag = CreateCompatibleDC(hdc)
SelectObject hdcMemImag, hBitmapImag
hdcMemMask = CreateCompatibleDC(hdc)
SelectObject hdcMemMask, hBitmapMask
' Center image
x = (cxClient - cxBitmap) / 2
y = (cyClient - cyBitmap) / 2
' Do the bitblts
BitBlt hdc, x, y, cxBitmap, cyBitmap, hdcMemMask, 0, 0, &H220326
BitBlt hdc, x, y, cxBitmap, cyBitmap, hdcMemImag, 0, 0, %SRCPAINT
DeleteDC hdcMemImag
DeleteDC hdcMemMask
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hBitmapImag
DeleteObject hBitmapMask
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BLOKOUT1.C -- Mouse Button Demo Program © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
This program demonstrates a little something that might be implemented in a Windows drawing program. You begin by depressing the left mouse button to indicate one corner of a rectangle. You then drag the mouse. The program draws an outlined rectangle with the opposite corner at the current mouse position. When you release the mouse, the program fills in the rectangle.
' ========================================================================================
' BLOKOUT1.BAS
' This program is a translation/adaptation of BLOKOUT1.C -- Mouse Button Demo Program
' © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' This program demonstrates a little something that might be implemented in a Windows
' drawing program. You begin by depressing the left mouse button to indicate one corner of
' a rectangle. You then drag the mouse. The program draws an outlined rectangle with the
' opposite corner at the current mouse position. When you release the mouse, the program
' fills in the rectangle.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BlokOut1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Mouse Button Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DrawBoxOutline (BYVAL hwnd AS DWORD, ptBeg AS POINTAPI, ptEnd AS POINTAPI)
LOCAL hdc AS DWORD
hdc = GetDC(hwnd)
SetROP2 hdc, %R2_NOT
SelectObject hdc, GetStockObject(%NULL_BRUSH)
Rectangle hdc, ptBeg.x, ptBeg.y, ptEnd.x, ptEnd.y
ReleaseDC hwnd, hdc
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC fBlocking AS LONG
STATIC fValidBox AS LONG
STATIC ptBeg AS POINT
STATIC ptEnd AS POINT
STATIC ptBoxBeg AS POINT
STATIC ptBoxEnd AS POINT
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDOWN
ptBeg.x = LOWRD(lParam)
ptBeg.y = HIWRD(lParam)
ptEnd.x = ptBeg.x
ptEnd.y = ptBeg.y
DrawBoxOutline hwnd, ptBeg, ptEnd
SetCursor LoadCursor(%NULL, BYVAL %IDC_CROSS)
fBlocking = %TRUE
EXIT FUNCTION
CASE %WM_MOUSEMOVE
IF fBlocking THEN
SetCursor LoadCursor(%NULL, BYVAL %IDC_CROSS)
DrawBoxOutline hwnd, ptBeg, ptEnd
ptEnd.x = LOWRD(lParam)
ptEnd.y = HIWRD(lParam)
DrawBoxOutline hwnd, ptBeg, ptEnd
END IF
EXIT FUNCTION
CASE %WM_LBUTTONUP
IF fBlocking THEN
DrawBoxOutline hwnd, ptBeg, ptEnd
ptBoxBeg = ptBeg
ptBoxEnd.x = LOWRD(lParam)
ptBoxEnd.y = HIWRD(lParam)
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
fBlocking = %FALSE
fValidBox = %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_CHAR
IF ISTRUE fBlocking AND wParam = %VK_ESCAPE THEN
DrawBoxOutline hwnd, ptBeg, ptEnd
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
fBlocking = %FALSE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
IF fValidBox THEN
SelectObject hdc, GetStockObject(%BLACK_BRUSH)
Rectangle hdc, ptBoxBeg.x, ptBoxBeg.y, ptBoxEnd.x, ptBoxEnd.y
END IF
IF fBlocking THEN
SetROP2 hdc, %R2_NOT
SelectObject hdc, GetStockObject(%NULL_BRUSH)
Rectangle hdc, ptBeg.x, ptBeg.y, ptEnd.x, ptEnd.y
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BLOKOUT2.C -- Mouse Button & Capture Demo Program © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
BLOKOUT2 is the same as BLOKOUT1, except with three new lines of code: a call to SetCapture during the WM_LBUTTONDOWN message and calls to ReleaseCapture during the WM_LBUTTONDOWN and WM_CHAR messages. And check this out: Make the window smaller than the screen size, begin blocking out a rectangle within the client area, and then move the mouse cursor outside the client and to the right or bottom, and finally release the mouse button. The program will have the coordinates of the entire rectangle. Just enlarge the window to see it.
' ========================================================================================
' BLOKOUT2.BAS
' This program is a translation/adaptation of BLOKOUT2.C -- Mouse Button & Capture Demo
' Program © Charles Petzold, 1998, described and analysed in Chapter 7 of the book
' Programming Windows, 5th Edition.
' BLOKOUT2 is the same as BLOKOUT1, except with three new lines of code: a call to
' SetCapture during the WM_LBUTTONDOWN message and calls to ReleaseCapture during the
' WM_LBUTTONDOWN and WM_CHAR messages. And check this out: Make the window smaller than
' the screen size, begin blocking out a rectangle within the client area, and then move
' the mouse cursor outside the client and to the right or bottom, and finally release the
' mouse button. The program will have the coordinates of the entire rectangle. Just
' enlarge the window to see it.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BlokOut2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Mouse Button & Capture Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DrawBoxOutline (BYVAL hwnd AS DWORD, ptBeg AS POINTAPI, ptEnd AS POINTAPI)
LOCAL hdc AS DWORD
hdc = GetDC(hwnd)
SetROP2 hdc, %R2_NOT
SelectObject hdc, GetStockObject(%NULL_BRUSH)
Rectangle hdc, ptBeg.x, ptBeg.y, ptEnd.x, ptEnd.y
ReleaseDC hwnd, hdc
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC fBlocking AS LONG
STATIC fValidBox AS LONG
STATIC ptBeg AS POINT
STATIC ptEnd AS POINT
STATIC ptBoxBeg AS POINT
STATIC ptBoxEnd AS POINT
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDOWN
ptBeg.x = LOWRD(lParam)
ptBeg.y = HIWRD(lParam)
ptEnd.x = ptBeg.x
ptEnd.y = ptBeg.y
DrawBoxOutline hwnd, ptBeg, ptEnd
SetCapture hwnd
SetCursor LoadCursor(%NULL, BYVAL %IDC_CROSS)
fBlocking = %TRUE
EXIT FUNCTION
CASE %WM_MOUSEMOVE
IF fBlocking THEN
SetCursor LoadCursor(%NULL, BYVAL %IDC_CROSS)
DrawBoxOutline hwnd, ptBeg, ptEnd
ptEnd.x = LOWRD(lParam)
ptEnd.y = HIWRD(lParam)
DrawBoxOutline hwnd, ptBeg, ptEnd
END IF
EXIT FUNCTION
CASE %WM_LBUTTONUP
IF fBlocking THEN
DrawBoxOutline hwnd, ptBeg, ptEnd
ptBoxBeg = ptBeg
ptBoxEnd.x = LOWRD(lParam)
ptBoxEnd.y = HIWRD(lParam)
ReleaseCapture()
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
fBlocking = %FALSE
fValidBox = %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_CHAR
IF ISTRUE fBlocking AND wParam = %VK_ESCAPE THEN
DrawBoxOutline hwnd, ptBeg, ptEnd
ReleaseCapture()
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
fBlocking = %FALSE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
IF fValidBox THEN
SelectObject hdc, GetStockObject(%BLACK_BRUSH)
Rectangle hdc, ptBoxBeg.x, ptBoxBeg.y, ptBoxEnd.x, ptBoxEnd.y
END IF
IF fBlocking THEN
SetROP2 hdc, %R2_NOT
SelectObject hdc, GetStockObject(%NULL_BRUSH)
Rectangle hdc, ptBeg.x, ptBeg.y, ptEnd.x, ptEnd.y
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BOUNCE.C -- Bouncing Ball Program © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
The BOUNCE program constructs a ball that bounces around in the window's client area. The program uses the timer to pace the ball. The ball itself is a bitmap. The program first creates the ball by creating the bitmap, selecting it into a memory device context, and then making simple GDI function calls. The program draws the bitmapped ball on the display using a BitBlt from a memory device context.
' ========================================================================================
' BOUNCE.BAS
' This program is a translation/adaptation of BOUNCE.C -- Bouncing Ball Program
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The BOUNCE program constructs a ball that bounces around in the window's client area.
' The program uses the timer to pace the ball. The ball itself is a bitmap. The program
' first creates the ball by creating the bitmap, selecting it into a memory device
' context, and then making simple GDI function calls. The program draws the bitmapped ball
' on the display using a BitBlt from a memory device context.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Bounce"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Bouncing Ball"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hBitmap AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC xCenter AS LONG
STATIC yCenter AS LONG
STATIC cxTotal AS LONG
STATIC cyTotal AS LONG
STATIC cxRadius AS LONG
STATIC cyRadius AS LONG
STATIC cxMove AS LONG
STATIC cyMove AS LONG
STATIC xPixel AS LONG
STATIC yPixel AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcMem AS DWORD
LOCAL iScale AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
hdc = GetDC(hwnd)
xPixel = GetDeviceCaps(hdc, %ASPECTX)
yPixel = GetDeviceCaps(hdc, %ASPECTY)
ReleaseDC hwnd, hdc
SetTimer hwnd, %ID_TIMER, 50, %NULL
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
xCenter = cxClient \ 2
yCenter = cyClient \ 2
iScale = MIN&(cxClient * xPixel, cyClient * yPixel) \ 16
cxRadius = iScale \ xPixel
cyRadius = iScale \ yPixel
cxMove = MAX&(1, cxRadius \ 2)
cyMove = MAX&(1, cyRadius \ 2)
cxTotal = 2 * (cxRadius + cxMove)
cyTotal = 2 * (cyRadius + cyMove)
IF hBitmap THEN DeleteObject hBitmap
hdc = GetDC(hwnd)
hdcMem = CreateCompatibleDC(hdc)
hBitmap = CreateCompatibleBitmap(hdc, cxTotal, cyTotal)
ReleaseDC hwnd, hdc
SelectObject hdcMem, hBitmap
Rectangle hdcMem, -1, -1, cxTotal + 1, cyTotal + 1
hBrush = CreateHatchBrush(%HS_DIAGCROSS, 0)
SelectObject hdcMem, hBrush
SetBkColor hdcMem, RGB(255, 0, 255)
Ellipse hdcMem, cxMove, cyMove, cxTotal - cxMove, cyTotal - cyMove
DeleteDC hdcMem
DeleteObject hBrush
EXIT FUNCTION
CASE %WM_TIMER
IF ISFALSE hBitmap THEN EXIT FUNCTION
hdc = GetDC(hwnd)
hdcMem = CreateCompatibleDC(hdc)
SelectObject hdcMem, hBitmap
BitBlt hdc, xCenter - cxTotal \ 2, _
yCenter - cyTotal \ 2, cxTotal, cyTotal, _
hdcMem, 0, 0, %SRCCOPY
ReleaseDC hwnd, hdc
DeleteDC hdcMem
xCenter = xCenter + cxMove
yCenter = yCenter + cyMove
IF (xCenter + cxRadius) >= cxClient OR (xCenter - cxRadius <= 0) THEN cxMove = -cxMove
IF (yCenter + cyRadius) >= cyClient OR (yCenter - cyRadius) <= 0 THEN cyMove = -cyMove
EXIT FUNCTION
CASE %WM_DESTROY
IF hBitmap THEN DeleteObject hBitmap
KillTimer hwnd, %ID_TIMER
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BRICKS1.C -- LoadBitmap Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
Shows how to load a small monochrome bitmap resource. This bitmap doesn't exactly look like a brick by itself but when repeated horizontally and vertically resembles a wall of bricks.
' ========================================================================================
' BRICKS1.BAS
' This program is a translation/adaptation of BRICKS1.C -- LoadBitmap Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' Shows how to load a small monochrome bitmap resource. This bitmap doesn't exactly look
' like a brick by itself but when repeated horizontally and vertically resembles a wall of
' bricks.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "bricks1.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Bricks1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "LoadBitmap Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hBitmap AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxSource AS LONG
STATIC cySource AS LONG
LOCAL bmp AS BITMAP
LOCAL hdc AS DWORD
LOCAL hdcMem AS DWORD
LOCAL lpc AS CREATESTRUCT PTR
LOCAL hInstance AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
hBitmap = LoadBitmap(hInstance, "Bricks")
GetObject hBitmap, SIZEOF(BITMAP), bmp
cxSource = bmp.bmWidth
cySource = bmp.bmHeight
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
hdcMem = CreateCompatibleDC(hdc)
SelectObject hdcMem, hBitmap
FOR y = 0 TO cxClient - 1 STEP cySource
FOR x = 0 TO cxClient - 1 STEP cxSource
BitBlt hdc, x, y, cxSource, cySource, hdcMem, 0, 0, %SRCCOPY
NEXT
NEXT
DeleteDC hdcMem
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hBitmap
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BRICKS2.C -- CreateBitmap Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
If you're working with small monochrome images, you don't have to create them as resources. Unlike color bitmap objects, the format of monochrome bits is relatively simple and can almost be derived directly from the image you want to create.
You can write down a series of bits (0 for black and 1 for white) that directly corresponds to this grid. Reading these bits from left to right, you can then assign each group of 8 bits a hexadecimal byte. If the width of the bitmap is not a multiple of 16, pad the bytes to the right with zeros to get an even number of bytes.
The BRICKS2 program uses this technique to create the bricks bitmap directly without requiring a resource.
' ========================================================================================
' BRICKS2.BAS
' This program is a translation/adaptation of BRICKS2.C -- CreateBitmap Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' If you're working with small monochrome images, you don't have to create them as
' resources. Unlike color bitmap objects, the format of monochrome bits is relatively
' simple and can almost be derived directly from the image you want to create.
' You can write down a series of bits (0 for black and 1 for white) that directly
' corresponds to this grid. Reading these bits from left to right, you can then assign
' each group of 8 bits a hexadecimal byte. If the width of the bitmap is not a multiple
' of 16, pad the bytes to the right with zeros to get an even number of bytes.
' The BRICKS2 program uses this technique to create the bricks bitmap directly without
' requiring a resource.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Bricks2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "CreateBitmap Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hBitmap AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxSource AS LONG
STATIC cySource AS LONG
LOCAL hdc AS DWORD
LOCAL hdcMem AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
STATIC bmp AS BITMAP
DIM bmpbits(0 TO 7, 0 TO 1) AS STATIC BYTE
SELECT CASE uMsg
CASE %WM_CREATE
bmp.bmType = 0
bmp.bmWidth = 8
bmp.bmHeight = 8
bmp.bmWidthBytes = 2
bmp.bmPlanes = 1
bmp.bmBitsPixel = 1
bmpbits(0, 0) = &HFF : bmpbits(1, 0) = 0
bmpbits(2, 0) = &H0C : bmpbits(3, 0) = 0
bmpbits(4, 0) = &H0C : bmpbits(5, 0) = 0
bmpbits(6, 0) = &H0C : bmpbits(7, 0) = 0
bmpbits(0, 1) = &HFF : bmpbits(1, 1) = 0
bmpbits(2, 1) = &HC0 : bmpbits(3, 1) = 0
bmpbits(4, 1) = &HC0 : bmpbits(5, 1) = 0
bmpbits(6, 1) = &HC0 : bmpbits(7, 1) = 0
bmp.bmBits = VARPTR(bmpbits(0))
hBitmap = CreateBitmapIndirect(bmp)
cxSource = bmp.bmWidth
cySource = bmp.bmHeight
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
hdcMem = CreateCompatibleDC(hdc)
SelectObject hdcMem, hBitmap
FOR y = 0 TO cxClient - 1 STEP cySource
FOR x = 0 TO cxClient - 1 STEP cxSource
BitBlt hdc, x, y, cxSource, cySource, hdcMem, 0, 0, %SRCCOPY
NEXT
NEXT
DeleteDC hdcMem
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hBitmap
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BRICKS3.C -- CreatePatternBrush Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
The final entry in the BRICKS series is BRICKS3. At first glance this program might provoke the reaction "Where's the code?"
As you can see, the window procedure doesn't do much of anything. BRICKS3 actually uses the bricks pattern as the window class background brush, which is defined in the hbrBackground field of the WNDCLASS structure.
' ========================================================================================
' BRICKS3.BAS
' This program is a translation/adaptation of BRICKS3.C -- CreatePatternBrush Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The final entry in the BRICKS series is BRICKS3. At first glance this program might
' provoke the reaction "Where's the code?"
' As you can see, the window procedure doesn't do much of anything. BRICKS3 actually uses
' the bricks pattern as the window class background brush, which is defined in the
' hbrBackground field of the WNDCLASS structure.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "bricks3.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
LOCAL hBitmap AS DWORD
LOCAL hBrush AS DWORD
hBitmap = LoadBitmap (hInstance, "Bricks")
hBrush = CreatePatternBrush(hBitmap)
DeleteObject hBitmap
szAppName = "Bricks3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = hBrush
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "CreatePatternBrush Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
DeleteObject hBrush
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BTNLOOK.C -- Button Look Program © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.
Creates 10 child window button controls, one for each of the 10 standard styles of buttons.
' ========================================================================================
' BTNLOOK.BAS
' This program is a translation/adaptation of BTNLOOK.C -- Button Look Program
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' Creates 10 child window button controls, one for each of the 10 standard styles of
' buttons.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
TYPE BUTTON_STRUCT
iStyle AS LONG
szText AS ASCIIZ * 256
END TYPE
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BtnLook"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Button Look"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM tbutton(9) AS STATIC BUTTON_STRUCT
DIM hwndButton(9) AS STATIC DWORD
STATIC rc AS RECT
STATIC szTop AS ASCIIZ * 256
STATIC szUnd AS ASCIIZ * 256
STATIC szFormat AS ASCIIZ * 256
STATIC szBuffer AS ASCIIZ * 256
STATIC cxChar AS LONG
STATIC cyChar AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL i AS LONG
LOCAL lpc AS CREATESTRUCT PTR
LOCAL hInstance AS DWORD
LOCAL szMsg AS ASCIIZ * 256
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
szTop = "message wParam lParam"
szUnd = "_______ ______ ______"
szFormat = "%-16s%04X-%04X %04X-%04X"
tbutton(0).iStyle = %BS_PUSHBUTTON : tbutton(0).szText = "PUSHBUTTON"
tbutton(1).iStyle = %BS_DEFPUSHBUTTON : tbutton(1).szText = "DEFPUSHBUTTON"
tbutton(2).iStyle = %BS_CHECKBOX : tbutton(2).szText = "CHECKBOX"
tbutton(3).iStyle = %BS_AUTOCHECKBOX : tbutton(3).szText = "AUTOCHECKBOX"
tbutton(4).iStyle = %BS_RADIOBUTTON : tbutton(4).szText = "RADIOBUTTON"
tbutton(5).iStyle = %BS_3STATE : tbutton(5).szText = "3STATE"
tbutton(6).iStyle = %BS_AUTO3STATE : tbutton(6).szText = "AUTO3STATE"
tbutton(7).iStyle = %BS_GROUPBOX : tbutton(7).szText = "GROUPBOX"
tbutton(8).iStyle = %BS_AUTORADIOBUTTON : tbutton(8).szText = "AUTORADIO"
tbutton(9).iStyle = %BS_OWNERDRAW : tbutton(9).szText = "OWNERDRAW"
cxChar = LO(WORD, GetDialogBaseUnits())
cyChar = HI(WORD, GetDialogBaseUnits())
FOR i = 0 TO 9
hwndButton(i) = CreateWindowEx (0, "button", _
tbutton(i).szText, _
%WS_CHILD OR %WS_VISIBLE OR tbutton(i).iStyle, _
cxChar, cyChar * (1 + 2 * i), _
20 * cxChar, 7 * cyChar / 4, _
hwnd, i, hInstance, BYVAL %NULL)
NEXT
EXIT FUNCTION
CASE %WM_SIZE
rc.nLeft = 24 * cxChar
rc.nTop = 2 * cyChar
rc.nRight = LO(WORD, lParam)
rc.nBottom = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
SetBkMode hdc, %TRANSPARENT
TextOut hdc, 24 * cxChar, cyChar, szTop, LEN(szTop)
TextOut hdc, 24 * cxChar, cyChar, szUnd, LEN(szUnd)
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DRAWITEM, %WM_COMMAND
ScrollWindow hwnd, 0, -cyChar, rc, rc
hdc = GetDC(hwnd)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
IF uMsg = %WM_DRAWITEM THEN
szMsg = "WM_DRAWITEM"
ELSE
szMsg = "WM_COMMAND"
END IF
wsprintf szBuffer, szFormat, szMsg, BYVAL HIWRD(wParam), BYVAL LOWRD(wParam), BYVAL HIWRD(lParam), BYVAL LOWRD(lParam)
TextOut hdc, 24 * cxChar, cyChar * (rc.nBottom / cyChar - 1), szBuffer, LEN(szBuffer)
ReleaseDC hwnd, hdc
ValidateRect hwnd, rc
' Fall through DefWindowProc
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CHECKER1.C -- Mouse Hit-Test Demo Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
Demonstrates some simple hit-testing. The program divides the client area into a 5-by-5 array of 25 rectangles. If you click the mouse on one of the rectangles, the rectangle is filled with an X. If you click there again, the X is removed.
' ========================================================================================
' CHECKER1.BAS
' This program is a translation/adaptation of CHECKER1.C -- Mouse Hit-Test Demo Program No. 1
' © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' Demonstrates some simple hit-testing. The program divides the client area into a 5-by-5
' array of 25 rectangles. If you click the mouse on one of the rectangles, the rectangle
' is filled with an X. If you click there again, the X is removed.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%DIVISIONS = 5
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Checker1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Checker1 Mouse Hit-Test Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main window callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM fState(0 TO %DIVISIONS, 0 TO %DIVISIONS) AS STATIC LONG
STATIC cxBlock AS LONG
STATIC cyBlock AS LONG
LOCAL hdc AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_SIZE
cxBlock = LO(WORD, lParam) \ %DIVISIONS
cyBlock = HI(WORD, lParam) \ %DIVISIONS
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDOWN
x = LO(WORD, lParam) \ cxBlock
y = HI(WORD, lParam) \ cyBlock
IF x < %DIVISIONS AND y < %DIVISIONS THEN
fState(x, y) = IIF&(fState(x, y) = 1, 0, 1)
rc.nLeft = x * cxBlock
rc.nTop = y * cyBlock
rc.nRight = (x + 1) * cxBlock
rc.nBottom = (y + 1) * cyBlock
InvalidateRect hwnd, rc, %FALSE
ELSE
MessageBeep 0
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
Rectangle hdc, x * cxBlock, y * cyBlock, _
(x + 1) * cxBlock, (y + 1) * cyBlock
IF fState(x, y) THEN
MoveToEx hdc, x * cxBlock, y * cyBlock, BYVAL %NULL
LineTo hdc, (x+1) * cxBlock, (y+1) * cyBlock
MoveToEx hdc, x * cxBlock, (y+1) * cyBlock, BYVAL %NULL
LineTo hdc, (x+1) * cxBlock, y * cyBlock
END IF
NEXT
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CHECKER2.C -- Mouse Hit-Test Demo Program No. 2 © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
Same as CHECKER1, except that it includes a keyboard interface. You can use the Left, Right, Up, and Down arrow keys to move the cursor among the 25 rectangles. The Home key sends the cursor to the upper left rectangle; the End key drops it down to the lower right rectangle. Both the Spacebar and Enter keys toggle the X mark.
' ========================================================================================
' CHECKER2.BAS
' This program is a translation/adaptation of CHECKER2.C -- Mouse Hit-Test Demo Program No. 2
' © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' Same as CHECKER1, except that it includes a keyboard interface. You can use the Left,
' Right, Up, and Down arrow keys to move the cursor among the 25 rectangles. The Home key
' sends the cursor to the upper left rectangle; the End key drops it down to the lower
' right rectangle. Both the Spacebar and Enter keys toggle the X mark.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%DIVISIONS = 5
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Checker2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Checker2 Mouse Hit-Test Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main window callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM fState(0 TO %DIVISIONS, 0 TO %DIVISIONS) AS STATIC LONG
STATIC cxBlock AS LONG
STATIC cyBlock AS LONG
LOCAL hdc AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL pt AS POINT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxBlock = LO(WORD, lParam) \ %DIVISIONS
cyBlock = HI(WORD, lParam) \ %DIVISIONS
EXIT FUNCTION
CASE %WM_SETFOCUS
ShowCursor %TRUE
EXIT FUNCTION
CASE %WM_KILLFOCUS
ShowCursor %FALSE
EXIT FUNCTION
CASE %WM_KEYDOWN
GetCursorPos pt
ScreenToClient hwnd, pt
x = MAX&(0, MIN&(%DIVISIONS - 1, pt.x \ cxBlock))
y = MAX&(0, MIN&(%DIVISIONS - 1, pt.y \ cyBlock))
SELECT CASE wParam
CASE %VK_UP
DECR y
CASE %VK_DOWN
INCR y
CASE %VK_LEFT
DECR x
CASE %VK_RIGHT
INCR x
CASE %VK_HOME
x = 0
y = 0
CASE %VK_END
x = %DIVISIONS - 1
y = %DIVISIONS - 1
CASE %VK_RETURN, %VK_SPACE
SendMessage hwnd, %WM_LBUTTONDOWN, %MK_LBUTTON, _
MAKLNG(x * cxBlock, y * cyBlock)
END SELECT
x = (x + %DIVISIONS) MOD %DIVISIONS
y = (y + %DIVISIONS) MOD %DIVISIONS
pt.x = x * cxBlock + cxBlock \ 2
pt.y = y * cyBlock + cyBlock \ 2
ClientToScreen hwnd, pt
SetCursorPos pt.x, pt.y
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
x = LO(WORD, lParam) \ cxBlock
y = HI(WORD, lParam) \ cyBlock
IF x < %DIVISIONS AND y < %DIVISIONS THEN
fState(x, y) = IIF&(fState(x, y) = 1, 0, 1)
rc.nLeft = x * cxBlock
rc.nTop = y * cyBlock
rc.nRight = (x + 1) * cxBlock
rc.nBottom = (y + 1) * cyBlock
InvalidateRect hwnd, rc, %FALSE
ELSE
MessageBeep 0
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
Rectangle hdc, x * cxBlock, y * cyBlock, _
(x + 1) * cxBlock, (y + 1) * cyBlock
IF fState(x, y) THEN
MoveToEx hdc, x * cxBlock, y * cyBlock, BYVAL %NULL
LineTo hdc, (x+1) * cxBlock, (y+1) * cyBlock
MoveToEx hdc, x * cxBlock, (y+1) * cyBlock, BYVAL %NULL
LineTo hdc, (x+1) * cxBlock, y * cyBlock
END IF
NEXT
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CHECKER3.C -- Mouse Hit-Test Demo Program No. 3 © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
This version of the program creates 25 child windows to process mouse clicks.
' ========================================================================================
' CHECKER3.BAS
' This program is a translation/adaptation of CHECKER3.C -- Mouse Hit-Test Demo Program No. 3
' © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' This version of the program creates 25 child windows to process mouse clicks.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%DIVISIONS = 5
GLOBAL szChildClass AS ASCIIZ * 256
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Checker3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szChildClass = "Checker3_Child"
wcex.lpfnWndProc = CODEPTR(ChildWndProc)
wcex.cbWndExtra = 4
wcex.hIcon = %NULL
wcex.lpszClassName = VARPTR(szChildClass)
RegisterClassEx wcex
szCaption = "Checker3 Mouse Hit-Test Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main window callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM hwndChild(0 TO %DIVISIONS, 0 TO %DIVISIONS) AS STATIC DWORD
LOCAL cxBlock AS LONG
LOCAL cyBlock AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL id AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
id = y
SHIFT LEFT id, 8
id = id OR x
hwndChild(x, y) = CreateWindowEx(0, szChildClass, BYVAL %NULL, _
%WS_CHILDWINDOW OR %WS_VISIBLE, _
0, 0, 0, 0, _
hwnd, id, _
GetWindowLong(hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
NEXT
NEXT
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxBlock = LO(WORD, lParam) \ %DIVISIONS
cyBlock = HI(WORD, lParam) \ %DIVISIONS
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
MoveWindow hwndChild(x, y), _
x * cxBlock, y * cyBlock, _
cxBlock, cyBlock, %TRUE
NEXT
NEXT
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
MessageBeep 0
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Child window callback
' ========================================================================================
FUNCTION ChildWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
SetWindowLong hwnd, 0, 0 ' on/off flag
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
SetWindowLong hwnd, 0, IIF&(GetWindowLong(hwnd, 0) = 1, 0, 1)
InvalidateRect hwnd, BYVAL %NULL, %FALSE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
Rectangle hdc, 0, 0, rc.nRight, rc.nBottom
IF GetWindowLong (hwnd, 0) THEN
MoveToEx hdc, 0, 0, BYVAL %NULL
LineTo hdc, rc.nRight, rc.nBottom
MoveToEx hdc, 0, rc.nBottom, BYVAL %NULL
LineTo hdc, rc.nRight, 0
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CHECKER4.C -- Mouse Hit-Test Demo Program No. 4 © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
Same as CHECKER3 with added keyboard interface.
' ========================================================================================
' CHECKER4.BAS
' This program is a translation/adaptation of CHECKER4.C -- Mouse Hit-Test Demo Program No. 4
' © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' Same as CHECKER3 with added keyboard interface.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%DIVISIONS = 5
GLOBAL szChildClass AS ASCIIZ * 256
GLOBAL idFocus AS LONG
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Checker4"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szChildClass = "Checker4_Child"
wcex.lpfnWndProc = CODEPTR(ChildWndProc)
wcex.cbWndExtra = 4
wcex.hIcon = %NULL
wcex.lpszClassName = VARPTR(szChildClass)
RegisterClassEx wcex
szCaption = "Checker4 Mouse Hit-Test Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main window callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM hwndChild(0 TO %DIVISIONS, 0 TO %DIVISIONS) AS STATIC DWORD
LOCAL cxBlock AS LONG
LOCAL cyBlock AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL id AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
id = y
SHIFT LEFT id, 8
id = id OR x
hwndChild(x, y) = CreateWindowEx(0, szChildClass, BYVAL %NULL, _
%WS_CHILDWINDOW OR %WS_VISIBLE, _
0, 0, 0, 0, _
hwnd, id, _
GetWindowLong(hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
NEXT
NEXT
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxBlock = LO(WORD, lParam) \ %DIVISIONS
cyBlock = HI(WORD, lParam) \ %DIVISIONS
FOR x = 0 TO %DIVISIONS - 1
FOR y = 0 TO %DIVISIONS - 1
MoveWindow hwndChild(x, y), _
x * cxBlock, y * cyBlock, _
cxBlock, cyBlock, %TRUE
NEXT
NEXT
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
MessageBeep 0
EXIT FUNCTION
' On set-focus message, set focus to child window
CASE %WM_SETFOCUS
SetFocus GetDlgItem(hwnd, idFocus)
EXIT FUNCTION
CASE %WM_KEYDOWN
x = idFocus AND &HFF
y = idFocus
SHIFT RIGHT y, 8
SELECT CASE wParam
CASE %VK_UP: DECR y
CASE %VK_DOWN: INCR y
CASE %VK_LEFT: DECR x
CASE %VK_RIGHT: INCR x
CASE %VK_HOME: x = 0 : y = 0
CASE %VK_END: x = %DIVISIONS - 1 : y = x
CASE ELSE
EXIT FUNCTION
END SELECT
x = (x + %DIVISIONS) MOD %DIVISIONS
y = (y + %DIVISIONS) MOD %DIVISIONS
idFocus = y
SHIFT LEFT idFocus, 8
idFocus = idFocus OR x
SetFocus GetDlgItem(hwnd, idFocus)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Child window callback
' ========================================================================================
FUNCTION ChildWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
SetWindowLong hwnd, 0, 0 ' on/off flag
EXIT FUNCTION
CASE %WM_KEYDOWN
' Send most key presses to the parent window
IF wParam <> %VK_RETURN AND wParam <> %VK_SPACE THEN
SendMessage GetParent(hwnd), uMsg, wParam, lParam
EXIT FUNCTION
END IF
' For Return and Space, fall through to toggle the square
SendMessage hwnd, %WM_LBUTTONDOWN, %MK_LBUTTON, 0
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
SetWindowLong hwnd, 0, IIF&(GetWindowLong(hwnd, 0) = 1, 0, 1)
SetFocus hwnd
InvalidateRect hwnd, BYVAL %NULL, %FALSE
EXIT FUNCTION
' For focus messages, invalidate the window for repaint
CASE %WM_SETFOCUS
idFocus = GetWindowLong(hwnd, %GWL_ID)
InvalidateRect hwnd, BYVAL %NULL, %FALSE
EXIT FUNCTION
CASE %WM_KILLFOCUS
InvalidateRect hwnd, BYVAL %NULL, %FALSE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
Rectangle hdc, 0, 0, rc.nRight, rc.nBottom
IF GetWindowLong (hwnd, 0) THEN
MoveToEx hdc, 0, 0, BYVAL %NULL
LineTo hdc, rc.nRight, rc.nBottom
MoveToEx hdc, 0, rc.nBottom, BYVAL %NULL
LineTo hdc, rc.nRight, 0
END IF
' Draw the "focus" rectangle
IF hwnd = GetFocus() THEN
rc.nLeft = rc.nLeft + rc.nRight \ 10
rc.nRight = rc.nRight - rc.nLeft
rc.nTop = rc.nTop + rc.nBottom \ 10
rc.nBottom = rc.nBottom - rc.nTop
SelectObject hdc, GetStockObject(%NULL_BRUSH)
SelectObject hdc, CreatePen(%PS_DASH, 0, 0)
Rectangle hdc, rc.nLeft, rc.nTop, rc.nRight, rc.nBottom
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CHOSFONT.C -- ChooseFont Demo © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
The CHOSFONT program demonstrates using the ChooseFont function and displays the fields of the LOGFONT structure that the function defines. The program also displays the same string of text as PICKFONT.
' ========================================================================================
' CHOSFONT.BAS
' This program is a translation/adaptation of CHOSFONT.C -- ChooseFont Demo
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The CHOSFONT program demonstrates using the ChooseFont function and displays the fields
' of the LOGFONT structure that the function defines. The program also displays the same
' string of text as PICKFONT.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "chosfont.res"
%IDM_FONT = 40001
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "ChosFont"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "ChooseFont"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cf AS CHOOSEFONTAPI
STATIC cyChar AS LONG
STATIC lf AS LOGFONT
STATIC szText AS ASCIIZ * 256
LOCAL hdc AS DWORD
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL szBuffer AS ASCIIZ * 64
LOCAL tm AS TEXTMETRIC
SELECT CASE uMsg
CASE %WM_CREATE
szText = CHR$(&H41, &H42, &H43, &H44, &H45) & " " & _
CHR$(&H61, &H62, &H63, &H64, &H65) & " " & _
CHR$(&HC0, &HC1, &HC2, &HC3, &HC4, &HC5) & " " & _
CHR$(&HE0, &HE1, &HE2, &HE3, &HE4, &HE5)
' Get text height
cyChar = HIWRD(GetDialogBaseUnits())
' Initialize the LOGFONT structure
GetObject (GetStockObject(%SYSTEM_FONT), SIZEOF(lf), lf)
' Inialize the CHOOSEFONT structure
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hwnd
cf.hDC = %NULL
cf.lpLogFont = VARPTR(lf)
cf.iPointSize = 0
cf.Flags = %CF_INITTOLOGFONTSTRUCT OR _
%CF_SCREENFONTS OR %CF_EFFECTS
cf.rgbColors = 0
cf.lCustData = 0
cf.lpfnHook = %NULL
cf.lpTemplateName = %NULL
cf.hInstance = %NULL
cf.lpszStyle = %NULL
cf.nFontType = 0
cf.nSizeMin = 0
cf.nSizeMax = 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FONT
IF ChooseFont(cf) THEN
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Display sample text using selected font
SelectObject hdc, CreateFontIndirect(lf)
GetTextMetrics hdc, tm
SetTextColor hdc, cf.rgbColors
y = tm.tmExternalLeading
TextOut hdc, 0, y, szText, LEN(szText)
' Display LOGFONT structure fields using system font
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
SetTextColor hdc, 0
wsprintf szBuffer, "lfHeight = %i", BYVAL lf.lfHeight
y = y + tm.tmHeight
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfWidth = %i", BYVAL lf.lfWidth
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfEscapement = %i", BYVAL lf.lfEscapement
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfOrientation = %i", BYVAL lf.lfOrientation
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfWeight = %i", BYVAL lf.lfWeight
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfItalic = %i", BYVAL lf.lfItalic
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfUnderline = %i", BYVAL lf.lfUnderline
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfStrikeOut = %i", BYVAL lf.lfStrikeOut
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfCharSet = %i", BYVAL lf.lfCharSet
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfOutPrecision = %i", BYVAL lf.lfOutPrecision
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfClipPrecision = %i", BYVAL lf.lfClipPrecision
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfQuality = %i", BYVAL lf.lfQuality
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfPitchAndFamily = 0x%02X", BYVAL lf.lfPitchAndFamily
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
wsprintf szBuffer, "lfFaceName = %s", lf.lfFaceName
y = y + cyChar
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CLIPTEXT.C -- The Clipboard and Text © Charles Petzold, 1998, described and analysed in Chapter 12 of the book Programming Windows, 5th Edition.
Clipboard text transfers.
ANSI version
' ========================================================================================
' CLIPTEXT.BAS
' This program is a translation/adaptation of CLIPTEXT.C -- The Clipboard and Text
' © Charles Petzold, 1998, described and analysed in Chapter 12 of the book Programming
' Windows, 5th Edition.
' Clipboard text transfers.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "cliptext.res"
%IDM_EDIT_CUT = 40001
%IDM_EDIT_COPY = 40002
%IDM_EDIT_PASTE = 40003
%IDM_EDIT_CLEAR = 40004
%IDM_EDIT_RESET = 40005
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "ClipText"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Clipboard Text Transfers - ANSI Version"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC szDefaultText AS ASCIIZ * 256
STATIC pText AS ASCIIZ PTR
LOCAL bEnable AS LONG
LOCAL hGlobal AS DWORD
LOCAL hdc AS DWORD
LOCAL pGlobal AS ASCIIZ PTR
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
szDefaultText = "Default Text - ANSI Version"
SendMessage hwnd, %WM_COMMAND, %IDM_EDIT_RESET, 0
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
EnableMenuItem (wParam, %IDM_EDIT_PASTE, _
IIF&(IsClipboardFormatAvailable(%CF_TEXT), %MF_ENABLED, %MF_GRAYED))
bEnable = IIF&(pText, %MF_ENABLED, %MF_GRAYED)
EnableMenuItem wParam, %IDM_EDIT_CUT, bEnable
EnableMenuItem wParam, %IDM_EDIT_COPY, bEnable
EnableMenuItem wParam, %IDM_EDIT_CLEAR, bEnable
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_EDIT_PASTE
OpenClipboard hwnd
hGlobal = GetClipboardData(%CF_TEXT)
IF hGlobal THEN
pGlobal = GlobalLock (hGlobal)
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
pText = CoTaskMemAlloc(GlobalSize(hGlobal))
lstrcpy (BYVAL pText, BYVAL pGlobal)
GlobalUnlock hGlobal
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CloseClipboard
CASE %IDM_EDIT_CUT, %IDM_EDIT_COPY
IF ISFALSE pText THEN EXIT FUNCTION
hGlobal = GlobalAlloc(%GHND OR %GMEM_SHARE, lstrlen(BYVAL pText) + 1)
pGlobal = GlobalLock(hGlobal)
lstrcpy BYVAL pGlobal, BYVAL pText
GlobalUnlock hGlobal
OpenClipboard hwnd
EmptyClipboard
SetClipboardData %CF_TEXT, hGlobal
CloseClipboard
IF LO(WORD, wParam) = %IDM_EDIT_CUT THEN
SendMessage hwnd, %WM_COMMAND, %IDM_EDIT_CLEAR, 0
END IF
CASE %IDM_EDIT_CLEAR
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_EDIT_RESET
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
pText = CoTaskMemAlloc(lstrlen(szDefaultText) + 1)
lstrcpy BYVAL pText, szDefaultText
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
IF pText THEN DrawText hdc, BYVAL pText, -1, rc, %DT_EXPANDTABS OR %DT_WORDBREAK
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
' Free the allocated memory and end the program
IF pText THEN CoTaskMemFree pText
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
UNICODE version
' ========================================================================================
' CLIPTEXTW.BAS
' This program is a translation/adaptation of CLIPTEXT.C -- The Clipboard and Text
' © Charles Petzold, 1998, described and analysed in Chapter 12 of the book Programming
' Windows, 5th Edition.
' Clipboard text transfers (Unicode version).
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "cliptext.res"
%IDM_EDIT_CUT = 40001
%IDM_EDIT_COPY = 40002
%IDM_EDIT_PASTE = 40003
%IDM_EDIT_CLEAR = 40004
%IDM_EDIT_RESET = 40005
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "ClipText"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Clipboard Text Transfers - UNICODE Version"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
IF IsDialogMessage(hwnd, uMsg) = 0 THEN
TranslateMessage uMsg
DispatchMessage uMsg
END IF
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC wszDefaultText AS WSTRINGZ * 260
STATIC pText AS DWORD
LOCAL bEnable AS LONG
LOCAL hGlobal AS DWORD
LOCAL hdc AS DWORD
LOCAL pGlobal AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
wszDefaultText = "Default Text - UNICODE Version"
SendMessage hwnd, %WM_COMMAND, %IDM_EDIT_RESET, 0
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
EnableMenuItem (wParam, %IDM_EDIT_PASTE, _
IIF&(IsClipboardFormatAvailable(%CF_TEXT), %MF_ENABLED, %MF_GRAYED))
bEnable = IIF&(pText, %MF_ENABLED, %MF_GRAYED)
EnableMenuItem wParam, %IDM_EDIT_CUT, bEnable
EnableMenuItem wParam, %IDM_EDIT_COPY, bEnable
EnableMenuItem wParam, %IDM_EDIT_CLEAR, bEnable
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDCANCEL
IF HI(WORD, wParam) = %BN_CLICKED THEN
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE %IDM_EDIT_PASTE
OpenClipboard hwnd
hGlobal = GetClipboardData(%CF_UNICODETEXT)
IF hGlobal THEN
pGlobal = GlobalLock (hGlobal)
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
pText = CoTaskMemAlloc(GlobalSize(hGlobal))
lstrcpyW (BYVAL pText, BYVAL pGlobal)
GlobalUnlock hGlobal
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CloseClipboard
CASE %IDM_EDIT_CUT, %IDM_EDIT_COPY
IF ISFALSE pText THEN EXIT FUNCTION
hGlobal = GlobalAlloc(%GHND OR %GMEM_SHARE, (lstrlenW(BYVAL pText) + 1) * 2)
pGlobal = GlobalLock(hGlobal)
lstrcpyW BYVAL pGlobal, BYVAL pText
GlobalUnlock hGlobal
OpenClipboard hwnd
EmptyClipboard
SetClipboardData %CF_UNICODETEXT, hGlobal
CloseClipboard
IF LO(WORD, wParam) = %IDM_EDIT_CUT THEN
SendMessage hwnd, %WM_COMMAND, %IDM_EDIT_CLEAR, 0
END IF
CASE %IDM_EDIT_CLEAR
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_EDIT_RESET
IF pText THEN
CoTaskMemFree pText
pText = %NULL
END IF
pText = CoTaskMemAlloc((LEN(wszDefaultText) + 1) * 2)
lstrcpyW BYVAL pText, wszDefaultText
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
IF pText THEN DrawTextW hdc, BYVAL pText, -1, rc, %DT_EXPANDTABS OR %DT_WORDBREAK
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
' Free the allocated memory and end the program
IF pText THEN CoTaskMemFree pText
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CLIPVIEW.C -- Simple Clipboard Viewer © Charles Petzold, 1998, described and analysed in Chapter 12 of the book Programming Windows, 5th Edition.
Clipboard viewers don't have to be as sophisticated as the one supplied with Windows. A clipboard viewer can, for instance, display a single clipboard format. The CLIPVIEW program is a clipboard viewer that displays only the %CF_TEXT format.
' ========================================================================================
' CLIPVIEW.BAS
' This program is a translation/adaptation of CLIPVIEW.C -- Simple Clipboard Viewer
' © Charles Petzold, 1998, described and analysed in Chapter 12 of the book Programming
' Windows, 5th Edition.
' Clipboard viewers don't have to be as sophisticated as the one supplied with Windows. A
' clipboard viewer can, for instance, display a single clipboard format. The CLIPVIEW
' program is a clipboard viewer that displays only the %CF_TEXT format.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
'%UNICODE = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "ClipView"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Simple Clipboard Viewer (Text Only)"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndNextViewer AS DWORD
LOCAL hGlobal AS DWORD
LOCAL hdc AS DWORD
LOCAL pGlobal AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
hwndNextViewer = SetClipboardViewer(hwnd)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_CHANGECBCHAIN
IF wParam = hwndNextViewer THEN
hwndNextViewer = lParam
ELSEIF hwndNextViewer THEN
SendMessage hwndNextViewer, uMsg, wParam, lParam
END IF
EXIT FUNCTION
CASE %WM_DRAWCLIPBOARD
IF hwndNextViewer THEN
SendMessage hwndNextViewer, uMsg, wParam, lParam
END IF
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
OpenClipboard hwnd
#IF %DEF(%UNICODE)
hGlobal = GetClipboardData(%CF_UNICODETEXT)
#ELSE
hGlobal = GetClipboardData(%CF_TEXT)
#ENDIF
IF hGlobal THEN
pGlobal = GlobalLock(hGlobal)
DrawText hdc, BYVAL pGlobal, -1, rc, %DT_EXPANDTABS
GlobalUnlock hGlobal
END IF
CloseClipboard
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
ChangeClipboardChain hwnd, hwndNextViewer
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of CLOCK.C -- Analog Clock Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
An analog clock program needn't concern itself with internationalization, but the complexity of the graphics more than make up for that simplification. To get it right, you'll need to know some trigonometry.
' ========================================================================================
' CLOCK.BAS
' This program is a translation/adaptation of CLOCK.C -- Analog Clock Program © Charles Petzold,
' 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
' An analog clock program needn't concern itself with internationalization, but the
' complexity of the graphics more than make up for that simplification. To get it right,
' you'll need to know some trigonometry.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Clock"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Analog Clock"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB SetIsotropic (BYVAL hdc AS DWORD, BYVAL cxClient AS LONG, BYVAL cyClient AS LONG)
SetMapMode hdc, %MM_ISOTROPIC
SetWindowExtEx hdc, 1000, 1000, BYVAL %NULL
SetViewportExtEx hdc, cxClient / 2, -cyClient / 2, BYVAL %NULL
SetViewportOrgEx hdc, cxClient / 2, cyClient / 2, BYVAL %NULL
END SUB
' ========================================================================================
' ========================================================================================
SUB RotatePoint (pt() AS POINT, BYVAL iNum AS LONG, BYVAL iAngle AS LONG)
LOCAL i AS LONG
LOCAL ptTemp AS POINT
LOCAL TWOPI AS DOUBLE
TWOPI = 2 * 3.14159#
FOR i = 0 TO iNum - 1
ptTemp.x = (pt(i).x * COS(TWOPI * iAngle / 360) + _
pt(i).y * SIN(TWOPI * iAngle / 360))
ptTemp.y = (pt(i).y * COS(TWOPI * iAngle / 360) - _
pt(i).x * SIN(TWOPI * iAngle / 360))
pt(i) = ptTemp
NEXT
END SUB
' ========================================================================================
' ========================================================================================
SUB DrawClock (BYVAL hdc AS DWORD)
LOCAL iAngle AS LONG
DIM pt(0 TO 3) AS POINT
FOR iAngle = 0 TO 359 STEP 6
pt(0).x = 0
pt(0).y = 900
RotatePoint (pt(), 1, iAngle)
IF iAngle MOD 5 <> 0 THEN
pt(2).x = 33
ELSE
pt(2).x = 100
END IF
pt(2).y = pt(2).x
pt(0).x = pt(0).x - pt(2).x / 2
pt(0).y = pt(0).y - pt(2).y / 2
pt(1).x = pt(0).x + pt(2).x
pt(1).y = pt(0).y + pt(2).y
SelectObject hdc, GetStockObject(%BLACK_BRUSH)
Ellipse hdc, pt(0).x, pt(0).y, pt(1).x, pt(1).y
NEXT
END SUB
' ========================================================================================
' ========================================================================================
SUB DrawHands (BYVAL hdc AS DWORD, pst AS SYSTEMTIME, BYVAL fChange AS LONG)
DIM pt(0 TO 2, 0 TO 4) AS STATIC POINT
STATIC flag AS LONG
LOCAL i AS LONG
LOCAL x AS LONG
LOCAL start AS LONG
DIM iAngle(0 TO 2) AS LONG
DIM ptTemp(0 TO 2, 0 TO 4) AS POINT
DIM ptVector(0 TO 4) AS POINT
IF ISFALSE flag THEN
pt(0, 0).x = 0 : pt(0, 0).y = -150
pt(0, 1).x = 100 : pt(0, 1).y = 0
pt(0, 2).x = 0 : pt(0, 2).y = 600
pt(0, 3).x = -100 : pt(0, 3).y = 0
pt(0, 4).x = 0 : pt(0, 4).y = -150
pt(1, 0).x = 0 : pt(1, 0).y = -200
pt(1, 1).x = 50 : pt(1, 1).y = 0
pt(1, 2).x = 0 : pt(1, 2).y = 800
pt(1, 3).x = -50 : pt(1, 3).y = 0
pt(1, 4).x = 0 : pt(1, 4).y = -200
pt(2, 0).x = 0 : pt(2, 0).y = 0
pt(2, 1).x = 0 : pt(2, 1).y = 0
pt(2, 2).x = 0 : pt(2, 2).y = 0
pt(2, 3).x = 0 : pt(2, 3).y = 0
pt(2, 4).x = 0 : pt(2, 4).y = 800
flag = %TRUE
END IF
iAngle(0) = (pst.wHour * 30) MOD 360 + pst.wMinute / 2
iAngle(1) = pst.wMinute * 6
iAngle(2) = pst.wSecond * 6
CopyMemory VARPTR(ptTemp(0)), VARPTR(pt(0)), ARRAYATTR(pt(), 4) * SIZEOF(POINT)
IF ISFALSE fChange THEN start = 2
FOR i = start TO 2
FOR x = 0 TO 4
ptVector(x) = ptTemp(i, x)
NEXT
RotatePoint ptVector(), 5, iAngle(i)
Polyline hdc, ptVector(0), 5
NEXT
SelectObject hdc, GetStockObject(%WHITE_BRUSH)
Ellipse hdc, -30, -30, 30, 30
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC stPrevious AS SYSTEMTIME
LOCAL fChange AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL st AS SYSTEMTIME
SELECT CASE uMsg
CASE %WM_CREATE
SetTimer hwnd, %ID_TIMER, 1000, %NULL
GetLocalTime st
stPrevious = st
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_TIMER
GetLocalTime st
IF st.wHour <> stPrevious.wHour OR st.wMinute <> stPrevious.wMinute THEN fChange = %TRUE
hdc = GetDC(hwnd)
SetIsotropic hdc, cxClient, cyClient
SelectObject hdc, GetStockObject(%WHITE_PEN)
DrawHands hdc, stPrevious, fChange
SelectObject hdc, GetStockObject(%BLACK_PEN)
DrawHands hdc, st, %TRUE
ReleaseDC hwnd, hdc
stPrevious = st
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetIsotropic hdc, cxClient, cyClient
DrawClock hdc
DrawHands hdc, stPrevious, %TRUE
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
KillTimer hwnd, %ID_TIMER
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the CLOVER.C-Clover Drawing Program Using Regions © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Forms a region out of four ellipses, selects this region into the device context, and then draws a series of lines emanating from the center of the window's client area. The lines appear only in the area defined by the region.
' ========================================================================================
' CLOVER.BAS
' This program is a translation/adaptation of the CLOVER.C-Clover Drawing Program Using Regions
' © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming
' Windows, 5th Edition.
' Forms a region out of four ellipses, selects this region into the device context, and
' then draws a series of lines emanating from the center of the window's client area. The
' lines appear only in the area defined by the region.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Clover"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Draw a Clover"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hRgnClip AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fAngle AS DOUBLE
LOCAL fRadius AS DOUBLE
LOCAL hCursor AS DWORD
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL ps AS PAINTSTRUCT
DIM hRgnTemp(5) AS DWORD
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
hCursor = SetCursor(LoadCursor(%NULL, BYVAL %IDC_WAIT))
ShowCursor %TRUE
IF hRgnClip THEN DeleteObject hRgnClip
hRgnTemp(0) = CreateEllipticRgn (0, cyClient / 3, cxClient / 2, 2 * cyClient / 3)
hRgnTemp(1) = CreateEllipticRgn (cxClient / 2, cyClient / 3, cxClient, 2 * cyClient / 3)
hRgnTemp(2) = CreateEllipticRgn (cxClient / 3, 0, 2 * cxClient / 3, cyClient / 2)
hRgnTemp(3) = CreateEllipticRgn (cxClient / 3, cyClient / 2, 2 * cxClient / 3, cyClient)
hRgnTemp(4) = CreateRectRgn (0, 0, 1, 1)
hRgnTemp(5) = CreateRectRgn (0, 0, 1, 1)
hRgnClip = CreateRectRgn (0, 0, 1, 1)
CombineRgn (hRgnTemp(4), hRgnTemp(0), hRgnTemp(1), %RGN_OR)
CombineRgn (hRgnTemp(5), hRgnTemp(2), hRgnTemp(3), %RGN_OR)
CombineRgn (hRgnClip, hRgnTemp(4), hRgnTemp(5), %RGN_XOR)
FOR i = 0 TO 5
DeleteObject hRgnTemp(i)
NEXT
SetCursor hCursor
ShowCursor %FALSE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetViewportOrgEx hdc, cxClient / 2, cyClient / 2, BYVAL %NULL
SelectClipRgn hdc, hRgnClip
fRadius = SQR((CEXT(cxClient)/2.0)^2 + (CEXT(cyClient)/2.0)^2)
FOR i = 0 TO 359
fAngle = CEXT(i) * (2.0 * 3.14159) / 360
MoveToEx hdc, 0, 0, BYVAL %NULL
LineTo hdc, INT(fRadius * COS(fAngle) + 0.5), INT(-fRadius * SIN(fAngle) + 0.5)
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hRgnClip
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of COLORS1.C -- Colors Using Scroll Bars © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.
COLORS1 puts its children to work. The program uses 10 child window controls: 3 scroll bars, 6 windows of static text, and 1 static rectangle. COLORS1 traps %WM_CTLCOLORSCROLLBAR messages to color the interior sections of the three scroll bars red, green, and blue and traps WM_CTLCOLORSTATIC messages to color the static text.
You can scroll the scroll bars using either the mouse or the keyboard. You can use COLORS1 as a development tool in experimenting with color and choosing attractive (or, if you prefer, ugly) colors for your own Windows programs.
' ========================================================================================
' COLORS1.BAS
' This program is a translation/adaptation of COLORS1.C -- Colors Using Scroll Bars
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' COLORS1 puts its children to work. The program uses 10 child window controls: 3 scroll
' bars, 6 windows of static text, and 1 static rectangle. COLORS1 traps
' %WM_CTLCOLORSCROLLBAR messages to color the interior sections of the three scroll bars
' red, green, and blue and traps WM_CTLCOLORSTATIC messages to color the static text.
' You can scroll the scroll bars using either the mouse or the keyboard. You can use
' COLORS1 as a development tool in experimenting with color and choosing attractive (or,
' if you prefer, ugly) colors for your own Windows programs.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
GLOBAL idFocus AS LONG
GLOBAL OldScroll() AS DWORD
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Colors1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Color Scroll"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM crPrim(0 TO 2) AS STATIC DWORD
DIM hBrush(0 TO 2) AS STATIC DWORD
STATIC hBrushStatic AS DWORD
DIM hwndScroll(0 TO 2) AS STATIC DWORD
DIM hwndLabel(0 TO 2) AS STATIC DWORD
DIM hwndValue(0 TO 2) AS STATIC DWORD
STATIC hwndRect AS DWORD
DIM iColor(0 TO 2) AS STATIC LONG
STATIC cyChar AS LONG
STATIC rcColor AS RECT
DIM szColorLabel(0 TO 2) AS STATIC ASCIIZ * 6
LOCAL hInstance AS DWORD
LOCAL i AS LONG
LOCAL cxClient AS LONG
LOCAL cyClient AS LONG
LOCAL szBuffer AS ASCIIZ * 10
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_CREATE
' Initialize variables
hInstance = GetWindowLong(hwnd, %GWL_HINSTANCE)
REDIM OldScroll(2)
crPrim(0) = RGB(255, 0, 0)
crPrim(1) = RGB(0, 255, 0)
crPrim(2) = RGB(0, 0, 255)
szColorLabel(0) = "Red"
szColorLabel(1) = "Green"
szColorLabel(2) = "Blue"
' Create the white-rectangle window against which the
' scroll bars will be positioned. The child window ID is 9.
hwndRect = CreateWindowEx(0, "static", BYVAL %NULL, _
%WS_CHILD OR %WS_VISIBLE OR %SS_WHITERECT, _
0, 0, 0, 0, _
hwnd, 9, hInstance, BYVAL %NULL)
FOR i = 0 TO 2
' The three scroll bars have IDs 0, 1, and 2, with
' scroll bar ranges from 0 through 255.
hwndScroll(i) = CreateWindowEx(0, "scrollbar", BYVAL %NULL, _
%WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %SBS_VERT, _
0, 0, 0, 0, hwnd, i, hInstance, BYVAL %NULL)
SetScrollRange hwndScroll(i), %SB_CTL, 0, 255, %FALSE
SetScrollPos hwndScroll(i), %SB_CTL, 0, %FALSE
' The three color-name labels have IDs 3, 4, and 5,
' and text strings "Red", "Green", and "Blue".
hwndLabel(i) = CreateWindowEx(0, "static", szColorLabel(i), _
%WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, _
0, 0, 0, 0, hwnd, i + 3, hInstance, BYVAL %NULL)
' The three color-value text fields have IDs 6, 7,
' and 8, and initial text strings of "0".
hwndValue(i) = CreateWindowEx(0, "static", "0", _
%WS_CHILD OR %WS_VISIBLE OR %SS_CENTER, _
0, 0, 0, 0, hwnd, i + 6, hInstance, BYVAL %NULL)
OldScroll(i) = SetWindowLong (hwndScroll(i), _
%GWL_WNDPROC, CODEPTR(ScrollProc))
hBrush(i) = CreateSolidBrush (crPrim(i))
NEXT
hBrushStatic = CreateSolidBrush (GetSysColor(%COLOR_BTNHIGHLIGHT))
cyChar = HI(WORD, GetDialogBaseUnits())
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
SetRect rcColor, cxClient / 2, 0, cxClient, cyClient
MoveWindow hwndRect, 0, 0, cxClient / 2, cyClient, %TRUE
FOR i = 0 TO 2
MoveWindow (hwndScroll(i), _
(2 * i + 1) * cxClient / 14, 2 * cyChar, _
cxClient / 14, cyClient - 4 * cyChar, %TRUE)
MoveWindow (hwndLabel(i), _
(4 * i + 1) * cxClient / 28, cyChar / 2, _
cxClient / 7, cyChar, %TRUE)
MoveWindow (hwndValue(i), _
(4 * i + 1) * cxClient / 28, _
cyClient - 3 * cyChar / 2, _
cxClient / 7, cyChar, %TRUE)
NEXT
SetFocus hwnd
EXIT FUNCTION
CASE %WM_SETFOCUS
SetFocus(hwndScroll(idFocus))
EXIT FUNCTION
CASE %WM_VSCROLL
i = GetWindowLong(lParam, %GWL_ID)
SELECT CASE LOWRD(wParam)
CASE %SB_PAGEDOWN
iColor(i) = iColor(i) + 15
iColor(i) = MIN&(255, iColor(i) + 1)
CASE %SB_LINEDOWN
iColor(i) = MIN&(255, iColor(i) + 1)
CASE %SB_PAGEUP
iColor(i) = iColor(i) - 15
iColor(i) = MAX&(0, iColor(i) - 1)
CASE %SB_LINEUP
iColor(i) = MAX&(0, iColor(i) - 1)
CASE %SB_TOP
iColor(i) = 0
CASE %SB_BOTTOM
iColor(i) = 255
CASE %SB_THUMBPOSITION, %SB_THUMBTRACK
iColor(i) = HIWRD(wParam)
END SELECT
SetScrollPos hwndScroll(i), %SB_CTL, iColor(i), %TRUE
wsprintf szBuffer, "%i", BYVAL iColor(i)
SetWindowText hwndValue(i), szBuffer
DeleteObject SetClassLong(hwnd, %GCL_HBRBACKGROUND, CreateSolidBrush(RGB(iColor(0), iColor(1), iColor(2))))
InvalidateRect hwnd, rcColor, %TRUE
EXIT FUNCTION
CASE %WM_CTLCOLORSCROLLBAR
i = GetWindowLong(lParam, %GWL_ID)
FUNCTION = hBrush(i)
EXIT FUNCTION
CASE %WM_CTLCOLORSTATIC
i = GetWindowLong(lParam, %GWL_ID)
IF i >= 3 AND i <= 8 THEN ' static text controls
SetTextColor wParam, crPrim(i MOD 3)
SetBkColor wParam, GetSysColor(%COLOR_BTNHIGHLIGHT)
FUNCTION = hBrushStatic
EXIT FUNCTION
END IF
CASE %WM_SYSCOLORCHANGE
DeleteObject hBrushStatic
hBrushStatic = CreateSolidBrush(GetSysColor(%COLOR_BTNHIGHLIGHT))
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject SetClassLong(hwnd, %GCL_HBRBACKGROUND, GetStockObject(%WHITE_BRUSH))
FOR i = 0 TO 2
DeleteObject hBrush(i)
NEXT
DeleteObject hBrushStatic
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ScrollProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL id AS LONG
id = GetWindowLong(hwnd, %GWL_ID)
SELECT CASE uMsg
CASE %WM_KEYDOWN
IF wParam = %VK_TAB THEN
SetFocus (GetDlgItem(GetParent(hwnd), (id + IIF&(GetKeyState(%VK_SHIFT) < 0, 2, 1)) MOD 3))
END IF
CASE %WM_SETFOCUS
idFocus = id
END SELECT
FUNCTION = CallWindowProc(OldScroll(id), hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of COLORS2.C -- Version using Modeless Dialog Box © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
Converting COLORS1 to use a modeless dialog box makes the program-and particularly its WndProc function-almost ridiculously simple.
Although the original COLORS1 program displayed scroll bars that were based on the size of the window, the new version keeps them at a constant size within the modeless dialog box.
' ========================================================================================
' COLORS2.BAS
' This program is a translation/adaptation of COLORS2.C -- Version using Modeless Dialog Box
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Converting COLORS1 to use a modeless dialog box makes the program-and particularly its
' WndProc function-almost ridiculously simple.
' Although the original COLORS1 program displayed scroll bars that were based on the size
' of the window, the new version keeps them at a constant size within the modeless dialog
' box.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "colors2.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
LOCAL hDlgModeless AS DWORD
szAppName = "Colors2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = CreateSolidBrush(0)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Color Scroll"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hDlgModeless = CreateDialog(hInstance, "ColorScrDlg", hwnd, CODEPTR(ColorScrDlg))
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_DESTROY
DeleteObject SetClassLong(hwnd, %GCL_HBRBACKGROUND, GetStockObject(%WHITE_BRUSH))
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ColorScrDlg (BYVAL hDlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM iColor(0 TO 2) AS STATIC LONG
LOCAL hwndParent AS DWORD
LOCAL hCtrl AS DWORD
LOCAL iCtrlID AS LONG
LOCAL iIndex AS LONG
SELECT CASE uMsg
CASE %WM_INITDIALOG
FOR iCtrlID = 10 TO 12
hCtrl = GetDlgItem(hDlg, iCtrlID)
SetScrollRange hCtrl, %SB_CTL, 0, 255, %FALSE
SetScrollPos hCtrl, %SB_CTL, 0, %FALSE
NEXT
FUNCTION = %TRUE
CASE %WM_VSCROLL
hCtrl = lParam
iCtrlID = GetWindowLong(hCtrl, %GWL_ID)
iIndex = iCtrlID - 10
hwndParent = GetParent(hDlg)
SELECT CASE LO(WORD, wParam)
CASE %SB_PAGEDOWN
iColor(iIndex) = iColor(iIndex) + 15
iColor(iIndex) = MIN&(255, iColor(iIndex) + 1)
CASE %SB_LINEDOWN
iColor(iIndex) = MIN&(255, iColor(iIndex) + 1)
CASE %SB_PAGEUP
iColor(iIndex) = iColor(iIndex) - 15
iColor(iIndex) = MAX&(0, iColor(iIndex) - 1)
CASE %SB_LINEUP
iColor(iIndex) = MAX&(0, iColor(iIndex) - 1)
CASE %SB_TOP
iColor(iIndex) = 0
CASE %SB_BOTTOM
iColor(iIndex) = 255
CASE %SB_THUMBPOSITION, %SB_THUMBTRACK
iColor(iIndex) = HIWRD(wParam)
CASE ELSE
FUNCTION = %FALSE
END SELECT
SetScrollPos hCtrl, %SB_CTL, iColor(iIndex), %TRUE
SetDlgItemInt hDlg, iCtrlID + 3, iColor(iIndex), %FALSE
DeleteObject SetClassLong(hwndParent, %GCL_HBRBACKGROUND, CreateSolidBrush(RGB(iColor(0), iColor(1), iColor(2))))
InvalidateRect hwndParent, BYVAL %NULL, %TRUE
FUNCTION = %TRUE
CASE ELSE
FUNCTION = %FALSE
END SELECT
END FUNCTION
' ========================================================================================
This program is a translation of COLORS3.C -- Version using Common Dialog Box © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
Displays the ChooseColor common dialog box. Color selection is similar to that in COLORS1 and COLORS2, but it's somewhat more interactive.
' ========================================================================================
' COLORS2.BAS
' This program is a translation/adaptation of COLORS2.C -- Version using Modeless Dialog Box
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Converting COLORS1 to use a modeless dialog box makes the program-and particularly its
' WndProc function-almost ridiculously simple.
' Although the original COLORS1 program displayed scroll bars that were based on the size
' of the window, the new version keeps them at a constant size within the modeless dialog
' box.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "colors2.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
LOCAL hDlgModeless AS DWORD
szAppName = "Colors2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = CreateSolidBrush(0)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Color Scroll"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hDlgModeless = CreateDialog(hInstance, "ColorScrDlg", hwnd, CODEPTR(ColorScrDlg))
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_DESTROY
DeleteObject SetClassLong(hwnd, %GCL_HBRBACKGROUND, GetStockObject(%WHITE_BRUSH))
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ColorScrDlg (BYVAL hDlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM iColor(0 TO 2) AS STATIC LONG
LOCAL hwndParent AS DWORD
LOCAL hCtrl AS DWORD
LOCAL iCtrlID AS LONG
LOCAL iIndex AS LONG
SELECT CASE uMsg
CASE %WM_INITDIALOG
FOR iCtrlID = 10 TO 12
hCtrl = GetDlgItem(hDlg, iCtrlID)
SetScrollRange hCtrl, %SB_CTL, 0, 255, %FALSE
SetScrollPos hCtrl, %SB_CTL, 0, %FALSE
NEXT
FUNCTION = %TRUE
CASE %WM_VSCROLL
hCtrl = lParam
iCtrlID = GetWindowLong(hCtrl, %GWL_ID)
iIndex = iCtrlID - 10
hwndParent = GetParent(hDlg)
SELECT CASE LO(WORD, wParam)
CASE %SB_PAGEDOWN
iColor(iIndex) = iColor(iIndex) + 15
iColor(iIndex) = MIN&(255, iColor(iIndex) + 1)
CASE %SB_LINEDOWN
iColor(iIndex) = MIN&(255, iColor(iIndex) + 1)
CASE %SB_PAGEUP
iColor(iIndex) = iColor(iIndex) - 15
iColor(iIndex) = MAX&(0, iColor(iIndex) - 1)
CASE %SB_LINEUP
iColor(iIndex) = MAX&(0, iColor(iIndex) - 1)
CASE %SB_TOP
iColor(iIndex) = 0
CASE %SB_BOTTOM
iColor(iIndex) = 255
CASE %SB_THUMBPOSITION, %SB_THUMBTRACK
iColor(iIndex) = HIWRD(wParam)
CASE ELSE
FUNCTION = %FALSE
END SELECT
SetScrollPos hCtrl, %SB_CTL, iColor(iIndex), %TRUE
SetDlgItemInt hDlg, iCtrlID + 3, iColor(iIndex), %FALSE
DeleteObject SetClassLong(hwndParent, %GCL_HBRBACKGROUND, CreateSolidBrush(RGB(iColor(0), iColor(1), iColor(2))))
InvalidateRect hwndParent, BYVAL %NULL, %TRUE
FUNCTION = %TRUE
CASE ELSE
FUNCTION = %FALSE
END SELECT
END FUNCTION
' ========================================================================================
This program is a translation of the CONNECT.C -- Connect-the-Dots Mouse Demo Program © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming Windows, 5th Edition.
Does some simple mouse processing to let you get a good feel for how Windows sends mouse messages to your program.
CONNECT processes three mouse messages:
%WM_LBUTTONDOWN CONNECT clears the client area.
%WM_MOUSEMOVE If the left button is down, CONNECT draws a black dot on the client area at the mouse position and saves the coordinates.
%WM_LBUTTONUP CONNECT connects every dot shown in the client area to every other dot. Sometimes this results in a pretty design, sometimes in a dense blob.
To use CONNECT, bring the mouse cursor into the client area, press the left button, move the mouse around a little, and then release the left button. CONNECT works best for a curved pattern of a few dots, which you can draw by moving the mouse quickly while the left button is depressed.
' ========================================================================================
' CONNECT.BAS
' This program is a translation/adaptation of the CONNECT.C -- Connect-the-Dots Mouse Demo
' Program © Charles Petzold, 1998, described and analysed in Chapter 7 of the book Programming
' Windows, 5th Edition.
' Does some simple mouse processing to let you get a good feel for how Windows sends mouse
' messages to your program.
'CONNECT processes three mouse messages:
' * %WM_LBUTTONDOWN CONNECT clears the client area.
' * %WM_MOUSEMOVE If the left button is down, CONNECT draws a black dot on the client area
' at the mouse position and saves the coordinates.
' * %WM_LBUTTONUP CONNECT connects every dot shown in the client area to every other dot.
' Sometimes this results in a pretty design, sometimes in a dense blob.
' To use CONNECT, bring the mouse cursor into the client area, press the left button, move
' the mouse around a little, and then release the left button. CONNECT works best for a
' curved pattern of a few dots, which you can draw by moving the mouse quickly while the
' left button is depressed.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%MAXPOINTS = 1000
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Connect"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Connect-the-Points Mouse Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC iCount AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL j AS LONG
LOCAL ps AS PAINTSTRUCT
DIM pt(%MAXPOINTS) AS STATIC POINT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_LBUTTONDOWN
iCount = 0
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_MOUSEMOVE
IF (wParam AND %MK_LBUTTON) AND (iCount < %MAXPOINTS) THEN
pt(iCount).x = LO(WORD, lParam)
pt(iCount).y = HI(WORD, lParam)
iCount = iCount + 1
hdc = GetDC(hwnd)
SetPixel hdc, LOWRD(lParam), HIWRD(lParam), 0
ReleaseDC hwnd, hdc
END IF
EXIT FUNCTION
CASE %WM_LBUTTONUP
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
FOR i = 0 TO iCount - 2
FOR j = i + 1 TO iCount - 1
MoveToEx hdc, pt(i).x, pt(i).y, BYVAL %NULL
LineTo hdc, pt(j).x, pt(j).y
NEXT
NEXT
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
his program is a translation of the DEVCAPS1.C-Device Capabilities Display Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Displays some (but not all) of the information available from the GetDeviceCaps function using a device context for the video display.
' ========================================================================================
' DEVCAPS1.BAS
' This program is a translation/adaptation of the DEVCAPS1.C-Device Capabilities Display
' Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Displays some (but not all) of the information available from the GetDeviceCaps function
' using a device context for the video display.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' DEVCAPS_STRUCT
' ========================================================================================
TYPE DEVCAPS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 13
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "DevCaps1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Device Capabilities"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL szBuffer AS ASCIIZ * 10
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
DIM devcaps(19) AS STATIC DEVCAPS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
devcaps( 0).iIndex = %HORZSIZE : devcaps( 0).szLabel = "HORZSIZE" : devcaps( 0).szDesc = "Width in millimeters:"
devcaps( 1).iIndex = %VERTSIZE : devcaps( 1).szLabel = "VERTSIZE" : devcaps( 1).szDesc = "Height in millimeters:"
devcaps( 2).iIndex = %HORZRES : devcaps( 2).szLabel = "HORZRES" : devcaps( 2).szDesc = "Width in pixels:"
devcaps( 3).iIndex = %VERTRES : devcaps( 3).szLabel = "VERTRES" : devcaps( 3).szDesc = "Height in raster lines:"
devcaps( 4).iIndex = %BITSPIXEL : devcaps( 4).szLabel = "BITSPIXEL" : devcaps( 4).szDesc = "Color bits per pixel:"
devcaps( 5).iIndex = %PLANES : devcaps( 5).szLabel = "PLANES" : devcaps( 5).szDesc = "Number of color planes:"
devcaps( 6).iIndex = %NUMBRUSHES : devcaps( 6).szLabel = "NUMBRUSHES" : devcaps( 6).szDesc = "Number of device brushes:"
devcaps( 7).iIndex = %NUMPENS : devcaps( 7).szLabel = "NUMPENS" : devcaps( 7).szDesc = "Number of device pens:"
devcaps( 8).iIndex = %NUMMARKERS : devcaps( 8).szLabel = "NUMMARKERS" : devcaps( 8).szDesc = "Number of device markers:"
devcaps( 9).iIndex = %NUMFONTS : devcaps( 9).szLabel = "NUMFONTS" : devcaps( 9).szDesc = "Number of device fonts:"
devcaps(10).iIndex = %NUMCOLORS : devcaps(10).szLabel = "NUMCOLORS" : devcaps(10).szDesc = "Number of device colors:"
devcaps(11).iIndex = %PDEVICESIZE : devcaps(11).szLabel = "PDEVICESIZE" : devcaps(11).szDesc = "Size of device structure:"
devcaps(12).iIndex = %ASPECTX : devcaps(12).szLabel = "ASPECTX" : devcaps(12).szDesc = "Relative width of pixel:"
devcaps(13).iIndex = %ASPECTY : devcaps(13).szLabel = "ASPECTY" : devcaps(13).szDesc = "Cursor width"
devcaps(14).iIndex = %ASPECTXY : devcaps(14).szLabel = "ASPECTXY" : devcaps(14).szDesc = "Relative diagonal of pixel:"
devcaps(15).iIndex = %LOGPIXELSX : devcaps(15).szLabel = "LOGPIXELSX" : devcaps(15).szDesc = "Horizontal dots per inch:"
devcaps(16).iIndex = %LOGPIXELSY : devcaps(16).szLabel = "LOGPIXELSY" : devcaps(16).szDesc = "Vertical dots per inch:"
devcaps(17).iIndex = %SIZEPALETTE : devcaps(17).szLabel = "SIZEPALETTE" : devcaps(17).szDesc = "Number of palette entries:"
devcaps(18).iIndex = %NUMRESERVED : devcaps(18).szLabel = "NUMRESERVED" : devcaps(18).szDesc = "Reserved palette entries:"
devcaps(19).iIndex = %COLORRES : devcaps(19).szLabel = "COLORRES" : devcaps(19).szDesc = "Actual color resolution:"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 / 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR i = LBOUND(devcaps) TO UBOUND(devcaps)
TextOut hdc, 0, cyChar * i, devcaps(i).szLabel, LEN(devcaps(i).szLabel)
TextOut hdc, 14 * cxCaps, cyChar * i, devcaps(i).szDesc, LEN(devcaps(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetDeviceCaps(hdc, devcaps(i).iIndex))
TextOut hdc, 14 * cxCaps + 35 * cxChar, cyChar * i, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of DEVCAPS2.C -- Displays Device Capability Information (Version 2) © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.
The original DEVCAPS1 program in Chapter 5 displayed basic information available from the GetDeviceCaps function for the video display. The new version shows more information for both the video display and all printers attached to the system.
' ========================================================================================
' DEVCAPS2.BAS
' This program is a translation/adaptation of DEVCAPS2.C -- Displays Device Capability
' Information (Version 2) © Charles Petzold, 1998, described and analysed in Chapter 13
' of the book Programming Windows, 5th Edition.
' The original DEVCAPS1 program in Chapter 5 displayed basic information available from
' the GetDeviceCaps function for the video display. The new version shows more information
' for both the video display and all printers attached to the system.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "devcaps2.res"
TYPE BITS_STRUCT
iMask AS LONG
szDesc AS ASCIIZ * 256
END TYPE
TYPE DEVCAPS2_INFO_STRUCT
nIndex AS LONG
szDesc AS ASCIIZ * 256
END TYPE
TYPE BITINFO_STRUCT
iIndex AS LONG
szTitle AS ASCIIZ * 256
pbits AS BITS_STRUCT PTR
iSize AS LONG
END TYPE
%IDM_DEVMODE = 1000
%IDM_SCREEN = 40001
%IDM_BASIC = 40002
%IDM_OTHER = 40003
%IDM_CURVE = 40004
%IDM_LINE = 40005
%IDM_POLY = 40006
%IDM_TEXT = 40007
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "DevCaps2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Device Capabilities"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DoBasicInfo (BYVAL hdc AS DWORD, BYVAL hdcInfo AS DWORD, BYVAL cxChar AS LONG, BYVAL cyChar AS LONG)
DIM info (23) AS DEVCAPS2_INFO_STRUCT
info ( 0).nIndex = %HORZSIZE : info ( 0).szDesc = "HORZSIZE Width in millimeters:"
info ( 1).nIndex = %VERTSIZE : info ( 1).szDesc = "VERTSIZE Height in millimeters:"
info ( 2).nIndex = %HORZRES : info ( 2).szDesc = "HORZRES Width in pixels:"
info ( 3).nIndex = %VERTRES : info ( 3).szDesc = "VERTRES Height in raster lines:"
info ( 4).nIndex = %BITSPIXEL : info ( 4).szDesc = "BITSPIXEL Color bits per pixel:"
info ( 5).nIndex = %PLANES : info ( 5).szDesc = "PLANES Number of color planes:"
info ( 6).nIndex = %NUMBRUSHES : info ( 6).szDesc = "NUMBRUSHES Number of device brushes:"
info ( 7).nIndex = %NUMPENS : info ( 7).szDesc = "NUMPENS Number of device pens:"
info ( 8).nIndex = %NUMMARKERS : info ( 8).szDesc = "NUMMARKERS Number of device markers:"
info ( 9).nIndex = %NUMFONTS : info ( 9).szDesc = "NUMFONTS Number of device fonts:"
info (10).nIndex = %NUMCOLORS : info (10).szDesc = "NUMCOLORS Number of device colors:"
info (11).nIndex = %PDEVICESIZE : info (11).szDesc = "PDEVICESIZE Size of device structure:"
info (12).nIndex = %ASPECTX : info (12).szDesc = "ASPECTX Relative width of pixel:"
info (13).nIndex = %ASPECTY : info (13).szDesc = "ASPECTY Relative width of pixel:"
info (14).nIndex = %ASPECTXY : info (14).szDesc = "ASPECTXY Relative diagonal of pixel:"
info (15).nIndex = %LOGPIXELSX : info (15).szDesc = "LOGPIXELSX Horizontal dots per inch:"
info (16).nIndex = %LOGPIXELSY : info (16).szDesc = "LOGPIXELSY Veertical dots per inch:"
info (17).nIndex = %SIZEPALETTE : info (17).szDesc = "SIZEPALETTE Number of palette entries:"
info (18).nIndex = %NUMRESERVED : info (18).szDesc = "NUMRESERVED Reserved palette entries:"
info (19).nIndex = %COLORRES : info (19).szDesc = "COLORRES Actual color resolution:"
info (20).nIndex = %PHYSICALWIDTH : info (20).szDesc = "PHYSICALWIDTH Printer page pixel width:"
info (21).nIndex = %PHYSICALHEIGHT : info (21).szDesc = "PHYSICALHEIGHT Printer page pixel height:"
info (22).nIndex = %PHYSICALOFFSETX : info (22).szDesc = "PHYSICALOFFSETX Printer page x offset:"
info (23).nIndex = %PHYSICALOFFSETY : info (23).szDesc = "PHYSICALOFFSETY Printer page y offset:"
LOCAL i AS LONG
LOCAL szBuffer AS ASCIIZ * 80
FOR i = 0 TO 23
wsprintf szBuffer, "%-45s%8d", info(i).szDesc, _
BYVAL GetDeviceCaps(hdcInfo, info(i).nIndex)
TextOut hdc, cxChar, (i + 1) * cyChar, szBuffer, LEN(szBuffer)
NEXT
END SUB
' ========================================================================================
' ========================================================================================
SUB DoOtherInfo (BYVAL hdc AS DWORD, BYVAL hdcInfo AS DWORD, BYVAL cxChar AS LONG, BYVAL cyChar AS LONG)
LOCAL clip AS BITS_STRUCT
clip.iMask = %CP_RECTANGLE : clip.szDesc = "CP_RECTANGLE Can Clip To Rectangle"
DIM raster(11) AS BITS_STRUCT
raster( 0).iMask = %RC_BITBLT : raster( 0).szDesc = "RC_BITBLT Capable of simple BitBlt:"
raster( 1).iMask = %RC_BANDING : raster( 1).szDesc = "RC_BANDING Requires banding support:"
raster( 2).iMask = %RC_SCALING : raster( 2).szDesc = "RC_SCALING Requires scaling support:"
raster( 3).iMask = %RC_BITMAP64 : raster( 3).szDesc = "RC_BITMAP64 Supports bitmaps >64K:"
raster( 4).iMask = %RC_GDI20_OUTPUT : raster( 4).szDesc = "RC_GDI20_OUTPUT Has 2.0 output calls:"
raster( 5).iMask = %RC_DI_BITMAP : raster( 5).szDesc = "RC_DI_BITMAP Supports DIB to memory:"
raster( 6).iMask = %RC_PALETTE : raster( 6).szDesc = "RC_PALETTE Supports a palette:"
raster( 7).iMask = %RC_DIBTODEV : raster( 7).szDesc = "RC_DIBTODEV Supports bitmap conversion:"
raster( 8).iMask = %RC_BIGFONT : raster( 8).szDesc = "RC_BIGFONT Supports fonts >64K:"
raster( 9).iMask = %RC_STRETCHBLT : raster( 9).szDesc = "RC_STRETCHBLT Supports StretchBlt:"
raster(10).iMask = %RC_FLOODFILL : raster(10).szDesc = "RC_FLOODFILL Supports FloodFill:"
raster(11).iMask = %RC_STRETCHDIB : raster(11).szDesc = "RC_STRETCHDIB Supports StretchDIBits:"
DIM szTech(6) AS ASCIIZ * 256
szTech(0) = "DT_PLOTTER (Vector plotter)"
szTech(1) = "DT_RASDISPLAY (Raster display)"
szTech(2) = "DT_RASPRINTER (Raster printer)"
szTech(3) = "DT_RASCAMERA (Raster camera)"
szTech(4) = "DT_CHARSTREAM (Character stream)"
szTech(5) = "DT_METAFILE (Metafile)"
szTech(6) = "DT_DISPFILE (Display file)"
LOCAL i AS LONG
LOCAL szBuffer AS ASCIIZ * 80
LOCAL szDesc AS ASCIIZ * 80
LOCAL szYesNo AS ASCIIZ * 4
szDesc = "DRIVERVERSION:"
wsprintf szBuffer, "%-24s%04XH", szDesc, _
BYVAL GetDeviceCaps(hdcInfo, %DRIVERVERSION)
TextOut hdc, cxChar, cyChar, szBuffer, LEN(szBuffer)
szDesc = "TECHNOLOGY:"
wsprintf szBuffer, "%-24s%-40s", szDesc, _
szTech(GetDeviceCaps(hdcInfo, %TECHNOLOGY))
TextOut hdc, cxChar, 2 * cyChar, szBuffer, LEN(szBuffer)
szDesc = "CLIPCAPS (Clipping capabilities)"
wsprintf szBuffer, szDesc, BYVAL %NULL
TextOut hdc, cxChar, 4 * cyChar, szBuffer, LEN(szBuffer)
szYesNo = IIF$((GetDeviceCaps(hdcInfo, %CLIPCAPS) AND clip.iMask) = clip.iMask, "Yes", "No")
wsprintf szBuffer, "%-45s %3s", clip.szDesc, szYesNo
TextOut hdc, 9 * cxChar, (i + 6) * cyChar, szBuffer, LEN(szBuffer)
szDesc = "RASTERCAPS (Raster capabilities)"
wsprintf szBuffer, szDesc, BYVAL %NULL
TextOut hdc, cxChar, 8 * cyChar, szBuffer, LEN(szBuffer)
FOR i = LBOUND(raster) TO UBOUND(raster)
szYesNo = IIF$((GetDeviceCaps(hdcInfo, %RASTERCAPS) AND raster(i).iMask) = raster(i).iMask, "Yes", "No")
wsprintf szBuffer, "%-45s %3s", raster(i).szDesc, szYesNo
TextOut hdc, 9 * cxChar, (i + 10) * cyChar, szBuffer, LEN(szBuffer)
NEXT
END SUB
' ========================================================================================
SUB DoBitCodedCaps (BYVAL hdc AS DWORD, BYVAL hdcInfo AS DWORD, BYVAL cxChar AS LONG, BYVAL cyChar AS LONG, BYVAL iType AS LONG)
DIM curves(7) AS BITS_STRUCT
curves(0).iMask = %CC_CIRCLES : curves(0).szDesc = "CC_CIRCLES Can do circles:"
curves(1).iMask = %CC_PIE : curves(1).szDesc = "CC_PIE Can do pie wedges:"
curves(2).iMask = %CC_CHORD : curves(2).szDesc = "CC_CHORD Can do chord arcs:"
curves(3).iMask = %CC_ELLIPSES : curves(3).szDesc = "CC_ELLIPSES Can do ellipses:"
curves(4).iMask = %CC_WIDE : curves(4).szDesc = "CC_WIDE Can do wide borders:"
curves(5).iMask = %CC_STYLED : curves(5).szDesc = "CC_STYLED Can do styled borders:"
curves(6).iMask = %CC_WIDESTYLED : curves(6).szDesc = "CC_WIDESTYLED Can do wide and styled borders:"
curves(7).iMask = %CC_INTERIORS : curves(7).szDesc = "CC_INTERIORS Can do interiors:"
DIM lines(6) AS BITS_STRUCT
lines(0).iMask = %LC_POLYLINE : lines(0).szDesc = "LC_POLYLINE Can do polyline:"
lines(1).iMask = %LC_MARKER : lines(1).szDesc = "LC_MARKER Can do markers:"
lines(2).iMask = %LC_POLYMARKER : lines(2).szDesc = "LC_POLYMARKER Can do polymarkers:"
lines(3).iMask = %LC_WIDE : lines(3).szDesc = "LC_WIDE Can do wide lines:"
lines(4).iMask = %LC_STYLED : lines(4).szDesc = "LC_STYLED Can do styled lines:"
lines(5).iMask = %LC_WIDESTYLED : lines(5).szDesc = "LC_WIDESTYLED Can do wide and styled lines:"
lines(6).iMask = %LC_INTERIORS : lines(6).szDesc = "LC_INTERIORS Can do interiors:"
DIM poly(7) AS BITS_STRUCT
poly(0).iMask = %PC_POLYGON : poly(0).szDesc = "PC_POLYGON Can do alternate fill polygon:"
poly(1).iMask = %PC_RECTANGLE : poly(1).szDesc = "PC_RECTANGLE Can do rectangle:"
poly(2).iMask = %PC_WINDPOLYGON : poly(2).szDesc = "PC_WINDPOLYGON Can do winding number fill polygon:"
poly(3).iMask = %PC_SCANLINE : poly(3).szDesc = "PC_SCANLINE Can do scanlines:"
poly(4).iMask = %PC_WIDE : poly(4).szDesc = "PC_WIDE Can do wide borders:"
poly(5).iMask = %PC_STYLED : poly(5).szDesc = "PC_STYLED Can do styled borders:"
poly(6).iMask = %PC_WIDESTYLED : poly(6).szDesc = "PC_WIDESTYLED Can do wide and styled borders:"
poly(7).iMask = %PC_INTERIORS : poly(7).szDesc = "PC_INTERIORS Can do interiors:"
DIM text(14) AS BITS_STRUCT
text( 0).iMask = %TC_OP_CHARACTER : text( 0).szDesc = "TC_OP_CHARACTER Can do character output precision:"
text( 1).iMask = %TC_OP_STROKE : text( 1).szDesc = "TC_OP_STROKE Can do stroke output precision:"
text( 2).iMask = %TC_CP_STROKE : text( 2).szDesc = "TC_CP_STROKE Can do stroke clip precision:"
text( 3).iMask = %TC_CR_90 : text( 3).szDesc = "TC_CP_90 Can do 90 degree character rotation:"
text( 4).iMask = %TC_CR_ANY : text( 4).szDesc = "TC_CR_ANY Can do any character rotation:"
text( 5).iMask = %TC_SF_X_YINDEP : text( 5).szDesc = "TC_SF_X_YINDEP Can do scaling independent of X and Y:"
text( 6).iMask = %TC_SA_DOUBLE : text( 6).szDesc = "TC_SA_DOUBLE Can do doubled character for scaling:"
text( 7).iMask = %TC_SA_INTEGER : text( 7).szDesc = "TC_SA_INTEGER Can do integer multiples for scaling:"
text( 8).iMask = %TC_SA_CONTIN : text( 8).szDesc = "TC_SA_CONTIN Can do any multiples for exact scaling:"
text( 9).iMask = %TC_EA_DOUBLE : text( 9).szDesc = "TC_EA_DOUBLE Can do double weight characters:"
text(10).iMask = %TC_IA_ABLE : text(10).szDesc = "TC_IA_ABLE Can do italicizing:"
text(11).iMask = %TC_UA_ABLE : text(11).szDesc = "TC_UA_ABLE Can do underlining:"
text(12).iMask = %TC_SO_ABLE : text(12).szDesc = "TC_SO_ABLE Can do strikeouts::"
text(13).iMask = %TC_RA_ABLE : text(13).szDesc = "TC_RA_ABLE Can do raster fonts:"
text(14).iMask = %TC_VA_ABLE : text(14).szDesc = "TC_VA_ABLE Can do vector fonts:"
DIM bitinfo(3) AS BITINFO_STRUCT
bitinfo(0).iIndex = %CURVECAPS
bitinfo(0).szTitle = "CURVCAPS (Curve Capabilities)"
bitinfo(0).pbits = VARPTR(curves(0))
bitinfo(0).iSize = UBOUND(curves) - LBOUND(curves) + 1
bitinfo(1).iIndex = %LINECAPS
bitinfo(1).szTitle = "LINECAPS (Line Capabilities)"
bitinfo(1).pbits = VARPTR(lines(0))
bitinfo(1).iSize = UBOUND(lines) - LBOUND(lines) + 1
bitinfo(2).iIndex = %POLYGONALCAPS
bitinfo(2).szTitle = "POLYGONALCAPS (Polygonal Capabilities)"
bitinfo(2).pbits = VARPTR(poly(0))
bitinfo(2).iSize = UBOUND(poly) - LBOUND(poly) + 1
bitinfo(3).iIndex = %TEXTCAPS
bitinfo(3).szTitle = "TEXTCAPS (Text Capabilities)"
bitinfo(3).pbits = VARPTR(text(0))
bitinfo(3).iSize = UBOUND(text) - LBOUND(text) + 1
LOCAL szBuffer AS ASCIIZ * 80
LOCAL pbits AS BITS_STRUCT PTR
LOCAL i AS LONG
LOCAL iDevCaps AS LONG
pbits = bitinfo(iType).pbits
iDevCaps = GetDeviceCaps(hdcInfo, bitinfo(iType).iIndex)
TextOut hdc, cxChar, cyChar, bitinfo(iType).szTitle, LEN(bitinfo(iType).szTitle)
LOCAL szYesNo AS ASCIIZ * 80
FOR i = 0 TO bitinfo(iType).iSize - 1
szYesNo = IIF$((iDevCaps AND @pbits[i].iMask) = @pbits[i].iMask, "Yes", "No")
wsprintf szBuffer, "%-55s %3s", @pbits[i].szDesc, szYesNo
TextOut hdc, cxChar, (i + 3) * cyChar, szBuffer, LEN(szBuffer)
NEXT
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC szDevice AS ASCIIZ * 32
STATIC szWindowText AS ASCIIZ * 64
STATIC cxChar AS LONG
STATIC cyChar AS LONG
STATIC nCurrentDevice AS LONG
STATIC nCurrentInfo AS LONG
STATIC dwNeeded AS DWORD
STATIC dwReturned AS DWORD
STATIC pinfo4 AS PRINTER_INFO_4 PTR
STATIC pinfo5 AS PRINTER_INFO_5 PTR
LOCAL i AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcInfo AS DWORD
LOCAL hMenu AS DWORD
LOCAL hPrint AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
SELECT CASE uMsg
CASE %WM_CREATE
nCurrentDevice = %IDM_SCREEN
nCurrentInfo = %IDM_BASIC
hdc = GetDC(hwnd)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
SendMessage hwnd, %WM_SETTINGCHANGE, 0, 0
EXIT FUNCTION
CASE %WM_SETTINGCHANGE
hMenu = GetSubMenu(GetMenu(hwnd), 0)
WHILE GetMenuItemCount (hMenu) > 1
DeleteMenu hMenu, 1, %MF_BYPOSITION
WEND
' Get a list of all local and remote printers
'
' First, find out how large an array we need; this
' call will fail, leaving the required size in dwNeeded
'
' Next, allocate space for the info array and fill it
'
' Put the printer names on the menu
IF (GetVersion () AND &H80000000) THEN ' // Windows 98
EnumPrinters %PRINTER_ENUM_LOCAL, BYVAL %NULL, 5, BYVAL %NULL, _
0, dwNeeded, dwReturned
pinfo5 = CoTaskMemAlloc(dwNeeded)
EnumPrinters %PRINTER_ENUM_LOCAL, BYVAL %NULL, 5, BYVAL pinfo5, _
dwNeeded, dwNeeded, dwReturned
FOR i = 0 TO dwReturned - 1
AppendMenu hMenu, IIF&((i+1) MOD 16 <> 0, 0, %MF_MENUBARBREAK), i + 1, _
@pinfo5[i].@pPrinterName
NEXT
CoTaskMemFree pinfo5
ELSE ' // Windows NT
EnumPrinters %PRINTER_ENUM_LOCAL, BYVAL %NULL, 4, BYVAL %NULL, _
0, dwNeeded, dwReturned
pinfo4 = CoTaskMemAlloc(dwNeeded)
EnumPrinters %PRINTER_ENUM_LOCAL, BYVAL %NULL, 4, BYVAL pinfo4, _
dwNeeded, dwNeeded, dwReturned
FOR i = 0 TO dwReturned - 1
AppendMenu hMenu, IIF&((i+1) MOD 16 <> 0, 0, %MF_MENUBARBREAK), i + 1, _
@pinfo4[i].@pPrinterName
NEXT
CoTaskMemFree pInfo4
END IF
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, 0, %IDM_DEVMODE, "Properties"
wParam = %IDM_SCREEN
SendMessage hwnd, %WM_COMMAND, wParam, 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
hMenu = GetMenu(hwnd)
IF LO(WORD, wParam) = %IDM_SCREEN OR _ ' IDM_SCREEN & Printers
LO(WORD, wParam) < %IDM_DEVMODE THEN
CheckMenuItem hMenu, nCurrentDevice, %MF_UNCHECKED
nCurrentDevice = LO(WORD, wParam)
CheckMenuItem hMenu, nCurrentDevice, %MF_CHECKED
ELSEIF LO(WORD, wParam) = %IDM_DEVMODE THEN ' Properties selection
GetMenuString hMenu, nCurrentDevice, szDevice, _
SIZEOF(szDevice), %MF_BYCOMMAND
IF OpenPrinter(szDevice, hPrint, BYVAL %NULL) THEN
PrinterProperties hwnd, hPrint
ClosePrinter hPrint
END IF
ELSE ' info menu items
CheckMenuItem hMenu, nCurrentInfo, %MF_UNCHECKED
nCurrentInfo = LO(WORD, wParam)
CheckMenuItem hMenu, nCurrentInfo, %MF_CHECKED
END IF
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
IF lParam = 0 THEN
EnableMenuItem GetMenu(hwnd), %IDM_DEVMODE, _
IIF&(nCurrentDevice = %IDM_SCREEN, %MF_GRAYED, %MF_ENABLED)
END IF
EXIT FUNCTION
CASE %WM_PAINT
szWindowText = "Device Capabilities: "
IF nCurrentDevice = %IDM_SCREEN THEN
szDevice = "DISPLAY"
hdcInfo = CreateIC(szDevice, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
ELSE
hMenu = GetMenu(hwnd)
GetMenuString hMenu, nCurrentDevice, szDevice, SIZEOF(szDevice), %MF_BYCOMMAND
hdcInfo = CreateIC(BYVAL %NULL, szDevice, BYVAL %NULL, BYVAL %NULL)
END IF
szWindowText = szWindowText & szDevice
SetWindowText hwnd, szWindowText
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
IF hdcInfo THEN
SELECT CASE nCurrentInfo
CASE %IDM_BASIC
DoBasicInfo hdc, hdcInfo, cxChar, cyChar
CASE %IDM_OTHER
DoOtherInfo hdc, hdcInfo, cxChar, cyChar
CASE %IDM_CURVE, %IDM_LINE, %IDM_POLY, %IDM_TEXT
DoBitCodedCaps hdc, hdcInfo, cxChar, cyChar, nCurrentInfo - %IDM_CURVE
END SELECT
DeleteDC hdcInfo
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
DEVCAPS2.RC
#define IDM_SCREEN 40001
#define IDM_BASIC 40002
#define IDM_OTHER 40003
#define IDM_CURVE 40004
#define IDM_LINE 40005
#define IDM_POLY 40006
#define IDM_TEXT 40007
/////////////////////////////////////////////////////////////////////////////
// Menu
DEVCAPS2 MENU DISCARDABLE
BEGIN
POPUP "&Device"
BEGIN
MENUITEM "&Screen", IDM_SCREEN, CHECKED
END
POPUP "&Capabilities"
BEGIN
MENUITEM "&Basic Information", IDM_BASIC
MENUITEM "&Other Information", IDM_OTHER
MENUITEM "&Curve Capabilities", IDM_CURVE
MENUITEM "&Line Capabilities", IDM_LINE
MENUITEM "&Polygonal Capabilities", IDM_POLY
MENUITEM "&Text Capabilities", IDM_TEXT
END
END
This program is a translation of DIGCLOCK.C -- Digital Clock © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Displays the current time using a simulated LED-like 7-segment display.
' ========================================================================================
' DIGCLOCK.BAS
' This program is a translation/adaptation of DIGCLOCK.C -- Digital Clock © Charles
' Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows,
' 5th Edition.
' Displays the current time using a simulated LED-like 7-segment display.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "DigClock"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Digital Clock"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DisplayDigit (BYVAL hdc AS DWORD, BYVAL iNumber AS LONG)
DIM fSevenSegment(0 TO 9, 0 TO 6) AS STATIC LONG
DIM ptSegment(0 TO 5, 0 TO 6) AS STATIC POINTAPI
STATIC flag AS LONG
LOCAL iSeg AS LONG
IF ISFALSE flag THEN
fSevenSegment(0, 0) = 1
fSevenSegment(0, 1) = 1
fSevenSegment(0, 2) = 1
fSevenSegment(0, 3) = 0
fSevenSegment(0, 4) = 1
fSevenSegment(0, 5) = 1
fSevenSegment(0, 6) = 1
fSevenSegment(1, 0) = 0
fSevenSegment(1, 1) = 0
fSevenSegment(1, 2) = 1
fSevenSegment(1, 3) = 0
fSevenSegment(1, 4) = 0
fSevenSegment(1, 5) = 1
fSevenSegment(1, 6) = 0
fSevenSegment(2, 0) = 1
fSevenSegment(2, 1) = 0
fSevenSegment(2, 2) = 1
fSevenSegment(2, 3) = 1
fSevenSegment(2, 4) = 1
fSevenSegment(2, 5) = 0
fSevenSegment(2, 6) = 1
fSevenSegment(3, 0) = 1
fSevenSegment(3, 1) = 0
fSevenSegment(3, 2) = 1
fSevenSegment(3, 3) = 1
fSevenSegment(3, 4) = 0
fSevenSegment(3, 5) = 1
fSevenSegment(3, 6) = 1
fSevenSegment(4, 0) = 0
fSevenSegment(4, 1) = 1
fSevenSegment(4, 2) = 1
fSevenSegment(4, 3) = 1
fSevenSegment(4, 4) = 0
fSevenSegment(4, 5) = 1
fSevenSegment(4, 6) = 0
fSevenSegment(5, 0) = 1
fSevenSegment(5, 1) = 1
fSevenSegment(5, 2) = 0
fSevenSegment(5, 3) = 1
fSevenSegment(5, 4) = 0
fSevenSegment(5, 5) = 1
fSevenSegment(5, 6) = 1
fSevenSegment(6, 0) = 1
fSevenSegment(6, 1) = 1
fSevenSegment(6, 2) = 0
fSevenSegment(6, 3) = 1
fSevenSegment(6, 4) = 1
fSevenSegment(6, 5) = 1
fSevenSegment(6, 6) = 1
fSevenSegment(7, 0) = 1
fSevenSegment(7, 1) = 0
fSevenSegment(7, 2) = 1
fSevenSegment(7, 3) = 0
fSevenSegment(7, 4) = 0
fSevenSegment(7, 5) = 1
fSevenSegment(7, 6) = 0
fSevenSegment(8, 0) = 1
fSevenSegment(8, 1) = 1
fSevenSegment(8, 2) = 1
fSevenSegment(8, 3) = 1
fSevenSegment(8, 4) = 1
fSevenSegment(8, 5) = 1
fSevenSegment(8, 6) = 1
fSevenSegment(9, 0) = 1
fSevenSegment(9, 1) = 1
fSevenSegment(9, 2) = 1
fSevenSegment(9, 3) = 1
fSevenSegment(9, 4) = 0
fSevenSegment(9, 5) = 1
fSevenSegment(9, 6) = 1
ptSegment(0, 0).x = 7 : ptSegment(0, 0).y = 6
ptSegment(1, 0).x = 11 : ptSegment(1, 0).y = 2
ptSegment(2, 0).x = 31 : ptSegment(2, 0).y = 2
ptSegment(3, 0).x = 35 : ptSegment(3, 0).y = 6
ptSegment(4, 0).x = 31 : ptSegment(4, 0).y = 10
ptSegment(5, 0).x = 11 : ptSegment(5, 0).y = 10
ptSegment(0, 1).x = 6 : ptSegment(0, 1).y = 7
ptSegment(1, 1).x = 10 : ptSegment(1, 1).y = 11
ptSegment(2, 1).x = 10 : ptSegment(2, 1).y = 31
ptSegment(3, 1).x = 6 : ptSegment(3, 1).y = 35
ptSegment(4, 1).x = 2 : ptSegment(4, 1).y = 31
ptSegment(5, 1).x = 2 : ptSegment(5, 1).y = 11
ptSegment(0, 2).x = 36 : ptSegment(0, 2).y = 7
ptSegment(1, 2).x = 40 : ptSegment(1, 2).y = 11
ptSegment(2, 2).x = 40 : ptSegment(2, 2).y = 31
ptSegment(3, 2).x = 36 : ptSegment(3, 2).y = 35
ptSegment(4, 2).x = 32 : ptSegment(4, 2).y = 31
ptSegment(5, 2).x = 32 : ptSegment(5, 2).y = 11
ptSegment(0, 3).x = 7 : ptSegment(0, 3).y = 36
ptSegment(1, 3).x = 11 : ptSegment(1, 3).y = 32
ptSegment(2, 3).x = 31 : ptSegment(2, 3).y = 32
ptSegment(3, 3).x = 35 : ptSegment(3, 3).y = 36
ptSegment(4, 3).x = 31 : ptSegment(4, 3).y = 40
ptSegment(5, 3).x = 11 : ptSegment(5, 3).y = 40
ptSegment(0, 4).x = 6 : ptSegment(0, 4).y = 37
ptSegment(1, 4).x = 10 : ptSegment(1, 4).y = 41
ptSegment(2, 4).x = 10 : ptSegment(2, 4).y = 61
ptSegment(3, 4).x = 6 : ptSegment(3, 4).y = 65
ptSegment(4, 4).x = 2 : ptSegment(4, 4).y = 61
ptSegment(5, 4).x = 2 : ptSegment(5, 4).y = 41
ptSegment(0, 5).x = 36 : ptSegment(0, 5).y = 37
ptSegment(1, 5).x = 40 : ptSegment(1, 5).y = 41
ptSegment(2, 5).x = 40 : ptSegment(2, 5).y = 61
ptSegment(3, 5).x = 36 : ptSegment(3, 5).y = 65
ptSegment(4, 5).x = 32 : ptSegment(4, 5).y = 61
ptSegment(5, 5).x = 32 : ptSegment(5, 5).y = 41
ptSegment(0, 6).x = 7 : ptSegment(0, 6).y = 66
ptSegment(1, 6).x = 11 : ptSegment(1, 6).y = 62
ptSegment(2, 6).x = 31 : ptSegment(2, 6).y = 62
ptSegment(3, 6).x = 35 : ptSegment(3, 6).y = 66
ptSegment(4, 6).x = 31 : ptSegment(4, 6).y = 70
ptSegment(5, 6).x = 11 : ptSegment(5, 6).y = 70
flag = %TRUE
END IF
FOR iSeg = 0 TO 6
IF fSevenSegment(iNumber, iSeg) THEN
Polygon hdc, ptSegment(0, iSeg), 6
END IF
NEXT
END SUB
' ========================================================================================
' ========================================================================================
SUB DisplayTwoDigits (BYVAL hdc AS DWORD, BYVAL iNumber AS LONG, BYVAL fSuppress AS LONG)
IF ISFALSE fSuppress OR iNumber \ 10 <> 0 THEN
DisplayDigit hdc, iNumber \ 10
END IF
OffsetWindowOrgEx hdc, -42, 0, BYVAL %NULL
DisplayDigit hdc, iNumber MOD 10
OffsetWindowOrgEx hdc, -42, 0, BYVAL %NULL
END SUB
' ========================================================================================
' ========================================================================================
SUB DisplayColon (BYVAL hdc AS DWORD)
DIM ptColon(0 TO 1, 0 TO 3) AS STATIC POINTAPI
STATIC flag AS LONG
IF ISFALSE flag THEN
ptColon(0, 0).x = 2 : ptColon(0, 0).y = 21
ptColon(0, 1).x = 6 : ptColon(0, 1).y = 17
ptColon(0, 2).x = 10 : ptColon(0, 2).y = 21
ptColon(0, 3).x = 6 : ptColon(0, 3).y = 25
flag = %TRUE
END IF
Polygon hdc, ptColon(0), 4
Polygon hdc, ptColon(1), 4
OffsetWindowOrgEx hdc, -12, 0, BYVAL %NULL
END SUB
' ========================================================================================
' ========================================================================================
SUB DisplayTime (BYVAL hdc AS DWORD, BYVAL f24Hour AS LONG, BYVAL fSuppress AS LONG)
LOCAL st AS SYSTEMTIME
GetLocalTime st
IF f24Hour THEN
DisplayTwoDigits hdc, st.wHour, fSuppress
ELSE
IF st.wHour MOD 12 = 0 THEN
DisplayTwoDigits hdc, 12, fSuppress
ELSE
DisplayTwoDigits hdc, st.wHour MOD 12, fSuppress
END IF
END IF
DisplayColon hdc
DisplayTwoDigits hdc, st.wMinute, %FALSE
DisplayColon hdc
DisplayTwoDigits hdc, st.wSecond, %FALSE
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC f24Hour AS LONG
STATIC fSuppress AS LONG
STATIC hBrushRed AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL szBuffer AS ASCIIZ * 3
SELECT CASE uMsg
CASE %WM_CREATE
hBrushRed = CreateSolidBrush(RGB (255, 0, 0))
SetTimer hwnd, %ID_TIMER, 1000, %NULL
SendMessage hwnd, %WM_SETTINGCHANGE, 0, 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SETTINGCHANGE
GetLocaleInfo %LOCALE_USER_DEFAULT, %LOCALE_ITIME, szBuffer, 2
IF LEFT$(szBuffer, 1) = "1" THEN f24Hour = %TRUE
GetLocaleInfo %LOCALE_USER_DEFAULT, %LOCALE_ITLZERO, szBuffer, 2
IF LEFT$(szBuffer, 1) = "0" THEN fSuppress = %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_TIMER
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetMapMode hdc, %MM_ISOTROPIC
SetWindowExtEx hdc, 276, 72, BYVAL %NULL
SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
SetWindowOrgEx hdc, 138, 36, BYVAL %NULL
SetViewportOrgEx hdc, cxClient \ 2, cyClient \ 2, BYVAL %NULL
SelectObject hdc, GetStockObject(%NULL_PEN)
SelectObject hdc, hBrushRed
DisplayTime hdc, f24Hour, fSuppress
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
KillTimer hwnd, %ID_TIMER
DeleteObject hBrushRed
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF1.C -- Enhanced Metafile Demo #1 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Creates and displays an enhanced metafile with a fairly minimal amount of distraction.
' ========================================================================================
' EMF1.BAS
' This program is a translation/adaptation of EMF1.C -- Enhanced Metafile Demo #1
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Creates and displays an enhanced metafile with a fairly minimal amount of distraction.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hemf AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcEMF AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
hdcEMF = CreateEnhMetaFile(%NULL, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
Rectangle hdcEMF, 100, 100, 200, 200
MoveToEx hdcEMF, 100, 100, BYVAL %NULL
LineTo hdcEMF, 200, 200
MoveToEx hdcEMF, 200, 100, BYVAL %NULL
LineTo hdcEMF, 100, 200
hemf = CloseEnhMetaFile(hdcEMF)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
PlayEnhMetaFile hdc, hemf, rc
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteEnhMetaFile hemf
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF2.C -- Enhanced Metafile Demo #2 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
You can get a good feel for how metafiles work by looking at the contents of the metafile. This is easiest if you have a disk-based metafile to look at, so the EMF2 program creates one for you.
' ========================================================================================
' EMF2.BAS
' This program is a translation/adaptation of EMF2.C -- Enhanced Metafile Demo #2
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' You can get a good feel for how metafiles work by looking at the contents of the
' metafile. This is easiest if you have a disk-based metafile to look at, so the EMF2
' program creates one for you.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hemf AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcEMF AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
hdcEMF = CreateEnhMetaFile(%NULL, "emf2.emf", BYVAL %NULL, "EMF2" & $NUL & "EMF Demo #2" & $NUL)
Rectangle hdcEMF, 100, 100, 201, 201
MoveToEx hdcEMF, 100, 100, BYVAL %NULL
LineTo hdcEMF, 200, 200
MoveToEx hdcEMF, 200, 100, BYVAL %NULL
LineTo hdcEMF, 100, 200
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf2.emf")
IF hemf THEN
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF3.C -- Enhanced Metafile Demo #3 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
We've now seen how GDI drawing commands are stored in metafiles. Now let's examine how GDI objects are stored. The EMF3 program is similar to the EMF2 program shown earlier, except that it creates a nondefault pen and brush for drawing the rectangle and lines.
' ========================================================================================
' EMF3.BAS
' This program is a translation/adaptation of EMF3.C -- Enhanced Metafile Demo #3
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' We've now seen how GDI drawing commands are stored in metafiles. Now let's examine how
' GDI objects are stored. The EMF3 program is similar to the EMF2 program shown earlier,
' except that it creates a nondefault pen and brush for drawing the rectangle and lines.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #3"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL lb AS LOGBRUSH
LOCAL hdc AS DWORD
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
hdcEMF = CreateEnhMetaFile(%NULL, "emf3.emf", BYVAL %NULL, "EMF3" & $NUL & "EMF Demo #3" & $NUL)
SelectObject hdcEMF, CreateSolidBrush(RGB(0, 0, 255))
lb.lbStyle = %BS_SOLID
lb.lbColor = RGB(255, 0, 0)
lb.lbHatch = 0
SelectObject hdcEMF, ExtCreatePen(%PS_SOLID OR %PS_GEOMETRIC, 5, lb, 0, BYVAL %NULL)
Rectangle hdcEMF, 100, 100, 201, 201
MoveToEx hdcEMF, 100, 100, BYVAL %NULL
LineTo hdcEMF, 200, 200
MoveToEx hdcEMF, 200, 100, BYVAL %NULL
LineTo hdcEMF, 100, 200
DeleteObject SelectObject (hdcEMF, GetStockObject(%BLACK_PEN))
DeleteObject SelectObject (hdcEMF, GetStockObject(%WHITE_BRUSH))
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf3.emf")
IF hemf THEN
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF4.C -- Enhanced Metafile Demo #4 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Let's try something a little more complex now, in particular drawing a bitmap in a metafile device context.
' ========================================================================================
' EMF4.BAS
' This program is a translation/adaptation of EMF4.C -- Enhanced Metafile Demo #4
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Let's try something a little more complex now, in particular drawing a bitmap in a
' metafile device context.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF4"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #4"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL bm AS BITMAP
LOCAL hbm AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcEMF AS DWORD
LOCAL hdcMem AS DWORD
LOCAL hemf AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
hdcEMF = CreateEnhMetaFile(%NULL, "emf4.emf", BYVAL %NULL, "EMF4" & $NUL & "EMF Demo #4" & $NUL)
hbm = LoadBitmap(%NULL, BYVAL %OBM_CLOSE)
GetObject hbm, SIZEOF(BITMAP), bm
hdcMem = CreateCompatibleDC(hdcEMF)
SelectObject hdcMem, hbm
StretchBlt hdcEMF, 100, 100, 100, 100, _
hdcMem, 0, 0, bm.bmWidth, bm.bmHeight, %SRCCOPY
DeleteDC hdcMem
DeleteObject hbm
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf4.emf")
IF hemf THEN
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF5.C -- Enhanced Metafile Demo #5 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
This program uses a metafile to display the same image as EMF3 but works by using metafile enumeration.
Note: This program uses the EMF3.EMF file created by the EMF3 program, so make sure you run that one before this one.
' ========================================================================================
' EMF5.BAS
' This program is a translation/adaptation of EMF5.C -- Enhanced Metafile Demo #5
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' This program uses a metafile to display the same image as EMF3 but works by using
' metafile enumeration.
' Note: This program uses the EMF3.EMF file created by the EMF3 program, so make sure you
' run that one before this one.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF5"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #5"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Enhanced metafile enumeration callback
' ========================================================================================
FUNCTION EnhMetaFileProc (BYVAL hdc AS DWORD, pHandleTable AS HANDLETABLE, _
pEmfRecord AS ENHMETARECORD, BYVAL iHandles AS DWORD, _
BYVAL pData AS LONG) AS LONG
PlayEnhMetaFileRecord hdc, pHandleTable, pEmfRecord, iHandles
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hdc AS DWORD
LOCAL hemf AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf3.emf")
IF hemf THEN
EnumEnhMetaFile hdc, hemf, CODEPTR(EnhMetaFileProc), BYVAL %NULL, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF6.C -- Enhanced Metafile Demo #6 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
EMF6 demonstrates that if you want to modify metafile records before rendering them, the solution is fairly simple: you make a copy and modify that.
Note: This program uses the EMF3.EMF file created by the EMF3 program, so make sure you run that one before this one.
' ========================================================================================
' EMF6.BAS
' This program is a translation/adaptation of EMF6.C -- Enhanced Metafile Demo #6
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' EMF6 demonstrates that if you want to modify metafile records before rendering them,
' the solution is fairly simple: you make a copy and modify that.
' Note: This program uses the EMF3.EMF file created by the EMF3 program, so make sure you
' run that one before this one.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF6"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #6"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Enhanced metafile enumeration callback
' ========================================================================================
FUNCTION EnhMetaFileProc (BYVAL hdc AS DWORD, pHandleTable AS HANDLETABLE, _
pEmfRecord AS ENHMETARECORD, BYVAL iHandles AS DWORD, _
BYVAL pData AS LONG) AS LONG
LOCAL pEmfr AS ENHMETARECORD PTR
pEmfr = CoTaskMemALloc(pEmfRecord.nSize)
CopyMemory pEmfr, VARPTR(pEmfRecord), pEmfRecord.nSize
IF @pEmfr.iType = %EMR_RECTANGLE THEN @pEmfr.iType = %EMR_ELLIPSE
PlayEnhMetaFileRecord hdc, pHandleTable, BYVAL pEmfr, iHandles
FUNCTION = %TRUE
CoTaskMemFree pEmfr
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hdc AS DWORD
LOCAL hemf AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf3.emf")
IF hemf THEN
EnumEnhMetaFile hdc, hemf, CODEPTR(EnhMetaFileProc), BYVAL %NULL, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF7.C -- Enhanced Metafile Demo #7 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Perhaps the most important use of metafile enumeration is to embed other images (or even entire metafiles) in an existing metafile. Actually, the existing metafile remains unchanged; what you really do is create a new metafile that combines the existing metafile and the new embedded images. The basic trick is to pass a metafile device context handle as the first argument to EnumEnhMetaFile. That allows you to render both metafile records and GDI function calls on the metafile device context.
Note: This program uses the EMF3.EMF file created by the EMF3 program, so make sure you run that one before this one.
' ========================================================================================
' EMF7.BAS
' This program is a translation/adaptation of EMF7.C -- Enhanced Metafile Demo #7
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Perhaps the most important use of metafile enumeration is to embed other images (or even
' entire metafiles) in an existing metafile. Actually, the existing metafile remains
' unchanged; what you really do is create a new metafile that combines the existing
' metafile and the new embedded images. The basic trick is to pass a metafile device
' context handle as the first argument to EnumEnhMetaFile. That allows you to render both
' metafile records and GDI function calls on the metafile device context.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EMF7"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Demo #7"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Enhanced metafile enumeration callback
' ========================================================================================
FUNCTION EnhMetaFileProc (BYVAL hdc AS DWORD, pHandleTable AS HANDLETABLE, _
pEmfRecord AS ENHMETARECORD, BYVAL iHandles AS DWORD, _
BYVAL pData AS LONG) AS LONG
LOCAL hBrush AS DWORD
LOCAL hPen AS DWORD
LOCAL lb AS LOGBRUSH
IF pEmfRecord.iType <> %EMR_HEADER AND pEmfRecord.iType <> %EMR_EOF THEN
PlayEnhMetaFileRecord hdc, pHandleTable, pEmfRecord, iHandles
END IF
IF pEmfRecord.iType <> %EMR_RECTANGLE THEN
hBrush = SelectObject(hdc, GetStockObject(%NULL_BRUSH))
lb.lbStyle = %BS_SOLID
lb.lbColor = RGB(0, 255, 0)
lb.lbHatch = 0
hPen = SelectObject(hdc, ExtCreatePen(%PS_SOLID OR %PS_GEOMETRIC, 5, lb, 0, BYVAL %NULL))
Ellipse hdc, 100, 100, 200, 200
DeleteObject SelectObject(hdc, hPen)
SelectObject hdc, hBrush
END IF
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL emh AS ENHMETAHEADER
LOCAL hdc AS DWORD
LOCAL hdcEMF AS DWORD
LOCAL hemfOld AS DWORD
LOCAL hemf AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
' Retrieve existing metafile and header
hemfOld = GetEnhMetaFile("emf3.emf")
GetEnhMetaFileHeader hemfOld, SIZEOF(ENHMETAHEADER), emh
' Create a new metafile DC
hdcEMF = CreateEnhMetaFile(%NULL, "emf7.emf", BYVAL %NULL, _
"EMF7" & $NUL & "EMF Demo #7" & $NUL)
' Enumerate the existing metafile
EnumEnhMetaFile hdcEMF, hemfOld, CODEPTR(EnhMetaFileProc), BYVAL %NULL, emh.rclBounds
' Clean up
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemfOld
DeleteEnhMetaFile hemf
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
rc.nLeft = rc.nRight / 4
rc.nRight = 3 * rc.nRight / 4
rc.nTop = rc.nBottom / 4
rc.nBottom = 3 * rc.nBottom / 4
hemf = GetEnhMetaFile("emf7.emf")
IF hemf THEN
EnumEnhMetaFile hdc, hemf, CODEPTR(EnhMetaFileProc), BYVAL %NULL, rc
DeleteEnhMetaFile hemf
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF8.C -- Enhanced Metafile Demo #8 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
In the sample programs shown previously, we've based the bounding rectangle in the PlayEnhMetaFile call on the size of the client area. Thus, as you resize the program's window, you effectively resize the image. This is conceptually similar to resizing a metafile image within a word-processing document.
Accurately displaying a metafile image-either in specific metrical sizes or with a proper aspect ratio-requires using size information in the metafile header and setting the rectangle structure accordingly.
Note: When printing the ruler you will notice that it is rendered very small. If you have a 300-dpi laser printer, the ruler will be about 11/3 inches wide. That's because we've used a pixel dimension based on the video display. Although you may think the little printed ruler looks kind of cute, it's not what we want. Let's try again in the next example.
' ========================================================================================
' EMF8.BAS
' This program is a translation/adaptation of EMF8.C -- Enhanced Metafile Demo #8
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' In the sample programs shown previously, we've based the bounding rectangle in the
' PlayEnhMetaFile call on the size of the client area. Thus, as you resize the program's
' window, you effectively resize the image. This is conceptually similar to resizing a
' metafile image within a word-processing document.
' Accurately displaying a metafile image-either in specific metrical sizes or with a
' proper aspect ratio-requires using size information in the metafile header and setting
' the rectangle structure accordingly.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf8.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF8"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF8: Enhanced Metafile Demo #8"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, 0, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, cy, BYVAL %NULL
LineTo hdc, i * cx / 96, cy - iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL xDpi AS LONG
LOCAL yDpi AS LONG
hdcEMF = CreateEnhMetaFile(%NULL, "emf8.emf", BYVAL %NULL, "EMF8" & $NUL & "EMF Demo #8" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
cxMms = GetDeviceCaps(hdcEMF, %HORZSIZE)
cyMms = GetDeviceCaps(hdcEMF, %VERTSIZE)
cxPix = GetDeviceCaps(hdcEMF, %HORZRES)
cyPix = GetDeviceCaps(hdcEMF, %VERTRES)
xDpi = cxPix * 254 / cxMms / 10
yDpi = cyPix * 254 / cyMms / 10
DrawRuler (hdcEMF, 6 * xDpi, yDpi)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL hemf AS DWORD
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
hemf = GetEnhMetaFile("emf8.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclBounds.nRight - emh.rclBounds.nLeft
cyImage = emh.rclBounds.nBottom - emh.rclBounds.nTop
rc.nLeft = (cxArea - cxImage) / 2
rc.nRight = (cxArea + cxImage) / 2
rc.nTop = (cyArea - cyImage) / 2
rc.nBottom = (cyArea + cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF8: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF8", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF8", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF9.C -- Enhanced Metafile Demo #9 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
The ENHMETAHEADER structure contains two rectangle structures that describe the size of the image. The first, which EMF8 uses, is the rclBounds field. This gives the size of the image in pixels. The second is the rclFrame field, which gives the size of the image in units of 0.01 millimeters. The relationship between these two fields is governed by the reference device context originally used when creating the metafile, in this case the video display. (The metafile header also contains two fields named szlDevice and szlMillimeters, which are SIZEL structures that indicate the size of the reference device in pixels and millimeters, the same information available from GetDeviceCaps.)
The information about the millimeter dimensions of the image is put to use by EMF9.
' ========================================================================================
' EMF9.BAS
' This program is a translation/adaptation of EMF9.C -- Enhanced Metafile Demo #9
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' The ENHMETAHEADER structure contains two rectangle structures that describe the size of
' the image. The first, which EMF8 uses, is the rclBounds field. This gives the size of
' the image in pixels. The second is the rclFrame field, which gives the size of the image
' in units of 0.01 millimeters. The relationship between these two fields is governed by
' the reference device context originally used when creating the metafile, in this case
' the video display. (The metafile header also contains two fields named szlDevice and
' szlMillimeters, which are SIZEL structures that indicate the size of the reference
' device in pixels and millimeters, the same information available from GetDeviceCaps.)
' The information about the millimeter dimensions of the image is put to use by EMF9.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf9.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF9"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF9: Enhanced Metafile Demo #9"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, 0, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, cy, BYVAL %NULL
LineTo hdc, i * cx / 96, cy - iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL xDpi AS LONG
LOCAL yDpi AS LONG
hdcEMF = CreateEnhMetaFile(%NULL, "emf9.emf", BYVAL %NULL, "EMF9" & $NUL & "EMF Demo #9" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
cxMms = GetDeviceCaps(hdcEMF, %HORZSIZE)
cyMms = GetDeviceCaps(hdcEMF, %VERTSIZE)
cxPix = GetDeviceCaps(hdcEMF, %HORZRES)
cyPix = GetDeviceCaps(hdcEMF, %VERTRES)
xDpi = cxPix * 254 / cxMms / 10
yDpi = cyPix * 254 / cyMms / 10
DrawRuler (hdcEMF, 6 * xDpi, yDpi)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
cxMms = GetDeviceCaps(hdc, %HORZSIZE)
cyMms = GetDeviceCaps(hdc, %VERTSIZE)
cxPix = GetDeviceCaps(hdc, %HORZRES)
cyPix = GetDeviceCaps(hdc, %VERTRES)
hemf = GetEnhMetaFile("emf9.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop
cxImage = cxImage * cxPix / cxMms / 100
cyImage = cyImage * cyPix / cyMms / 100
rc.nLeft = (cxArea - cxImage) / 2
rc.nRight = (cxArea + cxImage) / 2
rc.nTop = (cyArea - cyImage) / 2
rc.nBottom = (cyArea + cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF9: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF9", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF9", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF10.C -- Enhanced Metafile Demo #10 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
The ENHMETAHEADER structure contains two rectangle structures that describe the size of the image. The first, which EMF8 uses, is the rclBounds field. This gives the size of the image in pixels. The second is the rclFrame field, which gives the size of the image in units of 0.01 millimeters. The relationship between these two fields is governed by the reference device context originally used when creating the metafile, in this case the video display. (The metafile header also contains two fields named szlDevice and szlMillimeters, which are SIZEL structures that indicate the size of the reference device in pixels and millimeters, the same information available from GetDeviceCaps.)
The information about the millimeter dimensions of the image is put to use by EMF10.
' ========================================================================================
' EMF10.BAS
' This program is a translation/adaptation of EMF10.C -- Enhanced Metafile Demo #10
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' The ENHMETAHEADER structure contains two rectangle structures that describe the size of
' the image. The first, which EMF8 uses, is the rclBounds field. This gives the size of
' the image in pixels. The second is the rclFrame field, which gives the size of the image
' in units of 0.01 millimeters. The relationship between these two fields is governed by
' the reference device context originally used when creating the metafile, in this case
' the video display. (The metafile header also contains two fields named szlDevice and
' szlMillimeters, which are SIZEL structures that indicate the size of the reference
' device in pixels and millimeters, the same information available from GetDeviceCaps.)
' The information about the millimeter dimensions of the image is put to use by EMF10.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf10.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF10"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF10: Enhanced Metafile Demo #10"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
hAccel = LoadAccelerators(hInstance, szAppName)
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, 0, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, cy, BYVAL %NULL
LineTo hdc, i * cx / 96, cy - iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL xDpi AS LONG
LOCAL yDpi AS LONG
hdcEMF = CreateEnhMetaFile(%NULL, "EMF10.emf", BYVAL %NULL, "EMF10" & $NUL & "EMF Demo #10" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
cxMms = GetDeviceCaps(hdcEMF, %HORZSIZE)
cyMms = GetDeviceCaps(hdcEMF, %VERTSIZE)
cxPix = GetDeviceCaps(hdcEMF, %HORZRES)
cyPix = GetDeviceCaps(hdcEMF, %VERTRES)
xDpi = cxPix * 254 / cxMms / 10
yDpi = cyPix * 254 / cyMms / 10
DrawRuler (hdcEMF, 6 * xDpi, yDpi)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL fScale AS SINGLE
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
cxMms = GetDeviceCaps(hdc, %HORZSIZE)
cyMms = GetDeviceCaps(hdc, %VERTSIZE)
cxPix = GetDeviceCaps(hdc, %HORZRES)
cyPix = GetDeviceCaps(hdc, %VERTRES)
hemf = GetEnhMetaFile("EMF10.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop
fScale = MIN(cxArea / cxImage, cyArea / cyImage)
cxImage = fScale * cxImage
cyImage = fScale * cyImage
rc.nLeft = (cxArea - cxImage) / 2
rc.nRight = (cxArea + cxImage) / 2
rc.nTop = (cyArea - cyImage) / 2
rc.nBottom = (cyArea + cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF10: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF10", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF10", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF11.C -- Enhanced Metafile Demo #11 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
We've been drawing a ruler that displays inches, and we've also been dealing with dimensions in units of millimeters. Such jobs might seem like good candidates for using the various mapping modes provided under GDI. Yet I've insisted on using pixels and doing all the necessary calculations "manually." Why is that? The simple answer is that the use of mapping modes in connection with metafiles can be quite confusing. But let's try it out to see.
When you call SetMapMode using a metafile device context, the function is encoded in the metafile just like any other GDI function. This is demonstrated in the EMF11 program.
' ========================================================================================
' EMF11.BAS
' This program is a translation/adaptation of EMF11.C -- Enhanced Metafile Demo #11
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' We've been drawing a ruler that displays inches, and we've also been dealing with
' dimensions in units of millimeters. Such jobs might seem like good candidates for using
' the various mapping modes provided under GDI. Yet I've insisted on using pixels and
' doing all the necessary calculations "manually." Why is that?
' The simple answer is that the use of mapping modes in connection with metafiles can be
' quite confusing. But let's try it out to see.
' When you call SetMapMode using a metafile device context, the function is encoded in the
' metafile just like any other GDI function. This is demonstrated in the EMF11 program.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf11.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF11"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF11: Enhanced Metafile Demo #11"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, -1, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, 0, BYVAL %NULL
LineTo hdc, i * cx / 96, iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
hdcEMF = CreateEnhMetaFile(%NULL, "EMF11.emf", BYVAL %NULL, "EMF11" & $NUL & "EMF Demo #11" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
SetMapMode hdcEMF, %MM_LOENGLISH
DrawRuler (hdcEMF, 600, 100)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
cxMms = GetDeviceCaps(hdc, %HORZSIZE)
cyMms = GetDeviceCaps(hdc, %VERTSIZE)
cxPix = GetDeviceCaps(hdc, %HORZRES)
cyPix = GetDeviceCaps(hdc, %VERTRES)
hemf = GetEnhMetaFile("EMF11.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop
cxImage = cxImage * cxPix / cxMms / 100
cyImage = cyImage * cyPix / cyMms / 100
rc.nLeft = (cxArea - cxImage) / 2
rc.nTop = (cyArea - cyImage) / 2
rc.nRight = (cxArea + cxImage) / 2
rc.nBottom = (cyArea + cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF11: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF11", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF11", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF12.C -- Enhanced Metafile Demo #12 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Calculating the destination rectangle in EMF11 involves some calls to GetDeviceCaps. Our second goal is to eliminate those and use a mapping mode instead. GDI treats the coordinates of the destination rectangle as logical coordinates. Using the %MM_HIMETRIC mode seems like a good candidate for these coordinates, because that makes logical units 0.01 millimeters, the same units used for the bounding rectangle in the enhanced metafile header.
The EMF12 program restores the DrawRuler logic as originally presented in EMF8 but uses the %MM_HIMETRIC mapping mode to display the metafile.
' ========================================================================================
' EMF12.BAS
' This program is a translation/adaptation of EMF12.C -- Enhanced Metafile Demo #12
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Calculating the destination rectangle in EMF11 involves some calls to GetDeviceCaps. Our
' second goal is to eliminate those and use a mapping mode instead. GDI treats the
' coordinates of the destination rectangle as logical coordinates. Using the %MM_HIMETRIC
' mode seems like a good candidate for these coordinates, because that makes logical units
' 0.01 millimeters, the same units used for the bounding rectangle in the enhanced
' metafile header.
' The EMF12 program restores the DrawRuler logic as originally presented in EMF8 but uses
' the %MM_HIMETRIC mapping mode to display the metafile.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf12.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF12"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF12: Enhanced Metafile Demo #12"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, 0, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, cy, BYVAL %NULL
LineTo hdc, i * cx / 96, cy - iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
LOCAL cxMms AS LONG
LOCAL cyMms AS LONG
LOCAL cxPix AS LONG
LOCAL cyPix AS LONG
LOCAL xDpi AS LONG
LOCAL yDpi AS LONG
hdcEMF = CreateEnhMetaFile(%NULL, "EMF12.emf", BYVAL %NULL, "EMF12" & $NUL & "EMF Demo #12" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
cxMms = GetDeviceCaps(hdcEMF, %HORZSIZE)
cyMms = GetDeviceCaps(hdcEMF, %VERTSIZE)
cxPix = GetDeviceCaps(hdcEMF, %HORZRES)
cyPix = GetDeviceCaps(hdcEMF, %VERTRES)
xDpi = cxPix * 254 / cxMms / 10
yDpi = cyPix * 254 / cyMms / 10
DrawRuler (hdcEMF, 6 * xDpi, yDpi)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL hemf AS DWORD
LOCAL pt AS POINTAPI
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
SetMapMode hdc, %MM_HIMETRIC
SetViewportOrgEx hdc, 0, cyArea, BYVAL %NULL
pt.x = cxArea
pt.y = 0
DPtoLP hdc, pt, 1
hemf = GetEnhMetaFile("EMF12.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop
rc.nLeft = (pt.x - cxImage) / 2
rc.nTop = (pt.y + cyImage) / 2
rc.nRight = (pt.x + cxImage) / 2
rc.nBottom = (pt.y - cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF12: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF12", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF12", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMF13.C -- Enhanced Metafile Demo #13 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Now we've seen how we can use a mapping mode when creating the metafile and also for displaying it. Can we do both?
It turns out that it works, as EMF13 demonstrates.
' ========================================================================================
' EMF13.BAS
' This program is a translation/adaptation of EMF13.C -- Enhanced Metafile Demo #13
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Now we've seen how we can use a mapping mode when creating the metafile and also for
' displaying it. Can we do both?
' It turns out that it works, as EMF13 demonstrates.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "emf13.res"
%IDM_PRINT = 40001
%IDM_EXIT = 40002
%IDM_ABOUT = 40003
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EMF13"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "EMF13: Enhanced Metafile Demo #13"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)
LOCAL i AS LONG
LOCAL iHeight AS LONG
LOCAL lf AS LOGFONT
LOCAL ch AS ASCIIZ * 2
' Black pen with 1-point width
SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)
' Rectangle surrounding entire pen (with adjustment)
Rectangle (hdc, 0, -1, cx + 1, cy + 1)
' Tick marks
FOR i = 1 TO 95
IF i MOD 16 = 0 THEN
iHeight = cy / 2 ' inches
ELSEIF i MOD 8 = 0 THEN
iHeight = cy / 3 ' half inches
ELSEIF i MOD 4 = 0 THEN
iHeight = cy / 5 ' quarter inches
ELSEIF i MOD 2 = 0 THEN
iHeight = cy / 8 ' eighths
ELSE
iHeight = cy / 12 ' sixteenths
END IF
MoveToEx hdc, i * cx / 96, 0, BYVAL %NULL
LineTo hdc, i * cx / 96, iHeight
NEXT
' Create logical font
lf.lfHeight = cy / 2
lf.lfFaceName = "Times New Roman"
SelectObject hdc, CreateFontIndirect(lf)
SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
SetBkMode hdc, %TRANSPARENT
' Display numbers
FOR i = 1 TO 5
ch = FORMAT$(i)
TextOut hdc, i * cx / 6, cy / 2, ch, 1
NEXT
' Clean up
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
END SUB
' ========================================================================================
' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)
LOCAL hdcEMF AS DWORD
LOCAL hemf AS DWORD
hdcEMF = CreateEnhMetaFile(%NULL, "EMF13.emf", BYVAL %NULL, "EMF13" & $NUL & "EMF Demo #13" & $NUL)
IF hdcEMF = %NULL THEN EXIT SUB
SetMapMode hdcEMF, %MM_LOENGLISH
DrawRuler (hdcEMF, 600, 100)
hemf = CloseEnhMetaFile(hdcEMF)
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL emh AS ENHMETAHEADER
LOCAL hemf AS DWORD
LOCAL pt AS POINTAPI
LOCAL cxImage AS LONG
LOCAL cyImage AS LONG
LOCAL rc AS RECT
SetMapMode hdc, %MM_HIMETRIC
SetViewportOrgEx hdc, 0, cyArea, BYVAL %NULL
pt.x = cxArea
pt.y = 0
DPtoLP hdc, pt, 1
hemf = GetEnhMetaFile("EMF13.emf")
GetEnhMetaFileHeader hemf, SIZEOF(emh), emh
cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop
rc.nLeft = (pt.x - cxImage) / 2
rc.nTop = (pt.y + cyImage) / 2
rc.nRight = (pt.x + cxImage) / 2
rc.nBottom = (pt.y - cyImage) / 2
PlayEnhMetaFile hdc, hemf, rc
DeleteEnhMetaFile hemf
END SUB
' ========================================================================================
' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG
STATIC szMessage AS ASCIIZ * 32
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
IF hdcPrn = %NULL THEN EXIT FUNCTION
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
szMessage = "EMF13: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szMessage)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
CreateRoutine hwnd
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = PrintRoutine(hwnd)
ShowCursor %FALSE
SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Error encountered during printing", "EMF13", %MB_OK OR %MB_TASKMODAL
END IF
CASE %IDM_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_ABOUT
MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
"(c) Charles Petzold, 1998", "EMF13", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of EMFVIEW.C -- View Enhanced Metafiles © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Demonstrates how to transfer metafiles to and from the clipboard, and it also allows loading metafiles, saving metafiles, and printing them.
' ========================================================================================
' EMFVIEW.BAS
' This program is a translation/adaptation of EMFVIEW.C -- View Enhanced Metafiles
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Demonstrates how to transfer metafiles to and from the clipboard, and it also allows
' loading metafiles, saving metafiles, and printing them.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "emfview.res"
%IDM_FILE_OPEN = 40001
%IDM_FILE_SAVE_AS = 40002
%IDM_FILE_PRINT = 40003
%IDM_FILE_PROPERTIES = 40004
%IDM_APP_EXIT = 40005
%IDM_EDIT_CUT = 40006
%IDM_EDIT_COPY = 40007
%IDM_EDIT_PASTE = 40008
%IDM_EDIT_DELETE = 40009
%IDM_APP_ABOUT = 40010
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "EmfView"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Enhanced Metafile Viewer"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Creates palette from metafile
' ========================================================================================
FUNCTION CreatePaletteFromMetaFile (hemf AS DWORD) AS DWORD
LOCAL hPalette AS DWORD
LOCAL iNum AS LONG
LOCAL plp AS LOGPALETTE PTR
IF hemf = %NULL THEN EXIT FUNCTION
iNum = GetEnhMetaFilePaletteEntries(hemf, 0, BYVAL %NULL)
IF iNum = 0 THEN EXIT FUNCTION
plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + (iNum - 1) * SIZEOF(PALETTEENTRY))
@plp.palVersion = &H0300
@plp.palNumEntries = iNum
GetEnhMetaFilePaletteEntries hEmf, iNum , @plp.palPalEntry(0)
hPalette = CreatePalette(BYVAL plp)
CoTaskMemFree plp
FUNCTION = hPalette
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hemf AS DWORD
LOCAL bSuccess AS LONG
LOCAL emheader AS ENHMETAHEADER
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL hemfCopy AS DWORD
LOCAL hMenu AS DWORD
LOCAL hPalette AS DWORD
LOCAL i AS LONG
LOCAL iLEngth AS LONG
LOCAL iEnable AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
LOCAL pBuffer AS ASCIIZ PTR
LOCAL strDesc AS STRING
STATIC strPath AS STRING
STATIC fOptions AS STRING
STATIC dwStyle AS DWORD
STATIC strFileSpec AS STRING
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize variables to default values
strPath = CURDIR$
fOptions = "Enhanced Metafiles (*.EMF)|*.emf|"
fOptions = fOptions & "All Files (*.*)|*.*"
strFileSpec = "*.EMF"
FUNCTION = 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_OPEN
' Call the OpenFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST
IF ISFALSE OpenFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "EMF", dwStyle) THEN EXIT FUNCTION
' If there is an existing EMF, get rid of it
IF hemf THEN
DeleteEnhMetaFile hemf
hemf = %NULL
END IF
' Load the EMF into memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
hemf = GetEnhMetaFile(BYCOPY strFileSpec)
' Invalidate the client area for later update
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
InvalidateRect hwnd, BYVAL %NULL, %TRUE
IF hemf = %NULL THEN
MessageBox hwnd, "Cannot load metafile", "EmfView", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
CASE %IDM_FILE_SAVE_AS
IF ISFALSE hemf THEN EXIT FUNCTION
' Call the SaveFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT
IF ISFALSE(SaveFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "EMF", dwStyle)) THEN EXIT FUNCTION
' Save the DIB to memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
hemfCopy = CopyEnhMetaFile(hemf, BYCOPY strFileSpec)
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
IF hemfCopy THEN
DeleteEnhMetaFile hemf
hemf = hemfCopy
ELSE
MessageBox hwnd, "Cannot save metafile", "EmfView", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
CASE %IDM_FILE_PRINT
IF hemf = %NULL THEN EXIT FUNCTION
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
rc.nLeft = 0
rc.nRight = GetDeviceCaps(hdcPrn, %HORZRES)
rc.nTop = 0
rc.nBottom = GetDeviceCaps(hdcPrn, %VERTRES)
bSuccess = %FALSE
' Play the EMF to the printer
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
szDocName = "EmfView: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PlayEnhMetaFile hdcPrn, hemf, rc
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Could not print metafile", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
END IF
END IF
CASE %IDM_FILE_PROPERTIES
IF ISFALSE hemf THEN EXIT FUNCTION
iLength = GetEnhMetaFileDescription (hemf, 0, BYVAL %NULL)
pBuffer = CoTaskMemALloc (iLength + 256)
GetEnhMetaFileHeader hemf, SIZEOF(ENHMETAHEADER), emheader
' Format header file information
i = wsprintf(BYVAL pBuffer, "Bounds = (%i, %i) to (%i, %i) pixels" & $LF, _
BYVAL emheader.rclBounds.nLeft, BYVAL emheader.rclBounds.nTop, _
BYVAL emheader.rclBounds.nRight, BYVAL emheader.rclBounds.nBottom)
i = wsprintf(BYVAL pBuffer + i, "Frame = (%i, %i) to (%i, %i) mms" & $LF, _
BYVAL emheader.rclFrame.nLeft, BYVAL emheader.rclBounds.nTop, _
BYVAL emheader.rclBounds.nRight, BYVAL emheader.rclBounds.nBottom) + i
i = wsprintf(BYVAL pBuffer + i, "Resolution = (%i, %i) pixels = (%i, %i) mms" & $LF, _
BYVAL emheader.szlDevice.cx, BYVAL emheader.szlDevice.cy, _
BYVAL emheader.szlMillimeters.cx, _
BYVAL emheader.szlMillimeters.cy) + i
i = wsprintf(BYVAL pBuffer + i, "Size = %i, Records = %i, Handles = %i, Palette entries = %i" & $LF, _
BYVAL emheader.nBytes, BYVAL emheader.nRecords, _
BYVAL emheader.nHandles, BYVAL emheader.nPalEntries) + i
' Include the metafile description, if present
IF iLength THEN
strDesc = SPACE$(iLength)
GetEnhMetaFileDescription (hemf, iLength, BYVAL STRPTR(strDesc))
i = wsprintf(BYVAL pBuffer + i, "Description = %s", BYVAL STRPTR(strDesc)) + i
END IF
MessageBox hwnd, BYVAL pBuffer, "Metafile Properties", %MB_OK OR %MB_TASKMODAL
CoTaskMemFree pBuffer
CASE %IDM_EDIT_COPY, %IDM_EDIT_CUT
IF hemf = %NULL THEN EXIT FUNCTION
' Transfer metafile copy to the clipboard
hemfCopy = CopyEnhMetaFile (hemf, BYVAl %NULL)
OpenClipboard hwnd
EmptyClipboard
SetClipboardData %CF_ENHMETAFILE, hemfCopy
CloseClipboard
IF LO(WORD, wParam) = %IDM_EDIT_CUT THEN
DeleteEnhMetaFile hemf
hemf = %NULL
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_EDIT_DELETE
IF hemf THEN
DeleteEnhMetaFile hemf
hemf = %NULL
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_EDIT_PASTE
OpenClipboard hwnd
hemfCopy = GetClipboardData(%CF_ENHMETAFILE)
CloseClipboard
IF ISTRUE hemfCopy AND ISTRUE hemf THEN
DeleteEnhMetaFile hemf
hemf = %NULL
END IF
hemf = CopyEnhMetaFile(hemfCopy, BYVAL %NULL)
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_APP_ABOUT
MessageBox hwnd, "Enhanced Metafile Viewer" & $LF & _
"(c) Charles Petzold, 1998", "EmfView", %MB_OK OR %MB_TASKMODAL
CASE %IDM_APP_EXIT
SendMessage hwnd, %WM_CLOSE, 0, 0
END SELECT
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
' Enable or disable menu options
hMenu = GetMenu(hwnd)
IF hemf <> %NULL THEN
iEnable = %MF_ENABLED
ELSE
iEnable = %MF_GRAYED
END IF
EnableMenuItem hMenu, %IDM_FILE_SAVE_AS, iEnable
EnableMenuItem hMenu, %IDM_FILE_PRINT, iEnable
EnableMenuItem hMenu, %IDM_FILE_PROPERTIES, iEnable
EnableMenuItem hMenu, %IDM_EDIT_CUT, iEnable
EnableMenuItem hMenu, %IDM_EDIT_COPY, iEnable
EnableMenuItem hMenu, %IDM_EDIT_DELETE, iEnable
IF IsClipboardFormatAvailable(%CF_ENHMETAFILE) THEN
EnableMenuItem hMenu, %IDM_EDIT_DELETE, %MF_ENABLED
ELSE
EnableMenuItem hMenu, %IDM_EDIT_DELETE, %MF_GRAYED
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
IF hemf THEN
hPalette = CreatePaletteFromMetafile(hemf)
IF hPalette THEN
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
END IF
GetClientRect hwnd, rc
PlayEnhMetaFile hdc, hemf, rc
IF hPalette THEN DeleteObject hPalette
END IF
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_QUERYNEWPALETTE
IF ISFALSE hemf THEN EXIT FUNCTION
hPalette = CreatePaletteFromMetaFile(hemf)
IF ISFALSE hPalette THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
InvalidateRect hwnd, BYVAL %NULL, %FALSE
DeleteObject hPalette
ReleaseDC hwnd, hdc
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_PALETTECHANGED
IF wParam = hwnd THEN EXIT FUNCTION
IF ISFALSE hemf THEN EXIT FUNCTION
hPalette = CreatePaletteFromMetaFile(hemf)
IF ISFALSE hPalette THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
UpdateColors hdc
DeleteObject hPalette
ReleaseDC hwnd, hdc
CASE %WM_DESTROY
' Free the allocated memory and end the program
IF hemf THEN DeleteEnhMetaFile hemf
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of ENDJOIN.C -- Ends and Joins Demo © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
The program draws three V-shaped wide lines using the end and join styles in the order listed above. The program also draws three identical lines using the stock black pen. This shows how the wide line compares with the normal thin line.
' ========================================================================================
' ENDJOIN.BAS
' This program is a translation/adaptation of ENDJOIN.C -- Ends and Joins Demo
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The program draws three V-shaped wide lines using the end and join styles in the order
' listed above. The program also draws three identical lines using the stock black pen.
' This shows how the wide line compares with the normal thin line.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL msg AS tagMsg
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "EndJoin"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Ends and Joins Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM iEnd(0 TO 2) AS STATIC LONG
ARRAY ASSIGN iEnd() = %PS_ENDCAP_ROUND, %PS_ENDCAP_SQUARE, %PS_ENDCAP_FLAT
DIM iJoin(0 TO 2) AS STATIC LONG
ARRAY ASSIGN iJoin() = %PS_JOIN_ROUND, %PS_JOIN_BEVEL, %PS_JOIN_MITER
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL lb AS LOGBRUSH
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
FUNCTION = 0
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 100, 100, BYVAL %NULL
SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
lb.lbStyle = %BS_SOLID
lb.lbColor = RGB(128, 128, 128)
lb.lbHatch = 0
FOR i = 0 TO 2
SelectObject hdc, ExtCreatePen (%PS_SOLID OR %PS_GEOMETRIC OR _
iEnd(i) OR iJoin(i), 10, lb, 0, BYVAL %NULL)
BeginPath hdc
MoveToEx hdc, 10 + 30 * i, 25, BYVAl %NULL
LineTo hdc, 20 + 30 * i, 75
LineTo hdc, 30 + 30 * i, 25
EndPath hdc
StrokePath hdc
DeleteObject SelectObject (hdc, GetStockObject(%BLACK_PEN))
MoveToEx hdc, 10 + 30 * i, 25, BYVAl %NULL
LineTo hdc, 20 + 30 * i, 75
LineTo hdc, 30 + 30 * i, 25
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of ENVIRON.C -- Environment List Box © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.
The ENVIRON program uses a list box in its client area to display the name of your current operating system environment variables (such as PATH and WINDIR). As you select an environment variable, the environment string is displayed across the top of the client area.
' ========================================================================================
' ENVIRON.BAS
' This program is a translation/adaptation of ENVIRON.C -- Environment List Box
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' The ENVIRON program uses a list box in its client area to display the name of your
' current operating system environment variables (such as PATH and WINDIR). As you select
' an environment variable, the environment string is displayed across the top of the
' client area.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_LIST = 1
%ID_TEXT = 2
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL msg AS tagMsg
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Environ"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Environment List Box"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB FillListBox (BYVAL hwndList AS DWORD)
LOCAL pVarBlock AS ASCIIZ PTR
LOCAL strVarName AS STRING
LOCAL p AS LONG
' Get pointer to environment block
pVarBlock = GetEnvironmentStrings()
IF pVarBlock = %NULL THEN EXIT SUB
DO
strVarName = @pVarBlock
IF LEN(strVarName) = 0 THEN EXIT DO
pVarBlock = pVarBlock + LEN(strVarName) + 1
' Skip variable names beginning with "="
IF LEFT$(strVarName, 1) <> "=" THEN
' Extract the environment variable name
p = INSTR(strVarName, "=")
IF p THEN strVarName = LEFT$(strVarName, p - 1)
' Show the variable name in the listbox
SendMessage hwndList, %LB_ADDSTRING, 0, STRPTR(strVarName)
END IF
LOOP
' Frees the block of environment strings
FreeEnvironmentStrings BYVAL pVarBlock
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndList AS DWORD
STATIC hwndText AS DWORD
LOCAL iIndex AS LONG
LOCAL iLength AS LONG
LOCAL cxChar AS LONG
LOCAL cyChar AS LONG
LOCAL pVarName AS ASCIIZ PTR
LOCAL pVarValue AS ASCIIZ PTR
SELECT CASE uMsg
CASE %WM_CREATE
cxChar = LO(WORD, GetDialogBaseUnits())
cyChar = HI(WORD, GetDialogBaseUnits())
' Create listbox and static text windows.
hwndList = CreateWindowEx(0, "Listbox", BYVAL %NULL, _
%WS_CHILD OR %WS_VISIBLE OR %LBS_STANDARD, _
cxChar, cyChar * 3, _
cxChar * 30 + GetSystemMetrics(%SM_CXVSCROLL), _
cyChar * 15, _
hwnd, %ID_LIST, _
GetWindowLong (hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
hwndText = CreateWindowEx(0, "Static", BYVAL %NULL, _
%WS_CHILD OR %WS_VISIBLE OR %SS_LEFT, _
cxChar, cyChar, _
GetSystemMetrics(%SM_CXSCREEN), cyChar, _
hwnd, %ID_TEXT, _
GetWindowLong(hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
FillListBox hwndList
EXIT FUNCTION
CASE %WM_SETFOCUS
SetFocus hwndList
EXIT FUNCTION
CASE %WM_COMMAND
IF LO(WORD, wParam) = %ID_LIST AND HI(WORD, wParam) = %LBN_SELCHANGE THEN
' Get current selection
iIndex = SendMessage(hwndList, %LB_GETCURSEL, 0, 0)
iLength = SendMessage(hwndList, %LB_GETTEXTLEN, iIndex, 0) + 1
pVarName = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, iLength)
SendMessage hwndList, %LB_GETTEXT, iIndex, pVarName
' Get environment string
iLength = GetEnvironmentVariable(@pVarName, BYVAL %NULL, 0)
pVarValue = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, iLength)
GetEnvironmentVariable @pVarName, BYVAL pVarValue, iLength
' Show it in window
SetWindowText hwndText, @pVarValue
HeapFree GetProcessHeap, 0, BYVAL pVarName
HeapFree GetProcessHeap, 0, BYVAL pVarValue
END IF
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of FONTCLIP.C -- Using Path for Clipping on Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
You can use a path, and hence a TrueType font, to define a clipping region.
' ========================================================================================
' FONTCLIP.BAS
' This program is a translation/adaptation of FONTCLIP.C -- Using Path for Clipping on Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' You can use a path, and hence a TrueType font, to define a clipping region.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontClip"
$szTitle = "FontClip: Using Path for Clipping on Font"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINT
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL szString AS ASCIIZ * 256
LOCAL hFont AS DWORD
LOCAL y AS LONG
LOCAL iOffset AS LONG
LOCAL tsize AS SIZE
DIM pt(3) AS POINT
szString = "Clipping"
hFont = EzCreateFont(hdc, "Times New Roman", 1200, 0, 0, %TRUE)
SelectObject hdc, hFont
GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
BeginPath hdc
TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
EndPath hdc
' Set clipping area
SelectClipPath hdc, %RGN_COPY
' Draw Bezier splines
iOffset = (cxArea + cyArea) \ 4
FOR y = -iOffset TO cyArea + iOffset - 1
pt(0).x = 0
pt(0).y = y
pt(1).x = cxArea / 3
pt(1).y = y + iOffset
pt(2).x = 2 * cxArea \ 3
pt(2).y = y - iOffset
pt(3).x = cxArea
pt(3).y = y
SelectObject hdc, CreatePen (%PS_SOLID, 1, RGB(RND * 256, RND * 256, RND * 256))
PolyBezier hdc, pt(0), 4
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
NEXT
DeleteObject SelectObject(hdc, GetStockObject(%WHITE_BRUSH))
SelectObject hdc, GetStockObject(%SYSTEM_FONT)
DeleteObject hFont
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "FontClip: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
FONTDEMO.RC
#define IDM_PRINT 40001
#define IDM_ABOUT 40002
/////////////////////////////////////////////////////////////////////////////
// Menu
FONTDEMO MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print...", IDM_PRINT
END
POPUP "&Help"
BEGIN
MENUITEM "&About...", IDM_ABOUT
END
END
This program is a translation of FONTDEMO.C -- Font Demonstration Shell Program © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
' ========================================================================================
' FONTDEMO.BAS
' This program is a translation/adaptation of FONTDEMO.C -- Font Demonstration Shell
' Program © Charles Petzold, 1998, described and analysed in Chapter 17 of the book
' Programming Windows, 5th Edition.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontDemo"
$szTitle = "FontDemo: Font Demonstration Shell Program"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINTAPI
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL hFont AS DWORD
LOCAL y AS LONG
LOCAL iPointSize AS LONG
LOCAL lf AS LOGFONT
LOCAL szBuffer AS ASCIIZ * 100
LOCAL tm AS TEXTMETRIC
LOCAL szFormat AS ASCIIZ * 256
' Set Logical Twips mapping mode
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
SetViewportExtEx hdc, GetDeviceCaps (hdc, %LOGPIXELSX), _
GetDeviceCaps (hdc, %LOGPIXELSY), BYVAL %NULL
' Try some fonts
y = 0
FOR iPointSize = 80 TO 120
hFont = EzCreateFont(hdc, "Times New Roman", iPointSize, 0, 0, %TRUE)
GetObject hFont, SIZEOF(LOGFONT), lf
SelectObject hdc, hFont
GetTextMetrics hdc, tm
szFormat = "lf.lfHeight = %i, tm.tmHeight = %i"
wsprintf szBuffer, "Times New Roman font of %i.%i points, ", _
szFormat, _
BYVAL iPointSize \ 10, BYVAL iPointSize MOD 10, _
BYVAL lf.lfHeight, BYVAL tm.tmHeight
TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
y = y + tm.tmHeight
NEXT
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "Font Demo: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of FONTFILL.C -- Using Path to Fill Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
You can also use paths to define areas for filling. You create the path in the same way as shown in the past two programs, select a filling pattern, and call FillPath. Another function you can call is StrokeAndFillPath, which both outlines a path and fills it with one function call.
' ========================================================================================
' FONTFILL.BAS
' This program is a translation/adaptation of FONTFILL.C -- Using Path to Fill Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' You can also use paths to define areas for filling. You create the path in the same way
' as shown in the past two programs, select a filling pattern, and call FillPath. Another
' function you can call is StrokeAndFillPath, which both outlines a path and fills it with
' one function call.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontFill"
$szTitle = "FontFill: Using Path to Fill Font"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINTAPI
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL hFont AS DWORD
STATIC szString AS ASCIIZ * 256
LOCAL tsize AS APISIZE
szString = "Filling"
hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
SelectObject hdc, hFont
SetBkMode hdc, %TRANSPARENT
GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
BeginPath hdc
TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
EndPath hdc
SelectObject hdc, CreateHatchBrush(%HS_DIAGCROSS, RGB(255, 0, 0))
SetBkColor hdc, RGB(0, 0, 255)
SetBkMode hdc, %OPAQUE
StrokeAndFillPath hdc
DeleteObject SelectObject(hdc, GetStockObject(%WHITE_BRUSH))
SelectObject hdc, GetStockObject(%SYSTEM_FONT)
DeleteObject hFont
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "FontFill: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
FONTDEMO.RC
#define IDM_PRINT 40001
#define IDM_ABOUT 40002
/////////////////////////////////////////////////////////////////////////////
// Menu
FONTDEMO MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print...", IDM_PRINT
END
POPUP "&Help"
BEGIN
MENUITEM "&About...", IDM_ABOUT
END
END
This program is a translation of FONTOUT1.C -- Using Path to Outline Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
The program creates a 144-point TrueType font and calls the GetTextExtentPoint32 function to obtain the dimensions of the text box. It then calls the TextOut function in a path definition so that the text is centered in the client window. Because the TextOut function is called in a path bracket-that is, between calls to BeginPath and EndPath-GDI does not display the text immediately. Instead, the character outlines are stored in the path definition.
After the path bracket is ended, FONTOUT1 calls StrokePath. Because no special pen has been selected into the device context, GDI simply draws the character outlines using the default pen.
' ========================================================================================
' FONTOUT1.BAS
' This program is a translation/adaptation of FONTOUT1.C -- Using Path to Outline Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The program creates a 144-point TrueType font and calls the GetTextExtentPoint32
' function to obtain the dimensions of the text box. It then calls the TextOut function in
' a path definition so that the text is centered in the client window. Because the TextOut
' function is called in a path bracket-that is, between calls to BeginPath and EndPath-GDI
' does not display the text immediately. Instead, the character outlines are stored in the
' path definition.
' After the path bracket is ended, FONTOUT1 calls StrokePath. Because no special pen has
' been selected into the device context, GDI simply draws the character outlines using the
' default pen.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontOut1"
$szTitle = "FontOut1: Using Path to Outline Font"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINT
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL hFont AS DWORD
STATIC szString AS ASCIIZ * 256
LOCAL tsize AS SIZE
szString = "Outline"
hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
SelectObject hdc, hFont
GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
BeginPath hdc
TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
EndPath hdc
StrokePath hdc
SelectObject hdc, GetStockObject(%SYSTEM_FONT)
DeleteObject hFont
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "FontOut1: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LOWRD(lParam)
cyClient = HIWRD(lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
FONTDEMO.RC
#define IDM_PRINT 40001
#define IDM_ABOUT 40002
/////////////////////////////////////////////////////////////////////////////
// Menu
FONTDEMO MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print...", IDM_PRINT
END
POPUP "&Help"
BEGIN
MENUITEM "&About...", IDM_ABOUT
END
END
This program is a translation of FONTOUT2.C -- Using Path to Outline Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
Using the ExtCreatePen function, you can outline the characters of a font with something other than the default pen.
' ========================================================================================
' FONTOUT2.BAS
' This program is a translation/adaptation of FONTOUT2.C -- Using Path to Outline Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' Using the ExtCreatePen function, you can outline the characters of a font with something
' other than the default pen.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontOut2"
$szTitle = "FontOut2: Using Path to Outline Font"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINT
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL hFont AS DWORD
STATIC szString AS ASCIIZ * 256
LOCAL tsize AS SIZE
LOCAL lb AS LOGBRUSH
szString = "Outline"
hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
SelectObject hdc, hFont
SetBkMode hdc, %TRANSPARENT
GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
BeginPath hdc
TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
EndPath hdc
lb.lbStyle = %BS_SOLID
lb.lbColor = RGB(255, 0, 0)
lb.lbHatch = 0
SelectObject hdc, ExtCreatePen (%PS_GEOMETRIC OR %PS_DOT, _
GetDeviceCaps(hdc, %LOGPIXELSX) \ 24, lb, 0, BYVAL %NULL)
StrokePath hdc
DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
SelectObject hdc, GetStockObject(%SYSTEM_FONT)
DeleteObject hFont
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "FontOut2: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
FONTDEMO.RC
#define IDM_PRINT 40001
#define IDM_ABOUT 40002
/////////////////////////////////////////////////////////////////////////////
// Menu
FONTDEMO MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print...", IDM_PRINT
END
POPUP "&Help"
BEGIN
MENUITEM "&About...", IDM_ABOUT
END
END
This program is a translation of FONTROT.C -- Rotated Fonts © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
Although EzCreateFont does not allow you to specify a rotation angle for the font, it's fairly easy to make an adjustment after calling the function, as the FONTROT ("Font Rotate") program demonstrates.
' ========================================================================================
' FONTROT.BAS
' This program is a translation/adaptation of FONTROT.C -- Rotated Fonts
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' Although EzCreateFont does not allow you to specify a rotation angle for the font, it's
' fairly easy to make an adjustment after calling the function, as the FONTROT
' ("Font Rotate") program demonstrates.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "fontdemo.res"
$szAppName = "FontRot"
$szTitle = "FontRot: Rotated Fonts"
%IDM_PRINT = 40001
%IDM_ABOUT = 40002
%EZ_ATTR_BOLD = 1
%EZ_ATTR_ITALIC = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8
' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD
LOCAL cxDpi AS SINGLE
LOCAL cyDpi AS SINGLE
LOCAL hFont AS DWORD
LOCAL lf AS LOGFONT
LOCAL pt AS POINT
LOCAL tm AS TEXTMETRIC
SaveDC hdc
SetGraphicsMode hdc, %GM_ADVANCED
ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
SetWindowOrgEx hdc, 0, 0, BYVAL %NULL
IF fLogRes THEN
cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
ELSE
cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
GetDeviceCaps(hdc, %HORZSIZE))
cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
GetDeviceCaps(hdc, %VERTSIZE))
END IF
pt.x = iDeciPtWidth * cxDpi \ 72
pt.y = iDeciPtHeight * cyDpi \ 72
DPtoLP hdc, pt, 1
lf.lfHeight = - ABS(pt.y) \ 10.0 + 0.5
lf.lfWidth = 0
lf.lfEscapement = 0
lf.lfOrientation = 0
lf.lfWeight = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
lf.lfItalic = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
lf.lfUnderline = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
lf.lfStrikeOut = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
lf.lfCharSet = %DEFAULT_CHARSET
lf.lfOutPrecision = 0
lf.lfClipPrecision = 0
lf.lfQuality = 0
lf.lfPitchAndFamily = 0
lf.lfFaceName = szFaceName
hFont = CreateFontIndirect(lf)
IF iDeciPtWidth THEN
hFont = SelectObject(hdc, hFont)
GetTextMetrics hdc, tm
DeleteObject SelectObject(hdc, hFont)
lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
hFont = CreateFontIndirect(lf)
END IF
RestoreDC hdc, -1
FUNCTION = hFont
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)
LOCAL hFont AS DWORD
LOCAL i AS LONG
LOCAL lf AS LOGFONT
STATIC szString AS ASCIIZ * 256
LOCAL szFormat AS ASCIIZ * 256
szString = " Rotation"
hFont = EzCreateFont(hdc, "Times New Roman", 540, 0, 0, %TRUE)
GetObject hFont, SIZEOF(LOGFONT), lf
DeleteObject hFont
SetBkMode hdc, %TRANSPARENT
SetTextAlign hdc, %TA_BASELINE
SetViewportOrgEx hdc, cxArea \ 2, cyArea \ 2, BYVAL %NULL
FOR i = 0 TO 11
lf.lfOrientation = i * 300
lf.lfEscapement = lf.lfOrientation
SelectObject hdc, CreateFontIndirect(lf)
TextOut hdc, 0, 0, szString, LEN(szString)
DeleteObject SelectObject (hdc, GetStockObject(%SYSTEM_FONT))
NEXT
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szTitle AS ASCIIZ * 256
LOCAL szResource AS ASCIIZ * 256
szAppName = $szAppName
szTitle = $szTitle
szResource = "FontDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szResource)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szTitle, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dinfo AS DOCINFO
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL bSuccess AS LONG
STATIC szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
szDocName = "FontRot: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dInfo.lpszDocName = VARPTR(szDocName)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_PRINT
' Get printer DC
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
fSuccess = %FALSE
' Do the printer page
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
PaintRoutine hwnd, hdcPrn, cxPage, cyPage
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Error encountered during printing", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
END IF
END IF
EXIT FUNCTION
CASE %IDM_ABOUT
MessageBox hwnd, "Font Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PaintRoutine hwnd, hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of FORMFEED.C -- Advances printer to next page © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.
The FORMFEED program demonstrates the absolute minimum requirements for printing.
' ========================================================================================
' FORMFEED.BAS
' This program is a translation of FORMFEED.C -- Advances printer to next page
' © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming
' Windows, 5th Edition.
' The FORMFEED program demonstrates the absolute minimum requirements for printing.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
' ========================================================================================
' GetPrinterDC function
' Methods for obtaining the default printer device context have changed over the years.
' Currently, the standard method involves using the EnumPrinters function. This function
' fills an array of structures that contain information about each attached printer. You
' even have a choice of several structures to use with this function, depending on the
' level of detail you want. These structures have names of PRINTER_INFO_x, where x is a
' number.
' ========================================================================================
FUNCTION GetPrinterDC () AS DWORD
LOCAL dwLevel AS DWORD
LOCAL dwFlags AS DWORD
LOCAL dwNeeded AS DWORD
LOCAL dwReturned AS DWORD
LOCAL hdc AS DWORD
LOCAL tos AS OSVERSIONINFO
LOCAL pinfo4 AS PRINTER_INFO_4 PTR
LOCAL pinfo5 AS PRINTER_INFO_5 PTR
dwLevel = 5
dwFlags = %PRINTER_ENUM_LOCAL
IF ISTRUE GetVersionEx(tos) THEN
IF tos.dwPlatformId = %VER_PLATFORM_WIN32_NT THEN
dwLevel = 4
dwFlags = %PRINTER_ENUM_NETWORK OR %PRINTER_ENUM_LOCAL
END IF
END IF
EnumPrinters dwFlags, "", dwLevel, BYVAL %NULL, 0, dwNeeded, dwReturned
IF dwLevel = 4 THEN
pInfo4 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo4, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", @pInfo4.@pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo4
ELSE
pInfo5 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo5, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", BYVAL @pInfo5.pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo5
END IF
FUNCTION = hdc
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL hdcPrint AS DWORD
szDocName = "FormFeed"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
hdcPrint = GetPrinterDC()
IF hdcPrint <> %NULL THEN
IF StartDoc(hdcPrint, dinfo) > 0 THEN
IF StartPage(hdcPrint) > 0 AND EndPage(hdcPrint) > 0 THEN
EndDoc hdcPrint
END IF
END IF
DeleteDC hdcPrint
END IF
FUNCTION = 0
END FUNCTION
' ========================================================================================
This program is a translation of GRAFMENU.C -- Demonstrates Bitmap Menu Items © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
You can also use bitmaps to display items in menus. If you immediately recoiled at the thought of pictures of file folders, paste jars, and trash cans in a menu, don't think of pictures. Think instead of how useful menu bitmaps might be for a drawing program. Think of using different fonts and font sizes, line widths, hatch patterns, and colors in your menus.
' ========================================================================================
' GRAFMENU.BAS
' This program is a translation/adaptation of GRAFMENU.C -- Demonstrates Bitmap Menu Items
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' You can also use bitmaps to display items in menus. If you immediately recoiled at the
' thought of pictures of file folders, paste jars, and trash cans in a menu, don't think
' of pictures. Think instead of how useful menu bitmaps might be for a drawing program.
' Think of using different fonts and font sizes, line widths, hatch patterns, and colors
' in your menus.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "grafmenu.res"
%IDM_FONT_COUR = 101
%IDM_FONT_ARIAL = 102
%IDM_FONT_TIMES = 103
%IDM_HELP = 104
%IDM_EDIT_UNDO = 40005
%IDM_EDIT_CUT = 40006
%IDM_EDIT_COPY = 40007
%IDM_EDIT_PASTE = 40008
%IDM_EDIT_CLEAR = 40009
%IDM_FILE_NEW = 40010
%IDM_FILE_OPEN = 40011
%IDM_FILE_SAVE = 40012
%IDM_FILE_SAVE_AS = 40013
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "GrafMenu"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Bitmap Menu Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' StretchBitmap: Scales bitmap to display resolution
' ========================================================================================
FUNCTION StretchBitmap (BYVAL hBitmap1 AS DWORD) AS DWORD
LOCAL bm1 AS BITMAP
LOCAL bm2 AS BITMAP
LOCAL hBitmap2 AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcMem1 AS DWORD
LOCAL hdcMem2 AS DWORD
LOCAL cxChar AS DWORD
LOCAL cyChar AS DWORD
' Get the width and height of a system font character
cxChar = LOWRD(GetDialogBaseUnits())
cyChar = HIWRD(GetDialogBaseUnits())
' Create 2 memory DCs compatible with the display
hdc = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
hdcMem1 = CreateCompatibleDC(hdc)
hdcMem2 = CreateCompatibleDC(hdc)
DeleteDC hdc
' Get the dimensions of the bitmap to be stretched
GetObject hBitmap1, SIZEOF(BITMAP), bm1
' Scale these dimensions based on the system font size
bm2 = bm1
bm2.bmWidth = (cxChar * bm2.bmWidth) / 4
bm2.bmHeight = (cyChar * bm2.bmHeight) / 8
bm2.bmWidthBytes = ((bm2.bmWidth + 15) / 16) * 2
' Create a new bitmap of larger size
hBitmap2 = CreateBitmapIndirect(bm2)
' Select the bitmaps in the memory DCs and do a StretchBlt
SelectObject hdcMem1, hBitmap1
SelectObject hdcMem2, hBitmap2
StretchBlt hdcMem2, 0, 0, bm2.bmWidth, bm2.bmHeight, _
hdcMem1, 0, 0, bm1.bmWidth, bm1.bmHeight, %SRCCOPY
' Clean up
DeleteDC hdcMem1
DeleteDC hdcMem2
DeleteObject hBitmap1
FUNCTION = hBitmap2
END FUNCTION
' ========================================================================================
' ========================================================================================
' GetBitmapFont: Creates bitmaps with font names
' ========================================================================================
FUNCTION GetBitmapFont (BYVAL i AS LONG) AS DWORD
DIM szFaceName(2) AS ASCIIZ * 256
LOCAL hBitmap AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcMem AS DWORD
LOCAL hFont AS DWORD
LOCAL tsize AS SIZE
LOCAL tm AS TEXTMETRIC
szFaceName(0) = "Courier New"
szFaceName(1) = "Arial"
szFaceName(2) = "Times New Roman"
hdc = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
GetTextMetrics hdc, tm
hdcMem = CreateCompatibleDC(hdc)
hFont = CreateFont (2 * tm.tmHeight, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, szFaceName(i))
hFont = SelectObject(hdcMem, hFont)
GetTextExtentPoint32 hdcMem, szFaceName(i), LEN(szFaceName(i)), tsize
hBitmap = CreateBitmap(tsize.cx, tsize.cy, 1, 1, BYVAL %NULL)
SelectObject hdcMem, hBitmap
TextOut hdcMem, 0, 0, szFaceName(i), LEN(szFaceName(i))
DeleteObject SelectObject(hdcMem, hFont)
DeleteDC hdcMem
DeleteDC hdc
FUNCTION = hBitmap
END FUNCTION
' ========================================================================================
' ========================================================================================
' DeleteAllBitmaps: Deletes all the bitmaps in the menu
' ========================================================================================
SUB DeleteAllBitmaps (BYVAL hwnd AS DWORD)
LOCAL hMenu AS DWORD
LOCAL i AS LONG
LOCAL mii AS MENUITEMINFO
mii.cbSize = SIZEOF(MENUITEMINFO)
mii.fMask = %MIIM_SUBMENU OR %MIIM_TYPE
' Delete Help bitmap on system menu
hMenu = GetSystemMenu(hwnd, %FALSE)
GetMenuItemInfo hMenu, %IDM_HELP, %FALSE, mii
DeleteObject mii.dwTypeData
' Delete top-level menu bitmaps
hMenu = GetMenu(hwnd)
FOR i = 0 TO 2
GetMenuItemInfo hMenu, i, %TRUE, mii
DeleteObject mii.dwTypeData
NEXT
' Delete bitmap items on Font menu
hMenu = mii.hSubMenu
FOR i = 0 TO 2
GetMenuItemInfo hMenu, i, %TRUE, mii
DeleteObject mii.dwTypeData
NEXT
END SUB
' ========================================================================================
' ========================================================================================
' AddHelpToSys: Adds bitmap Help item to system menu
' ========================================================================================
SUB AddHelpToSys (BYVAL hInstance AS DWORD, BYVAL hwnd AS DWORD)
LOCAL hBitmap AS DWORD
LOCAL hMenu AS DWORD
hMenu = GetSystemMenu(hwnd, %FALSE)
hBitmap = StretchBitmap(LoadBitmap (hInstance, "BitmapHelp"))
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, %MF_BITMAP, %IDM_HELP, BYVAL hBitmap
END SUB
' ========================================================================================
' ========================================================================================
' CreateMyMenu: Assembles menu from components
' ========================================================================================
FUNCTION CreateMyMenu (BYVAL hInstance AS DWORD) AS DWORD
LOCAL hBitmap AS DWORD
LOCAL hMenu AS DWORD
LOCAL hMenuPopup AS DWORD
LOCAL i AS LONG
hMenu = CreateMenu()
hMenuPopup = LoadMenu(hInstance, "MenuFile")
hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapFile"))
AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap
hMenuPopup = LoadMenu(hInstance, "MenuEdit")
hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapEdit"))
AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap
hMenuPopup = CreateMenu()
FOR i = 0 TO 2
hBitmap = GetBitmapFont(i)
AppendMenu hMenuPopup, %MF_BITMAP, %IDM_FONT_COUR + i, BYVAL hBitmap
NEXT
hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapFont"))
AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap
FUNCTION = hMenu
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hMenu AS DWORD
STATIC iCurrentFont AS LONG
STATIC hInstance AS DWORD
LOCAL lpc AS CREATESTRUCT PTR
SELECT CASE uMsg
CASE %WM_CREATE
iCurrentFont = %IDM_FONT_COUR
lpc = lParam
hInstance = @lpc.hInstance
AddHelpToSys hInstance, hwnd
hMenu = CreateMyMenu(hInstance)
SetMenu hwnd, hMenu
CheckMenuItem hMenu, iCurrentFont, %MF_CHECKED
EXIT FUNCTION
CASE %WM_SYSCOMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_HELP
MessageBox hwnd, "Help not yet implemented!", _
"GrafMenu", %MB_OK OR %MB_ICONEXCLAMATION
EXIT FUNCTION
END SELECT
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LOWRD(wParam)
CASE %IDM_FILE_NEW, _
%IDM_FILE_OPEN, _
%IDM_FILE_SAVE, _
%IDM_FILE_SAVE_AS, _
%IDM_EDIT_UNDO, _
%IDM_EDIT_CUT, _
%IDM_EDIT_COPY, _
%IDM_EDIT_PASTE, _
%IDM_EDIT_CLEAR
MessageBeep 0
EXIT FUNCTION
CASE %IDM_FONT_COUR, %IDM_FONT_ARIAL, %IDM_FONT_TIMES
hMenu = GetMenu(hwnd)
CheckMenuItem hMenu, iCurrentFont, %MF_UNCHECKED
iCurrentFont = LOWRD(wParam)
CheckMenuItem hMenu, iCurrentFont, %MF_CHECKED
EXIT FUNCTION
END SELECT
CASE %WM_DESTROY
DeleteALlBitmaps hwnd
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of GRAYS1.C -- Gray Shades © Charles Petzold, 1998, described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.
Does not use the Windows Palette Manager but instead tries to normally display 65 shades of gray as a "fountain" of color ranging black to white.
' ========================================================================================
' GRAYS1.BAS
' This program is a translation/adaptation of GRAYS1.C -- Gray Shades © Charles Petzold, 1998,
' described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.
' Does not use the Windows Palette Manager but instead tries to normally display 65 shades
' of gray as a "fountain" of color ranging black to white.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Grays1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Shades of Gray #1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Draw the fountain of grays
FOR i = 0 TO 64
rc.nLeft = i * cxClient / 65
rc.nTop = 0
rc.nRight = (i + 1) * cxClient / 65
rc.nBottom = cyClient
hBrush = CreateSolidBrush(RGB(MIN&(255, 4 * i), _
MIN&(255, 4 * i), _
MIN&(255, 4 * i)))
FillRect hdc, rc, hBrush
DeleteObject hBrush
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of GRAYS2.C -- Gray Shades Using Palette Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.
Demonstrates the most important Palette Manager functions and messages with little extraneous code.
' ========================================================================================
' GRAYS2.BAS
' This program is a translation/adaptatiopn of GRAYS2.C -- Gray Shades Using Palette
' Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book
' Programming Windows, 5th Edition.
' Demonstrates the most important Palette Manager functions and messages with little
' extraneous code.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Grays2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Shades of Gray #2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hPalette AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL plp AS LOGPALETTE PTR
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
' Set up a LOGPALETTE structure and create a palette
plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + 64 * SIZEOF(PALETTEENTRY))
@plp.palVersion = &H0300
@plp.palNumEntries = 65
FOR i = 0 TO 64
@plp.palPalEntry(i).peRed = MIN&(255, 4 * i)
@plp.palPalEntry(i).peGreen = MIN&(255, 4 * i)
@plp.palPalEntry(i).peBlue = MIN&(255, 4 * i)
@plp.palPalEntry(i).peFlags = 0
NEXT
hPalette = CreatePalette(BYVAL plp)
CoTaskMemFree plp
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Select and realize the palette in the device context
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
' Draw the fountain of grays
FOR i = 0 TO 64
rc.nLeft = i * cxClient / 64
rc.nTop = 0
rc.nRight = (i + 1) * cxClient / 64
rc.nBottom = cyClient
hBrush = CreateSolidBrush(PALETTERGB (MIN&(255, 4 * i), _
MIN&(255, 4 * i), _
MIN&(255, 4 * i)))
FillRect hdc, rc, hBrush
DeleteObject hBrush
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_QUERYNEWPALETTE
IF ISFALSE hPalette THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
InvalidateRect hwnd, BYVAL %NULL, %TRUE
ReleaseDC hwnd, hdc
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_PALETTECHANGED
IF ISFALSE hPalette OR wParam = hwnd THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
UpdateColors hdc
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hPalette
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of GRAYS3.C -- Gray Shades Using Palette Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.
Same as GRAYS2 but using a macro called PALETTEINDEX instead of PALETTERGB during %WM_PAINT processing.
' ========================================================================================
' GRAYS3.BAS
' This program is a translation/adaptation of GRAYS3.C -- Gray Shades Using Palette
' Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book
' Programming Windows, 5th Edition.
' Same as GRAYS2 but using a macro called PALETTEINDEX instead of PALETTERGB during
' %WM_PAINT processing.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Grays3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Shades of Gray #3"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hPalette AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL plp AS LOGPALETTE PTR
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
' Set up a LOGPALETTE structure and create a palette
plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + 64 * SIZEOF(PALETTEENTRY))
@plp.palVersion = &H0300
@plp.palNumEntries = 65
FOR i = 0 TO 64
@plp.palPalEntry(i).peRed = MIN&(255, 4 * i)
@plp.palPalEntry(i).peGreen = MIN&(255, 4 * i)
@plp.palPalEntry(i).peBlue = MIN&(255, 4 * i)
@plp.palPalEntry(i).peFlags = 0
NEXT
hPalette = CreatePalette(BYVAL plp)
CoTaskMemFree plp
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Select and realize the palette in the device context
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
' Draw the fountain of grays
FOR i = 0 TO 64
rc.nLeft = i * cxClient / 64
rc.nTop = 0
rc.nRight = (i + 1) * cxClient / 64
rc.nBottom = cyClient
hBrush = CreateSolidBrush(PALETTEINDEX(i))
FillRect hdc, rc, hBrush
DeleteObject hBrush
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_QUERYNEWPALETTE
IF ISFALSE hPalette THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
ReleaseDC hwnd, hdc
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_PALETTECHANGED
IF ISFALSE hPalette OR wParam = hwnd THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectPalette hdc, hPalette, %FALSE
RealizePalette hdc
UpdateColors hdc
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_DESTROY
DeleteObject hPalette
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of HEAD.C -- Displays beginning (head) of file © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.
A well-known UNIX utility named head displays the beginning lines of a file. Let's use a list box to write a similar program for Windows. HEAD lists all files and child subdirectories in the list box. It allows you to choose a file to display by double-clicking on the filename with the mouse or by pressing the Enter key when the filename is selected. You can also change the subdirectory using either of these methods. The program displays up to 8 KB of the beginning of the file in the right side of the client area of HEAD's window.
' ========================================================================================
' HEAD.BAS
' This program is a translation/adaptation of HEAD.C -- Displays beginning (head) of file
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' A well-known UNIX utility named head displays the beginning lines of a file. Let's use a
' list box to write a similar program for Windows. HEAD lists all files and child
' subdirectories in the list box. It allows you to choose a file to display by
' double-clicking on the filename with the mouse or by pressing the Enter key when the
' filename is selected. You can also change the subdirectory using either of these
' methods. The program displays up to 8 KB of the beginning of the file in the right side
' of the client area of HEAD's window.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_LIST = 1
%ID_TEXT = 2
%MAXREAD = 8192
%DIRATTR = %DDL_READWRITE OR %DDL_READONLY OR %DDL_HIDDEN OR %DDL_SYSTEM OR _
%DDL_DIRECTORY OR %DDL_ARCHIVE OR %DDL_DRIVES
%DTFLAGS = %DT_WORDBREAK OR %DT_EXPANDTABS OR %DT_NOCLIP OR %DT_NOPREFIX
GLOBAL OldList AS DWORD
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "head"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "head"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC bValidFile AS LONG
STATIC buffer AS ASCIIZ * %MAXREAD
STATIC hwndList AS DWORD
STATIC hwndText AS DWORD
STATIC rc AS RECT
STATIC szFile AS ASCIIZ * %MAX_PATH + 1
LOCAL hFile AS DWORD
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL cxChar AS LONG
LOCAL cyChar AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL szBuffer AS ASCIIZ * %MAX_PATH + 1
LOCAL szMask AS ASCIIZ * 4
SELECT CASE uMsg
CASE %WM_CREATE
cxChar = LO(WORD, GetDialogBaseUnits())
cyChar = HI(WORD, GetDialogBaseUnits())
rc.nLeft = 20 * cxChar
rc.nTop = 3 * cyChar
hwndList = CreateWindowEx(0, "Listbox", BYVAL %NULL, _
%WS_CHILDWINDOW OR %WS_VISIBLE OR %LBS_STANDARD, _
cxChar, cyChar * 3, _
cxChar * 13 + GetSystemMetrics(%SM_CXVSCROLL), _
cyChar * 10, _
hwnd, %ID_LIST, _
GetWindowLong(hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
GetCurrentDirectory %MAX_PATH + 1, szBuffer
hwndText = CreateWindowEx(0, "Static", szBuffer, _
%WS_CHILDWINDOW OR %WS_VISIBLE OR %SS_LEFT, _
cxChar, cyChar, cxChar * %MAX_PATH, cyChar, _
hwnd, %ID_TEXT, _
GetWindowLong(hwnd, %GWL_HINSTANCE), _
BYVAL %NULL)
OldList = SetWindowLong(hwndList, %GWL_WNDPROC, CODEPTR(ListProc))
szMask = "*.*"
SendMessage hwndList, %LB_DIR, %DIRATTR, VARPTR(szMask)
EXIT FUNCTION
CASE %WM_SIZE
rc.nRight = LO(WORD, lParam)
rc.nBottom = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_SETFOCUS
SetFocus hwndList
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
IF LO(WORD, wParam) = %ID_LIST AND HI(WORD, wParam) = %LBN_DBLCLK THEN
i = SendMessage(hwndList, %LB_GETCURSEL, 0, 0)
IF i = %LB_ERR THEN EXIT FUNCTION
SendMessage hwndList, %LB_GETTEXT, i, VARPTR(szBuffer)
hFile = CreateFile(szBuffer, %GENERIC_READ, %FILE_SHARE_READ, _
BYVAL %NULL, %OPEN_EXISTING, 0, %NULL)
IF hFile <> %INVALID_HANDLE_VALUE THEN
CloseHandle hFile
bValidFile = %TRUE
szFile = szBuffer
GetCurrentDirectory %MAX_PATH + 1, szBuffer
IF RIGHT$(szBuffer, 1) <> "\" THEN szBuffer = szBuffer + "\"
SetWindowText hwndText, szBuffer & szFile
ELSE
bValidFile = %FALSE
' If setting the directory doesn't work, maybe it's
' a drive change, so try that.
IF LEFT$(szBuffer, 2) ="[-" THEN szBuffer = MID$(szBuffer, 3)
IF RIGHT$(szBuffer, 2) ="-]" THEN szBuffer = LEFT$(szBuffer, LEN(szBuffer) - 2)
IF LEFT$(szBuffer, 1) ="[" THEN szBuffer = MID$(szBuffer, 2)
IF RIGHT$(szBuffer, 1) ="]" THEN szBuffer = LEFT$(szBuffer, LEN(szBuffer) - 1)
IF ISFALSE SetCurrentDirectory(szBuffer) THEN
szBuffer = szBuffer & ":\"
SetCurrentDirectory szBuffer
END IF
' Get the new directory name and fill the list box.
GetCurrentDirectory %MAX_PATH + 1, szBuffer
SetWindowText hwndText, szBuffer
SendMessage hwndList, %LB_RESETCONTENT, 0, 0
szMask = "*.*"
SendMessage hwndList, %LB_DIR, %DIRATTR, VARPTR(szMask)
END IF
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
SetTextColor hdc, GetSysColor(%COLOR_BTNTEXT)
SetBkColor hdc, GetSysColor(%COLOR_BTNFACE)
IF bValidFile THEN
hFile = CreateFile(szFile, %GENERIC_READ, %FILE_SHARE_READ, _
BYVAL %NULL, %OPEN_EXISTING, 0, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN
bValidFile = %FALSE
EXIT FUNCTION
END IF
ReadFile hFile, buffer, %MAXREAD, i, BYVAL %NULL
CloseHandle hFile
' i now equals the number of bytes in buffer.
' Commence getting a device context for displaying text.
' Assume the file is ASCII
DrawText hdc, buffer, i, rc, %DTFLAGS
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
SetWindowLong hwndList, %GWL_WNDPROC, OldList
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' ListgBox callback function
' ========================================================================================
FUNCTION ListProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
IF uMsg = %WM_KEYDOWN AND wParam = %VK_RETURN THEN
SendMessage GetParent(hwnd), %WM_COMMAND, MAKLNG(1, %LBN_DBLCLK), hwnd
END IF
FUNCTION = CallWindowProc(OldList, hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of HELLOBIT.C -- Bitmap Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
The program displays the text string "Hello, world!" on a small bitmap and then does a BitBlt or a StretchBlt (based on a menu selection) from the bitmap to the program's client area.
' ========================================================================================
' HELLOBIT.BAS
' This program is a translation/adaptation of HELLOBIT.C -- Bitmap Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The program displays the text string "Hello, world!" on a small bitmap and then does a
' BitBlt or a StretchBlt (based on a menu selection) from the bitmap to the program's
' client area.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "hellobit.res"
%IDM_BIG = 40001
%IDM_SMALL = 40002
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "HelloBit"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "HelloBit"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hBitmap AS DWORD
STATIC hdcMem AS DWORD
STATIC cxBitmap AS LONG
STATIC cyBitmap AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC iSize AS LONG
STATIC szText AS ASCIIZ * 256
LOCAL hdc AS DWORD
LOCAL hMenu AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL tsize AS SIZE
SELECT CASE uMsg
CASE %WM_CREATE
szText = "Hello, world!"
iSize = %IDM_BIG
hdc = GetDC(hwnd)
hdcMem = CreateCompatibleDC(hdc)
GetTextExtentPoint32 hdc, szText, LEN(szText), tsize
cxBitmap = tsize.cx
cyBitmap = tsize.cy
hBitmap = CreateCompatibleBitmap(hdc, cxBitmap, cyBitmap)
ReleaseDC hwnd, hdc
SelectObject hdcMem, hBitmap
TextOut hdcMem, 0, 0, szText, LEN(szText)
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_BIG, %IDM_SMALL
hMenu = GetMenu(hwnd)
CheckMenuItem hMenu, iSize, %MF_UNCHECKED
iSize = LOWRD(wParam)
CheckMEnuItem hMenu, iSize, %MF_CHECKED
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SELECT CASE iSize
CASE %IDM_BIG
StretchBlt hdc, 0, 0, cxClient, cyClient, _
hdcMem, 0, 0, cxBitmap, cyBitmap, %SRCCOPY
CASE %IDM_SMALL
FOR y = 0 TO cyClient - 1 STEP cyBitmap
FOR x = 0 TO cxClient - 1 STEP cxBitmap
BitBlt hdc, x, y, cxBitmap, cyBitmap, hdcMem, 0, 0, %SRCCOPY
NEXT
NEXT
END SELECT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteDC hdcMem
DeleteObject hBitmap
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the HELLOWIN.C program © Charles Petzold, 1998, described and analysed in Chapter 3 of the book Programming Windows, 5th Edition.
Creating a window first requires registering a window class, and that requires a window procedure to process messages to the window. This involves a bit of overhead that appears in almost every Windows program. The HELLOWIN program is a simple program showing mostly that overhead.
' ========================================================================================
' HELLOWIN.BAS
' This program is a translation/adaptation of the HELLOWIN.C program © Charles Petzold, 1998,
' described and analysed in Chapter 3 of the book Programming Windows, 5th Edition.
' Creating a window first requires registering a window class, and that requires a window
' procedure to process messages to the window. This involves a bit of overhead that
' appears in almost every Windows program. The HELLOWIN program is a simple program
' showing mostly that overhead.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "HelloWin"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
"The Hello Program", _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
PlaySound "hellowin.wav", %NULL, %SND_FILENAME OR %SND_ASYNC
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
DrawText hdc, "Hello, Windows!", -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of HEXCALC.C -- Hexadecimal Calculator © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.
Perhaps the epitome of lazy programming is the HEXCALC program. This program doesn't call CreateWindow at all, never processes WM_PAINT messages, never obtains a device context, and never processes mouse messages. Yet it manages to incorporate a 10-function hexadecimal calculator with a full keyboard and mouse interface in fewer than 150 lines of source code.
' ========================================================================================
' HEXCALC.BAS
' This program is a translation/adaptation of HEXCALC.C -- Hexadecimal Calculator
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Perhaps the epitome of lazy programming is the HEXCALC program. This program doesn't
' call CreateWindow at all, never processes WM_PAINT messages, never obtains a device
' context, and never processes mouse messages. Yet it manages to incorporate a 10-function
' hexadecimal calculator with a full keyboard and mouse interface in fewer than 150 lines
' of source code.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "CRT.inc"
#RESOURCE RES, "hexcalc.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "HexCalc"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = %DLGWINDOWEXTRA ' // Note!
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = %COLOR_BTNFACE + 1
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateDialog(hInstance, szAppName, 0, %NULL)
ShowWindow hwnd, iCmdShow
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB ShowNumber (BYVAL hwnd AS DWORD, BYVAL iNumber AS DWORD)
' LOCAL szBuffer AS ASCIIZ * 20
' wsprintf szBuffer, "%X", BYVAL iNumber
' SetDlgItemText hwnd, %VK_ESCAPE, szBuffer
SetDlgItemText hwnd, %VK_ESCAPE, HEX$(iNumber)
END SUB
' ========================================================================================
' ========================================================================================
FUNCTION CalcIt (BYVAL iFirstNum AS DWORD, BYVAL iOperation AS LONG, BYVAL iNum AS DWORD) AS DWORD
SELECT CASE CHR$(iOperation)
CASE "=": FUNCTION = iNum
CASE "+": FUNCTION = iFirstNum + iNum
CASE "-": FUNCTION = iFirstNum - iNum
CASE "*": FUNCTION = iFirstNum * iNum
CASE "&": FUNCTION = iFirstNum AND iNum
CASE "|": FUNCTION = iFirstNum OR iNum
CASE "^": FUNCTION = iFirstNum ^ iNum
CASE "<": SHIFT LEFT iFirstNum, iNum : FUNCTION = iFirstNum
CASE ">": SHIFT RIGHT iFirstNum, iNum : FUNCTION = iFirstNum
CASE "/": FUNCTION = IIF&(iNum = 0, %MAXDWORD, iFirstNum \ iNum)
CASE "%": FUNCTION = IIF&(iNum = 0, %MAXDWORD, iFirstNum MOD iNum)
CASE ELSE : FUNCTION = 0
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC bNewNumber AS LONG
STATIC iOperation AS LONG
STATIC iNumber AS DWORD
STATIC iFirstNum AS DWORD
LOCAL hButton AS DWORD
LOCAL dwTemp AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
bNewNumber = %TRUE
iOperation = ASC("=")
EXIT FUNCTION
CASE %WM_KEYDOWN ' left arrow --> backspace
IF wParam <> %VK_LEFT THEN EXIT FUNCTION
SendMessage hwnd, %WM_CHAR, %VK_BACK, 0
CASE %WM_CHAR
wParam = ASC(UCASE$(CHR$(wParam)))
IF wParam = %VK_RETURN THEN wParam = ASC("=")
hButton = GetDlgItem(hwnd, wParam)
IF hButton THEN
SendMessage hButton, %BM_SETSTATE, 1, 0
ApiSleep 100
SendMessage hButton, %BM_SETSTATE, 0, 0
ELSE
MessageBeep 0
END IF
SendMessage hwnd, %WM_COMMAND, wParam, 0
CASE %WM_COMMAND
SetFocus hwnd
IF LO(WORD, wParam) = %VK_BACK THEN ' backspace
iNumber = iNumber \ 16
ShowNumber hwnd, iNumber
ELSEIF LO(WORD, wParam) = %VK_ESCAPE THEN ' escape
iNumber = 0
ShowNumber hwnd, iNumber
ELSEIF isxdigit(LO(WORD, wParam)) THEN ' hex digit
IF bNewNumber THEN
iFirstNum = iNumber
iNumber = 0
END IF
bNewNumber = %FALSE
dwTemp = %MAXDWORD
SHIFT RIGHT dwTemp, 4
IF iNumber <= dwTemp THEN
iNumber = 16 * iNumber + wParam - IIF&(isdigit(wParam), ASC("0"), ASC("A") - 10)
ShowNumber hwnd, iNumber
ELSE
MessageBeep 0
END IF
ELSE ' operation
IF ISFALSE bNewNumber THEN
iNumber = CalcIt (iFirstNum, iOperation, iNumber)
ShowNumber hwnd, iNumber
END IF
bNewNumber = %TRUE
iOperation = LO(WORD, wParam)
END IF
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
HEXCALC.RC
#define WS_OVERLAPPED 0x00000000L
#define WS_CAPTION 0x00C00000L /* WS_BORDER | WS_DLGFRAME */
#define WS_SYSMENU 0x00080000L
#define WS_MINIMIZEBOX 0x00020000L
/////////////////////////////////////////////////////////////////////////////
// Icon
HEXCALC ICON DISCARDABLE "HexCalc.ico"
/*---------------------------
HEXCALC.DLG dialog script
---------------------------*/
HexCalc DIALOG -1, -1, 102, 122
STYLE WS_OVERLAPPED | WS_CAPTION | WS_SYSMENU | WS_MINIMIZEBOX
CLASS "HexCalc"
CAPTION "Hex Calculator"
{
PUSHBUTTON "D", 68, 8, 24, 14, 14
PUSHBUTTON "A", 65, 8, 40, 14, 14
PUSHBUTTON "7", 55, 8, 56, 14, 14
PUSHBUTTON "4", 52, 8, 72, 14, 14
PUSHBUTTON "1", 49, 8, 88, 14, 14
PUSHBUTTON "0", 48, 8, 104, 14, 14
PUSHBUTTON "0", 27, 26, 4, 50, 14
PUSHBUTTON "E", 69, 26, 24, 14, 14
PUSHBUTTON "B", 66, 26, 40, 14, 14
PUSHBUTTON "8", 56, 26, 56, 14, 14
PUSHBUTTON "5", 53, 26, 72, 14, 14
PUSHBUTTON "2", 50, 26, 88, 14, 14
PUSHBUTTON "Back", 8, 26, 104, 32, 14
PUSHBUTTON "C", 67, 44, 40, 14, 14
PUSHBUTTON "F", 70, 44, 24, 14, 14
PUSHBUTTON "9", 57, 44, 56, 14, 14
PUSHBUTTON "6", 54, 44, 72, 14, 14
PUSHBUTTON "3", 51, 44, 88, 14, 14
PUSHBUTTON "+", 43, 62, 24, 14, 14
PUSHBUTTON "-", 45, 62, 40, 14, 14
PUSHBUTTON "*", 42, 62, 56, 14, 14
PUSHBUTTON "/", 47, 62, 72, 14, 14
PUSHBUTTON "%", 37, 62, 88, 14, 14
PUSHBUTTON "Equals", 61, 62, 104, 32, 14
PUSHBUTTON "&&", 38, 80, 24, 14, 14
PUSHBUTTON "|", 124, 80, 40, 14, 14
PUSHBUTTON "^", 94, 80, 56, 14, 14
PUSHBUTTON "<", 60, 80, 72, 14, 14
PUSHBUTTON ">", 62, 80, 88, 14, 14
}
This program is a translation of ICONDEMO.C -- Icon Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
Displays the icon in its client area, repeated horizontally and vertically.
' ========================================================================================
' ICONDEMO.BAS
' This program is a translation/adaptation of ICONDEMO.C -- Icon Demonstration Program
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' Displays the icon in its client area, repeated horizontally and vertically.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "icondemo.res"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "IconDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Icon Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hIcon AS DWORD
STATIC cxIcon AS DWORD
STATIC cyIcon AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL hInstance AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL lpc AS CREATESTRUCT PTR
SELECT CASE uMsg
CASE %WM_CREATE
lpc = lParam
hInstance = @lpc.hInstance
hIcon = LoadIcon (hInstance, "IDI_ICON")
cxIcon = GetSystemMetrics(%SM_CXICON)
cyIcon = GetSystemMetrics(%SM_CYICON)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR y = 0 TO cyClient - 1 STEP cyIcon
FOR x = 0 TO cxClient - 1 STEP cxIcon
DrawIcon hdc, x, y, hIcon
NEXT
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of JUSTIFY1.C -- Justified Type Program #1 © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
' ========================================================================================
' JUSTIFY1.BAS
' This program is a translation/adaptation of JUSTIFY1.C -- Justified Type Program #1
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "justify1.res"
GLOBAL szAppName AS ASCIIZ * 256
%IDM_FILE_PRINT = 40001
%IDM_FONT = 40002
%IDM_ALIGN_LEFT = 40003
%IDM_ALIGN_RIGHT = 40004
%IDM_ALIGN_CENTER = 40005
%IDM_ALIGN_JUSTIFIED = 40006
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Justify1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Justified Type #1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, rc AS RECT)
DIM iRuleSize(15) AS LONG
ARRAY ASSIGN iRuleSize() = 360, 72, 144, 72, 216, 72, 144, 72, 288, 72, 144, 72, 216, 72, 144, 72
LOCAL i AS LONG
LOCAL j AS LONG
LOCAL ptClient AS POINT
SaveDC hdc
' Set Logical Twips mapping mode
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
SetViewportExtEx hdc, GetDeviceCaps(hdc, %LOGPIXELSX), _
GetDeviceCaps(hdc, %LOGPIXELSY), BYVAL %NULL
' Move the origin to a half inch from upper left
SetWindowOrgEx hdc, -720, -720, BYVAL %NULL
' Find the right margin (quarter inch from right)
ptClient.x = rc.nRight
ptClient.y = rc.nBottom
DPtoLP hdc, ptClient, 1
ptClient.x = ptClient.x - 360
' Draw the rulers
MoveToEx hdc, 0, -360, BYVAL %NULL
LineTo hdc, ptClient.x, -360
MoveToEx hdc, -360, 0, BYVAL %NULL
LineTo hdc, -360, ptClient.y
FOR i = 0 TO ptClient.x STEP 1440 \ 16
MoveToEx hdc, i, -360, BYVAL %NULL
LineTo hdc, i, -360 - iRuleSize (j MOD 16)
INCR j
NEXT
j = 0
FOR i = 0 TO ptClient.y STEP 1440 \ 16
MoveToEx hdc, -360, i, BYVAL %NULL
LineTo hdc, -360 - iRuleSize (j MOD 16), i
INCR j
NEXT
RestoreDC hdc, -1
END SUB
' ========================================================================================
' ========================================================================================
SUB Justify (BYVAL hdc AS DWORD, szText AS ASCIIZ, rc AS RECT, BYVAL iAlign AS LONG)
LOCAL xStart AS LONG
LOCAL yStart AS LONG
LOCAL cSpaceChars AS LONG
LOCAL pText AS BYTE PTR
LOCAL pBegin AS BYTE PTR
LOCAL pEnd AS BYTE PTR
LOCAL tsize AS SIZE
pText = VARPTR(szText)
yStart = rc.nTop
DO ' for each text line
cSpaceChars = 0 ' initialize number of spaces in line
WHILE @pText = 32 ' skip over leading spaces
INCR pText
WEND
pBegin = pText ' set pointer to char at beginning of
DO ' until the line is known
pEnd = pText ' set pointer to char at end of line
' skip to next space
WHILE @pText <> 0 AND @pText <> 32
INCR pText
WEND
IF @pText = 0 THEN EXIT DO
INCR pText
' after each space encountered, calculate extents
INCR cSpaceChars
GetTextExtentPoint32 hdc, BYVAL pBegin, pText - pBegin - 1, tsize
LOOP WHILE tsize.cx < rc.nRight - rc.nLeft
DECR cSpaceChars ' discount last space at end of line
WHILE @pEnd - 1 = 32 ' eliminate trailing spaces
DECR pEnd
DECR cSpaceChars
WEND
' if end of text and no space characters, set pEnd to end
IF @pText = 0 OR cSpaceChars <= 0 THEN pEnd = pText
GetTextExtentPoint32 hdc, BYVAL pBegin, pEnd - pBegin, tsize
SELECT CASE iAlign
CASE %IDM_ALIGN_LEFT
xStart = rc.nLeft
CASE %IDM_ALIGN_RIGHT
xStart = rc.nRight - tsize.cx
CASE %IDM_ALIGN_CENTER
xStart = (rc.nRight + rc.nLeft - tsize.cx) \ 2
CASE %IDM_ALIGN_JUSTIFIED
IF @pText <> 0 AND cSpaceChars > 0 THEN
SetTextJustification hdc, rc.nRight - rc.nLeft - tsize.cx, cSpaceChars
xStart = rc.nLeft
END IF
END SELECT
' display the text
TextOut hdc, xStart, yStart, BYVAL pBegin, pEnd - pBegin
' prepare for next line
IF @pText <> 0 THEN
SetTextJustification hdc, 0, 0
yStart = yStart + tsize.cy
pText = pEnd
END IF
LOOP WHILE @pText <> 0 AND yStart < rc.nBottom - tsize.cy
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cf AS CHOOSEFONTAPI
STATIC dinfo AS DOCINFO
STATIC iAlign AS LONG
STATIC lf AS LOGFONT
STATIC pd AS PRINTDLGAPI
STATIC szText AS ASCIIZ * 2048
STATIC szDocName AS ASCIIZ * 256
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL hMenu AS DWORD
LOCAL iSavePointSize AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
szText = "You don't know about me, without you " & _
"have read a book by the name of " & $DQ & "The " & _
"Adventures of Tom Sawyer," & $DQ & " but that " & _
"ain't no matter. That book was made by " & _
"Mr. Mark Twain, and he told the truth, " & _
"mainly. There was things which he " & _
"stretched, but mainly he told the truth. " & _
"That is nothing. I never seen anybody " & _
"but lied, one time or another, without " & _
"it was Aunt Polly, or the widow, or " & _
"maybe Mary. Aunt Polly -- Tom's Aunt " & _
"Polly, she is -- and Mary, and the Widow " & _
"Douglas, is all told about in that book " & _
"-- which is mostly a true book; with " & _
"some stretchers, as I said before."
iAlign = %IDM_ALIGN_LEFT
szDocName = "Justify1: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
' Initialize the CHOOSEFONT structure
GetObject GetStockObject(%SYSTEM_FONT), SIZEOF(lf), lf
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hwnd
cf.hDC = %NULL
cf.lpLogFont = VARPTR(lf)
cf.iPointSize = 0
cf.Flags = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS OR %CF_EFFECTS
cf.rgbColors = 0
cf.lCustData = 0
cf.lpfnHook = %NULL
cf.lpTemplateName = %NULL
cf.hInstance = %NULL
cf.lpszStyle = %NULL
cf.nFontType = 0
cf.nSizeMin = 0
cf.nSizeMax = 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
hMenu = GetMenu(hwnd)
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_PRINT
' Get printer DC
pd.lStructSize = SIZEOF(PRINTDLGAPI)
pd.hwndOwner = hwnd
pd.Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
IF ISFALSE PrintDlg(pd) THEN EXIT FUNCTION
hdcPrn = pd.hDC
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", _
szAppName, %MB_ICONEXCLAMATION OR %MB_OK
EXIT FUNCTION
END IF
' Set margins of 1 inch
rc.nLeft = GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
rc.nTop = GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
rc.nRight = GetDeviceCaps(hdcPrn, %PHYSICALWIDTH) - _
GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
rc.nBottom = GetDeviceCaps(hdcPrn, %PHYSICALHEIGHT) - _
GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
' Display text on printer
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
fSuccess = %FALSE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
' Select font using adjusted lfHeight
iSavePointSize = lf.lfHeight
lf.lfHeight = -(GetDeviceCaps (hdcPrn, %LOGPIXELSY) * _
cf.iPointSize) \ 720
SelectObject hdcPrn, CreateFontIndirect(lf)
lf.lfHeight = iSavePointSize
' Set text color
SetTextColor hdcPrn, cf.rgbColors
' Display text
Justify hdcPrn, szText, rc, iAlign
IF EndPage(hdcPrn) > 0 THEN
fSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
DeleteDC hdcPrn
IF ISFALSE fSuccess THEN
MessageBox hwnd, "Could not print text", _
szAppName, %MB_ICONEXCLAMATION OR %MB_OK
END IF
CASE %IDM_FONT
IF ChooseFont(cf) THEN
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_ALIGN_LEFT, %IDM_ALIGN_RIGHT, %IDM_ALIGN_CENTER, %IDM_ALIGN_JUSTIFIED
CheckMenuItem hMenu, iAlign, %MF_UNCHECKED
iAlign = LO(WORD, wParam)
CheckMenuItem hMenu, iAlign, %MF_CHECKED
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
DrawRuler hdc, rc
rc.nLeft = rc.nLeft + GetDeviceCaps(hdc, %LOGPIXELSX) \ 2
rc.nTop = rc.nTop + GetDeviceCaps (hdc, %LOGPIXELSY) \ 2
rc.nRight = rc.nRight - GetDeviceCaps(hdc, %LOGPIXELSX) \ 4
SelectObject hdc, CreateFontIndirect(lf)
SetTextColor hdc, cf.rgbColors
Justify hdc, szText, rc, iAlign
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
JUSTIFY1.RC
#define IDM_FILE_PRINT 40001
#define IDM_FONT 40002
#define IDM_ALIGN_LEFT 40003
#define IDM_ALIGN_RIGHT 40004
#define IDM_ALIGN_CENTER 40005
#define IDM_ALIGN_JUSTIFIED 40006
/////////////////////////////////////////////////////////////////////////////
// Menu
JUSTIFY1 MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print", IDM_FILE_PRINT
END
POPUP "&Font"
BEGIN
MENUITEM "&Font...", IDM_FONT
END
POPUP "&Align"
BEGIN
MENUITEM "&Left", IDM_ALIGN_LEFT, CHECKED
MENUITEM "&Right", IDM_ALIGN_RIGHT
MENUITEM "&Centered", IDM_ALIGN_CENTER
MENUITEM "&Justified", IDM_ALIGN_JUSTIFIED
END
END
This program is a translation of JUSTIFY2.C -- Justified Type Program #2 © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
The code in JUSTIFY2 is based on a program called TTJUST ("TrueType Justify") written by Microsoft's David Weise, which was in turn based on a version of the JUSTIFY1 program in an earlier edition of this book. To symbolize the increased complexity of this program, the Mark Twain excerpt has been replaced with the first paragraph from Herman Melville's Moby-Dick. JUSTIFY2 works with TrueType fonts only.
' ========================================================================================
' JUSTIFY2.BAS
' This program is a translation/adaptation of JUSTIFY2.C -- Justified Type Program #2
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The code in JUSTIFY2 is based on a program called TTJUST ("TrueType Justify") written by
' Microsoft's David Weise, which was in turn based on a version of the JUSTIFY1 program in
' an earlier edition of this book. To symbolize the increased complexity of this program,
' the Mark Twain excerpt has been replaced with the first paragraph from Herman Melville's
' Moby-Dick. JUSTIFY2 works with TrueType fonts only.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "justify2.res"
%OUTWIDTH = 6 ' Width of formatted output in inches
%LASTCHAR = 127 ' Last character code used in text
GLOBAL szAppName AS ASCIIZ * 256
%IDM_FILE_PRINT = 40001
%IDM_FONT = 40002
%IDM_ALIGN_LEFT = 40003
%IDM_ALIGN_RIGHT = 40004
%IDM_ALIGN_CENTER = 40005
%IDM_ALIGN_JUSTIFIED = 40006
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Justify2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Justified Type #2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, rc AS RECT)
DIM iRuleSize(15) AS LONG
ARRAY ASSIGN iRuleSize() = 360, 72, 144, 72, 216, 72, 144, 72, 288, 72, 144, 72, 216, 72, 144, 72
LOCAL i AS LONG
LOCAL j AS LONG
LOCAL ptClient AS POINT
SaveDC hdc
' Set Logical Twips mapping mode
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
SetViewportExtEx hdc, GetDeviceCaps(hdc, %LOGPIXELSX), _
GetDeviceCaps(hdc, %LOGPIXELSY), BYVAL %NULL
' Move the origin to a half inch from upper left
SetWindowOrgEx hdc, -720, -720, BYVAL %NULL
' Find the right margin (quarter inch from right)
ptClient.x = rc.nRight
ptClient.y = rc.nBottom
DPtoLP hdc, ptClient, 1
ptClient.x = ptClient.x - 360
' Draw the rulers
MoveToEx hdc, 0, -360, BYVAL %NULL
LineTo hdc, %OUTWIDTH * 1440, -360
MoveToEx hdc, -360, 0, BYVAL %NULL
LineTo hdc, -360, ptClient.y
FOR i = 0 TO ptClient.x STEP 1440 \ 16
IF i > %OUTWIDTH * 1440 THEN EXIT FOR
MoveToEx hdc, i, -360, BYVAL %NULL
LineTo hdc, i, -360 - iRuleSize (j MOD 16)
INCR j
NEXT
j = 0
FOR i = 0 TO ptClient.y STEP 1440 \ 16
MoveToEx hdc, -360, i, BYVAL %NULL
LineTo hdc, -360 - iRuleSize (j MOD 16), i
INCR j
NEXT
RestoreDC hdc, -1
END SUB
' ========================================================================================
' ========================================================================================
' GetCharDesignWidths: Gets character widths for font as large as the
' original design size
' ========================================================================================
FUNCTION GetCharDesignWidths (BYVAL hdc AS DWORD, BYVAL uFirst AS DWORD, BYVAL uLast AS DWORD, BYVAL piWidths AS LONG) AS DWORD
LOCAL hFont AS DWORD
LOCAL hFontDesign AS DWORD
LOCAL lf AS LOGFONT
LOCAL otm AS OUTLINETEXTMETRIC
hFont = GetCurrentObject(hdc, %OBJ_FONT)
GetObject hFont, SIZEOF(LOGFONT), lf
' Get outline text metrics (we'll only be using a field that is
' independent of the DC the font is selected into)
otm.otmSize = SIZEOF(OUTLINETEXTMETRIC)
GetOutlineTextMetrics hdc, SIZEOF(OUTLINETEXTMETRIC), otm
' Create a new font based on the design size
lf.lfHeight = - otm.otmEMSquare
lf.lfWidth = 0
hFontDesign = CreateFontIndirect(lf)
' Select the font into the DC and get the character widths
SaveDC hdc
SetMapMode hdc, %MM_TEXT
SelectObject hdc, hFontDesign
GetCharWidth hdc, uFirst, uLast, BYVAL piWidths
SelectObject hdc, hFont
RestoreDC hdc, -1
' Clean up
DeleteObject hFontDesign
FUNCTION = otm.otmEMSquare
END FUNCTION
' ========================================================================================
' ========================================================================================
' GetScaledWidths: Gets floating point character widths for selected
' font size
' ========================================================================================
SUB GetScaledWidths (BYVAL hdc AS DWORD, pdWidths() AS DOUBLE)
LOCAL dScale AS DOUBLE
LOCAL hFont AS DWORD
DIM aiDesignWidths(0 TO %LASTCHAR) AS LONG
LOCAL i AS LONG
LOCAL lf AS LOGFONT
LOCAL uEMSquare AS DWORD
' Call function above
uEMSquare = GetCharDesignWidths(hdc, 0, %LASTCHAR, VARPTR(aiDesignWidths(0)))
' Get LOGFONT for current font in device context
hFont = GetCurrentObject(hdc, %OBJ_FONT)
GetObject hFont, SIZEOF(LOGFONT), lf
' Scale the widths and store as floating point values
dScale = -lf.lfHeight / uEMSquare
FOR i = 0 TO %LASTCHAR
pdWidths(i) = dScale * aiDesignWidths(i)
NEXT
END SUB
' ========================================================================================
' ========================================================================================
' GetTextExtentFloat: Calculates text width in floating point
' ========================================================================================
FUNCTION GetTextExtentFloat (pdWidths() AS DOUBLE, BYVAL psText AS BYTE PTR, BYVAL iCount AS LONG) AS DOUBLE
LOCAL dWidth AS DOUBLE
LOCAL i AS LONG
FOR i = 0 TO iCount - 1
dWidth = dWidth + pdWidths(@psText[i])
NEXT
FUNCTION = dWidth
END FUNCTION
' ========================================================================================
' ========================================================================================
' Justify: Based on design units for screen/printer compatibility
' ========================================================================================
SUB Justify (BYVAL hdc AS DWORD, szText AS ASCIIZ, rc AS RECT, BYVAL iAlign AS LONG)
LOCAL dWidth AS DOUBLE
DIM adWidths(0 TO %LASTCHAR) AS DOUBLE
LOCAL xStart AS LONG
LOCAL yStart AS LONG
LOCAL cSpaceChars AS LONG
LOCAL pText AS BYTE PTR
LOCAL pBegin AS BYTE PTR
LOCAL pEnd AS BYTE PTR
LOCAL tsize AS SIZE
' Fill the adWidths array with floating point character widths
GetScaledWidths hdc, adWidths()
' Call this function just once to get size.cy (font height)
GetTextExtentPoint32 hdc, szText, 1, tsize
pText = VARPTR(szText)
yStart = rc.nTop
DO ' for each text line
cSpaceChars = 0 ' initialize number of spaces in line
WHILE @pText = 32 ' skip over leading spaces
INCR pText
WEND
pBegin = pText ' set pointer to char at beginning of
DO ' until the line is known
pEnd = pText ' set pointer to char at end of line
' skip to next space
WHILE @pText <> 0 AND @pText <> 32
INCR pText
WEND
IF @pText = 0 THEN EXIT DO
INCR pText
' after each space encountered, calculate extents
INCR cSpaceChars
dWidth = GetTextExtentFloat(adWidths(), BYVAL pBegin, pText - pBegin - 1)
LOOP WHILE dWidth < (rc.nRight - rc.nLeft)
DECR cSpaceChars ' discount last space at end of line
WHILE @pEnd - 1 = 32 ' eliminate trailing spaces
DECR pEnd
DECR cSpaceChars
WEND
' if end of text and no space characters, set pEnd to end
IF @pText = 0 OR cSpaceChars <= 0 THEN pEnd = pText
' Now get integer extents
GetTextExtentPoint32 hdc, BYVAL pBegin, pEnd - pBegin, tsize
SELECT CASE iAlign
CASE %IDM_ALIGN_LEFT
xStart = rc.nLeft
CASE %IDM_ALIGN_RIGHT
xStart = rc.nRight - tsize.cx
CASE %IDM_ALIGN_CENTER
xStart = (rc.nRight + rc.nLeft - tsize.cx) \ 2
CASE %IDM_ALIGN_JUSTIFIED
IF @pText <> 0 AND cSpaceChars > 0 THEN
SetTextJustification hdc, rc.nRight - rc.nLeft - tsize.cx, cSpaceChars
xStart = rc.nLeft
END IF
END SELECT
' display the text
TextOut hdc, xStart, yStart, BYVAL pBegin, pEnd - pBegin
' prepare for next line
IF @pText <> 0 THEN
SetTextJustification hdc, 0, 0
yStart = yStart + tsize.cy
pText = pEnd
END IF
LOOP WHILE @pText <> 0 AND yStart < (rc.nBottom - tsize.cy)
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cf AS CHOOSEFONTAPI
STATIC dinfo AS DOCINFO
STATIC iAlign AS LONG
STATIC lf AS LOGFONT
STATIC pd AS PRINTDLGAPI
STATIC szText AS ASCIIZ * 2048
STATIC szDocName AS ASCIIZ * 256
LOCAL szFontName AS ASCIIZ * 256
LOCAL fSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL hMenu AS DWORD
LOCAL iSavePointSize AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
szText = "Call me Ishmael. Some years ago -- never " & _
"mind how long precisely -- having little " & _
"or no money in my purse, and nothing " & _
"particular to interest me on shore, I " & _
"thought I would sail about a little and " & _
"see the watery part of the world. It is " & _
"a way I have of driving off the spleen, " & _
"and regulating the circulation. Whenever " & _
"I find myself growing grim about the " & _
"mouth; whenever it is a damp, drizzly " & _
"November in my soul; whenever I find " & _
"myself involuntarily pausing before " & _
"coffin warehouses, and bringing up the " & _
"rear of every funeral I meet; and " & _
"especially whenever my hypos get such an " & _
"upper hand of me, that it requires a " & _
"strong moral principle to prevent me " & _
"from deliberately stepping into the " & _
"street, and methodically knocking " & _
"people's hats off -- then, I account it " & _
"high time to get to sea as soon as I " & _
"can. This is my substitute for pistol " & _
"and ball. With a philosophical flourish " & _
"Cato throws himself upon his sword; I " & _
"quietly take to the ship. There is " & _
"nothing surprising in this. If they but " & _
"knew it, almost all men in their degree, " & _
"some time or other, cherish very nearly " & _
"the same feelings towards the ocean with " & _
"me."
iAlign = %IDM_ALIGN_LEFT
szDocName = "Justify2: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
' Initialize the CHOOSEFONT structure
hdc = GetDC(hwnd)
lf.lfHeight = - GetDeviceCaps(hdc, %LOGPIXELSY) \ 6
lf.lfFaceName = "Times New Roman"
ReleaseDC hwnd, hdc
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hwnd
cf.hDC = %NULL
cf.lpLogFont = VARPTR(lf)
cf.iPointSize = 0
cf.Flags = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS OR _
%CF_TTONLY OR %CF_EFFECTS
cf.rgbColors = 0
cf.lCustData = 0
cf.lpfnHook = %NULL
cf.lpTemplateName = %NULL
cf.hInstance = %NULL
cf.lpszStyle = %NULL
cf.nFontType = 0
cf.nSizeMin = 0
cf.nSizeMax = 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
hMenu = GetMenu(hwnd)
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_PRINT
' Get printer DC
pd.lStructSize = SIZEOF(PRINTDLGAPI)
pd.hwndOwner = hwnd
pd.Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
IF ISFALSE PrintDlg(pd) THEN EXIT FUNCTION
hdcPrn = pd.hDC
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", _
szAppName, %MB_ICONEXCLAMATION OR %MB_OK
EXIT FUNCTION
END IF
' Set margins of 1 inch
rc.nLeft = GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
rc.nTop = GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
rc.nRight = GetDeviceCaps(hdcPrn, %PHYSICALWIDTH) - _
GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
rc.nBottom = GetDeviceCaps(hdcPrn, %PHYSICALHEIGHT) - _
GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
' Display text on printer
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
fSuccess = %FALSE
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
' Select font using adjusted lfHeight
iSavePointSize = lf.lfHeight
lf.lfHeight = -(GetDeviceCaps (hdcPrn, %LOGPIXELSY) * _
cf.iPointSize) \ 720
SelectObject hdcPrn, CreateFontIndirect(lf)
lf.lfHeight = iSavePointSize
' Set text color
SetTextColor hdcPrn, cf.rgbColors
' Display text
Justify hdcPrn, szText, rc, iAlign
IF EndPage(hdcPrn) > 0 THEN
fSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
DeleteDC hdcPrn
IF ISFALSE fSuccess THEN
MessageBox hwnd, "Could not print text", _
szAppName, %MB_ICONEXCLAMATION OR %MB_OK
END IF
CASE %IDM_FONT
IF ChooseFont(cf) THEN
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_ALIGN_LEFT, %IDM_ALIGN_RIGHT, %IDM_ALIGN_CENTER, %IDM_ALIGN_JUSTIFIED
CheckMenuItem hMenu, iAlign, %MF_UNCHECKED
iAlign = LO(WORD, wParam)
CheckMenuItem hMenu, iAlign, %MF_CHECKED
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
DrawRuler hdc, rc
rc.nLeft = rc.nLeft + GetDeviceCaps(hdc, %LOGPIXELSX) \ 2
rc.nTop = rc.nTop + GetDeviceCaps (hdc, %LOGPIXELSY) \ 2
rc.nRight = rc.nLeft + %OUTWIDTH * GetDeviceCaps(hdc, %LOGPIXELSX)
SelectObject hdc, CreateFontIndirect(lf)
SetTextColor hdc, cf.rgbColors
Justify hdc, szText, rc, iAlign
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
JUSTIFY2.RC
#define IDM_FILE_PRINT 40001
#define IDM_FONT 40002
#define IDM_ALIGN_LEFT 40003
#define IDM_ALIGN_RIGHT 40004
#define IDM_ALIGN_CENTER 40005
#define IDM_ALIGN_JUSTIFIED 40006
/////////////////////////////////////////////////////////////////////////////
// Menu
JUSTIFY2 MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&Print", IDM_FILE_PRINT
END
POPUP "&Font"
BEGIN
MENUITEM "&Font...", IDM_FONT
END
POPUP "&Align"
BEGIN
MENUITEM "&Left", IDM_ALIGN_LEFT, CHECKED
MENUITEM "&Right", IDM_ALIGN_RIGHT
MENUITEM "&Centered", IDM_ALIGN_CENTER
MENUITEM "&Justified", IDM_ALIGN_JUSTIFIED
END
END
This program is a translation of KEYVIEW1.C-Displays Keyboard and Character Messages © Charles Petzold, 1998, described and analysed in Chapter 6 of the book Programming Windows, 5th Edition.
Displays in its client area all the information that Windows sends the window procedure for the eight different keyboard messages.
' ========================================================================================
' KEYVIEW1.BAS
' This program is a translation/adaptation of KEYVIEW1.C-Displays Keyboard and Character
' Messages © Charles Petzold, 1998, described and analysed in Chapter 6 of the book
' Programming Windows, 5th Edition.
' Displays in its client area all the information that Windows sends the window procedure
' for the eight different keyboard messages.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
TYPE PMESSAGE
hwnd AS DWORD
message AS DWORD
wParam AS LONG
lParam AS LONG
END TYPE
$szTop = "Message Key Char Repeat Scan Ext ALT Prev Tran"
$szUnd = "_______ ___ ____ ______ ____ ___ ___ ____ ____"
$szYes = "Yes"
$szNo = "No"
$szDown = "Down"
$szUp = "Up"
GLOBAL szMessage() AS ASCIIZ * 15
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
REDIM szMessage(7)
szMessage (0) = "WM_KEYDOWN"
szMessage (1) = "WM_KEYUP"
szMessage (2) = "WM_CHAR"
szMessage (3) = "WM_DEADCHAR"
szMessage (4) = "WM_SYSKEYDOWN"
szMessage (5) = "WM_SYSKEYUP"
szMessage (6) = "WM_SYSCHAR"
szMessage (7) = "WM_SYSDEADCHAR"
szAppName = "KeyView1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Keyboard Message Viewer #1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClientMax AS LONG
STATIC cyClientMax AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxChar AS LONG
STATIC cyChar AS LONG
STATIC cLinesMax AS LONG
STATIC cLines AS LONG
STATIC rectScroll AS RECT
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL iType AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL szBuffer AS ASCIIZ * 128
LOCAL szKeyName AS ASCIIZ * 128
LOCAL tm AS TEXTMETRIC
DIM pmsg(0) AS STATIC PMESSAGE
LOCAL strMessage AS STRING * 14
LOCAL strKey AS STRING * 21
LOCAL strRepeat AS STRING * 6
LOCAL strScan AS STRING * 4
SELECT CASE uMsg
CASE %WM_CREATE, %WM_DISPLAYCHANGE
' Get maximum size of client area
cxClientMax = GetSystemMetrics(%SM_CXMAXIMIZED)
cyClientMax = GetSystemMetrics(%SM_CYMAXIMIZED)
' Get character size for fixed-pitch font
hdc = GetDC(hwnd)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cyChar = tm.tmHeight
ReleaseDC hwnd, hdc
' Allocate memory for display lines
cLinesMax = cyClientMax / cyChar
REDIM pmsg(cLinesMax - 1)
cLines = 0
' Fall though
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
rectScroll.nLeft = 0
rectScroll.nRight = cxClient
rectScroll.nTop = 3 * cyChar / 2
rectScroll.nBottom = cyChar * (cyClient / cyChar)
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_KEYDOWN, %WM_KEYUP, %WM_CHAR, %WM_DEADCHAR, _
%WM_SYSKEYDOWN, %WM_SYSKEYUP, %WM_SYSCHAR, %WM_SYSDEADCHAR
' Rearrange storage array
FOR i = cLinesMax - 1 TO 0 STEP -1
pmsg(i) = pmsg(i - 1)
NEXT
' Store new message
pmsg(0).hwnd = hwnd
pmsg(0).message = uMsg
pmsg(0).wParam = wParam
pmsg(0).lParam = lParam
cLines = MIN&(cLines + 1, cLinesMax)
' Scroll up the display
ScrollWindow hwnd, 0, -cyChar, rectScroll, rectScroll
' Fall through DefWindowProc so Sys messages work
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
SetBkMode hdc, %TRANSPARENT
TextOut hdc, 0, 0, BYCOPY $szTop, LEN($szTop)
TextOut hdc, 0, 0, BYCOPY $szUnd, LEN($szUnd)
FOR i = 0 TO MIN&(cLines, cyClient / cyChar - 1) - 1
IF i <= UBOUND(pmsg) THEN
IF pmsg(i).wParam THEN
GetKeyNameText pmsg(i).lParam, szKeyName, SIZEOF(szKeyName)
strMessage = szMessage(pmsg(i).message - %WM_KEYFIRST)
IF pmsg(i).message = %WM_CHAR OR _
pmsg(i).message = %WM_SYSCHAR OR _
pmsg(i).message = %WM_DEADCHAR OR _
pmsg(i).message = %WM_SYSDEADCHAR THEN
strKey = " &H" & HEX$(pmsg(i).wParam, 4) & " " & CHR$(pmsg(i).wParam)
ELSE
strKey = FORMAT$(pmsg(i).wParam) & " " & szKeyName
END IF
RSET strRepeat = STR$(LO(WORD, pmsg(i).lParam))
RSET strScan = STR$(HI(WORD, pmsg(i).lParam) AND &HFF)
szBuffer = strMessage & " " & strKey & " " & strRepeat & " " & strScan & " "
IF (pmsg(i).lParam AND &H01000000) THEN
szBuffer = szBuffer & $szYes & " "
ELSE
szBuffer = szBuffer & " " & $szNo & " "
END IF
IF (pmsg(i).lParam AND &H20000000) THEN
szBuffer = szBuffer & $szYes & " "
ELSE
szBuffer = szBuffer & " " & $szNo & " "
END IF
IF (pmsg(i).lParam AND &H40000000) THEN
szBuffer = szBuffer & $szDown & " "
ELSE
szBuffer = szBuffer & " " & $szUp & " "
END IF
IF (pmsg(i).lParam AND &H80000000) THEN
szBuffer = szBuffer & " " & $szUp
ELSE
szBuffer = szBuffer & $szDown
END IF
TextOut hdc, 0, (cyClient / cyChar - 1 - i) * cyChar, szBuffer, LEN(szBuffer)
END IF
END IF
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the LINEDEMO.C-Line-Drawing Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Draws a rectangle, an ellipse, a rectangle with rounded corners, and two lines, but not in that order. The program demonstrates that these functions that define closed areas do indeed fill them, because the lines are hidden behind the ellipse.
' ========================================================================================
' LINEDEMO.BAS
' This program is a translation/adaptation of the LINEDEMO.C-Line-Drawing Demonstration
' Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Draws a rectangle, an ellipse, a rectangle with rounded corners, and two lines, but not
' in that order. The program demonstrates that these functions that define closed areas do
' indeed fill them, because the lines are hidden behind the ellipse.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "LineDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Line Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
Rectangle hdc, cxClient / 8, cyClient / 8, 7 * cxClient / 8, 7 * cyClient / 8
MoveToEx hdc, 0, 0, BYVAL %NULL
LineTo hdc, cxClient, cyClient
MoveToEx hdc, 0, cyClient, BYVAL %NULL
LineTo hdc, cxClient, 0
Ellipse hdc, cxClient / 8, cyClient / 8, 7 * cxClient / 8, 7 * cyClient / 8
RoundRect hdc, cxClient / 4, cyClient / 4, 3 * cxClient / 4, 3 * cyClient / 4, cxClient / 4, cyClient / 4
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of MDIDEMO.C -- Multiple-Document Interface Demonstration © Charles Petzold, 1998, described and analysed in Chapter 19 of the book Programming Windows, 5th Edition.
Demonstrates the basics of writing an MDI application.
MDIDEMO supports two types of extremely simple document windows: one displays "Hello, World!" in the center of its client area, and the other displays a series of random rectangles. (In the source code listings and identifier names, these are referred to as the Hello document and the Rect document.) Different menus are associated with these two types of document windows. The document window that displays "Hello, World!" has a menu that allows you to change the color of the text.
' ========================================================================================
' MDIDEMO.BAS
' This program is a translation/adaptation of MDIDEMO.C -- Multiple-Document Interface
' Demonstration © Charles Petzold, 1998, described and analysed in Chapter 19 of the book
' Programming Windows, 5th Edition.
' Demonstrates the basics of writing an MDI application.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "mdidemo.res"
%IDM_FILE_NEWHELLO = 40001
%IDM_FILE_NEWRECT = 40002
%IDM_APP_EXIT = 40003
%IDM_FILE_CLOSE = 40004
%IDM_COLOR_BLACK = 40005
%IDM_COLOR_RED = 40006
%IDM_COLOR_GREEN = 40007
%IDM_COLOR_BLUE = 40008
%IDM_COLOR_WHITE = 40009
%IDM_WINDOW_CASCADE = 40010
%IDM_WINDOW_TILE = 40011
%IDM_WINDOW_ARRANGE = 40012
%IDM_WINDOW_CLOSEALL = 40013
%INIT_MENU_POS = 0
%HELLO_MENU_POS = 2
%RECT_MENU_POS = 1
%IDM_FIRSTCHILD = 50000
' structure for storing data unique to each Hello child window
TYPE HELLODATA
iColor AS DWORD
clrText AS DWORD
END TYPE
' structure for storing data unique to each Rect child window
TYPE RECTDATA
cxClient AS INTEGER
cyClient AS INTEGER
END TYPE
GLOBAL szAppName AS ASCIIZ * 256
GLOBAL szFrameClass AS ASCIIZ * 256
GLOBAL szHelloClass AS ASCIIZ * 256
GLOBAL szRectClass AS ASCIIZ * 256
GLOBAL hInst AS DWORD
GLOBAL hMenuInit AS DWORD
GLOBAL hMenuHello AS DWORD
GLOBAL hMenuRect AS DWORD
GLOBAL hMenuInitWindow AS DWORD
GLOBAL hMenuHelloWindow AS DWORD
GLOBAL hMenuRectWindow AS DWORD
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hAccel AS DWORD
LOCAL hwndFrame AS DWORD
LOCAL hwndClient AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "MDIDemo"
szFrameClass = "MdiFrame"
szHelloClass = "MdiHelloChild"
szRectClass = "MdiRectChild"
' Register the frame window class
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(FrameWndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = %COLOR_APPWORKSPACE + 1
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szFrameClass)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
' Register the Hello child window class
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(HelloWndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 4
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szHelloClass)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
' Register the Rect child window class
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(RectWndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 4
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szRectClass)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
' Obtain handles to three possible menus & submenus
hMenuInit = LoadMenu(hInstance, "MdiMenuInit")
hMenuHello = LoadMenu(hInstance, "MdiMenuHello")
hMenuRect = LoadMenu(hInstance, "MdiMenuRect")
hMenuInitWindow = GetSubMenu(hMenuInit, %INIT_MENU_POS)
hMenuHelloWindow = GetSubMenu(hMenuHello, %HELLO_MENU_POS)
hMenuRectWindow = GetSubMenu(hMenuRect, %RECT_MENU_POS)
' Load accelerator table
hAccel = LoadAccelerators(hInstance, szAppName)
' Create the frame window
szCaption = "MDI Demonstration"
hWndFrame = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szFrameClass, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
hMenuInit, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
hwndClient = GetWindow(hwndFrame, %GW_CHILD)
ShowWindow hwndFrame, iCmdShow
UpdateWindow hwndFrame
' Enter the modified message loop
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
IF ISFALSE TranslateMDISysAccel(hwndClient, uMsg) THEN
IF ISFALSE TranslateAccelerator(hwndFrame, hAccel, uMsg) THEN
TranslateMessage uMsg
DispatchMessage uMsg
END IF
END IF
WEND
' Clean up by deleting unattached menus
DestroyMenu hMenuHello
DestroyMenu hMenuRect
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Frame dialog callback.
' ========================================================================================
FUNCTION FrameWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndClient AS DWORD
LOCAL clientcreate AS CLIENTCREATESTRUCT
LOCAL hwndChild AS DWORD
LOCAL mdicreate AS MDICREATESTRUCT
LOCAL szTitle AS ASCIIZ * 256
SELECT CASE uMsg
CASE %WM_CREATE ' Create the client window
clientcreate.hWindowMenu = hMenuInitWindow
clientcreate.idFirstChild = %IDM_FIRSTCHILD
hwndClient = CreateWindowEx(0, "MDICLIENT", BYVAL %NULL, _
%WS_CHILD OR %WS_CLIPCHILDREN OR %WS_VISIBLE, _
0, 0, 0, 0, hwnd, 1, hInst, _
BYVAL VARPTR(clientcreate))
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_NEWHELLO ' Create a Hello child window
szTitle = "Hello"
mdicreate.szClass = VARPTR(szHelloClass)
mdicreate.szTitle = VARPTR(szTitle)
mdicreate.hOwner = hInst
mdicreate.x = %CW_USEDEFAULT
mdicreate.y = %CW_USEDEFAULT
mdicreate.cx = %CW_USEDEFAULT
mdicreate.cy = %CW_USEDEFAULT
mdicreate.style = 0
mdicreate.lParam = 0
hwndChild = SendMessage(hwndClient, %WM_MDICREATE, 0, VARPTR(mdicreate))
EXIT FUNCTION
CASE %IDM_FILE_NEWRECT ' Create a Rect child window
szTitle = "Rectangles"
mdicreate.szClass = VARPTR(szRectClass)
mdicreate.szTitle = VARPTR(SzTitle)
mdicreate.hOwner = hInst
mdicreate.x = %CW_USEDEFAULT
mdicreate.y = %CW_USEDEFAULT
mdicreate.cx = %CW_USEDEFAULT
mdicreate.cy = %CW_USEDEFAULT
mdicreate.style = 0
mdicreate.lParam = 0
hwndChild = SendMessage(hwndClient, %WM_MDICREATE, 0, VARPTR(mdicreate))
EXIT FUNCTION
CASE %IDM_FILE_CLOSE ' Close the active window
hwndChild = SendMessage(hwndClient, %WM_MDIGETACTIVE, 0, 0)
IF SendMessage(hwndChild, %WM_QUERYENDSESSION, 0, 0) THEN
SendMessage hwndClient, %WM_MDIDESTROY, hwndChild, 0
END IF
EXIT FUNCTION
CASE %IDM_APP_EXIT ' Exit the program
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
' // messages for arranging windows
CASE %IDM_WINDOW_TILE
SendMessage hwndClient, %WM_MDITILE, 0, 0
EXIT FUNCTION
CASE %IDM_WINDOW_CASCADE
SendMessage hwndClient, %WM_MDICASCADE, 0, 0
EXIT FUNCTION
CASE %IDM_WINDOW_ARRANGE
SendMessage hwndClient, %WM_MDIICONARRANGE, 0, 0
EXIT FUNCTION
CASE %IDM_WINDOW_CLOSEALL ' Attempt to close all children
EnumChildWindows hwndClient, CODEPTR(CloseEnumProc), 0
EXIT FUNCTION
CASE ELSE ' Pass to active child...
hwndChild = SendMessage (hwndClient, %WM_MDIGETACTIVE, 0, 0)
IF IsWindow(hwndChild) THEN
SendMessage hwndChild, %WM_COMMAND, wParam, lParam
END IF
' ...and fall through DefFrameProc
END SELECT
CASE %WM_QUERYENDSESSION, %WM_CLOSE ' Attempt to close all children
SendMessage hwnd, %WM_COMMAND, %IDM_WINDOW_CLOSEALL, 0
IF GetWindow(hwndClient, %GW_CHILD) <> %NULL THEN
EXIT FUNCTION
END IF
' Fall through DefFrameProc
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefFrameProc(hwnd, hwndClient, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION CloseEnumProc (BYVAL hwnd AS DWORD, BYVAL lParam AS LONG) AS LONG
IF GetWindow(hwnd, %GW_OWNER) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
SendMessage GetParent(hwnd), %WM_MDIRESTORE, hwnd, 0
IF ISFALSE SendMessage(hwnd, %WM_QUERYENDSESSION, 0, 0) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
SendMessage GetParent(hwnd), %WM_MDIDESTROY, hwnd, 0
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION HelloWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM clrTextArray(4) AS STATIC DWORD
STATIC hwndClient AS DWORD
STATIC hwndFrame AS DWORD
LOCAL hdc AS DWORD
LOCAL hMenu AS DWORD
LOCAL pHelloData AS HELLODATA PTR
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
SELECT CASE uMsg
CASE %WM_CREATE
clrTextArray(0) = RGB(0, 0, 0)
clrTextArray(1) = RGB(255, 0, 0)
clrTextArray(2) = RGB(0, 255, 0)
clrTextArray(3) = RGB(0, 0, 255)
clrTextArray(4) = RGB(255, 255, 255)
' Allocate memory for window private data
pHelloData = HeapAlloc(GetprocessHeap, %HEAP_ZERO_MEMORY, SIZEOF(HELLODATA))
@pHelloData.iColor = %IDM_COLOR_BLACK
@pHelloData.clrText = RGB(0, 0, 0)
SetWindowLong hwnd, 0, pHelloData
' Save some window handles
hwndClient = GetParent(hwnd)
hwndFrame = GetParent(hwndClient)
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_COLOR_BLACK, %IDM_COLOR_RED, %IDM_COLOR_GREEN, _
%IDM_COLOR_BLUE, %IDM_COLOR_WHITE
' Change the text color
pHelloData = GetWindowLong (hwnd, 0)
hMenu = GetMenu(hwndFrame)
CheckMenuItem hMenu, @pHelloData.iColor, %MF_UNCHECKED
@pHelloData.iColor = wParam
CheckMenuItem hMenu, @pHelloData.iColor, %MF_CHECKED
@pHelloData.clrText = clrTextArray(wParam - %IDM_COLOR_BLACK)
InvalidateRect hwnd, BYVAL %NULL, %FALSE
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
' Paint the window
hdc = BeginPaint(hwnd, ps)
pHelloData = GetWindowLong (hwnd, 0)
SetTextColor hdc, @pHelloData.clrText
GetClientRect hwnd, rc
DrawText hdc, "Hello, World!", -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_MDIACTIVATE
' Set the Hello menu if gaining focus
IF lParam = hwnd THEN
SendMessage hWndClient, %WM_MDISETMENU, hMenuHello, hMenuHelloWindow
END IF
' Check or uncheck menu item
pHelloData = GetWindowLong(hwnd, 0)
CheckMenuItem hMenuHello, @pHelloData.iColor, _
IIF&(lParam = hwnd, %MF_CHECKED, %MF_UNCHECKED)
' Set the Init menu if losing focus
IF lParam <> hwnd THEN
SendMessage hwndCLient, %WM_MDISETMENU, hMenuInit, hMenuInitWindow
END IF
DrawMenuBar hwndFrame
EXIT FUNCTION
CASE %WM_QUERYENDSESSION, %WM_CLOSE
IF MessageBox(hwnd, "OK to close window?", "Hello", %MB_ICONQUESTION OR %MB_OKCANCEL) <> %IDOK THEN
EXIT FUNCTION
END IF
' Fall through DefMDIChildProc
CASE %WM_DESTROY
pHelloData = GetWindowLong (hwnd, 0)
HeapFree GetProcessHeap, 0, pHelloData
EXIT FUNCTION
END SELECT
' Pass unprocessed message to DefMDIChildProc
FUNCTION = DefMDIChildProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION RectWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndClient AS DWORD
STATIC hwndFrame AS DWORD
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL pRectData AS RECTDATA PTR
LOCAL ps AS PAINTSTRUCT
LOCAL xLeft AS LONG
LOCAL xRight AS LONG
LOCAL yTop AS LONG
LOCAL yBottom AS LONG
LOCAL nRed AS INTEGER
LOCAL nGreen AS INTEGER
LOCAL nBlue AS INTEGER
SELECT CASE uMsg
CASE %WM_CREATE
' Allocate memory for window private data
pRectData = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, SIZEOF(RECTDATA))
SetWindowLong hwnd, 0, pRectData
' Start the timer going
SetTimer hwnd, 1, 250, %NULL
' Save some window handles
hwndClient = GetParent(hwnd)
hwndFrame = GetParent(hwndClient)
EXIT FUNCTION
CASE %WM_SIZE ' // If not minimized, save the window size
IF wParam <> %SIZE_MINIMIZED THEN
pRectData = GetWindowLong(hwnd, 0)
@pRectData.cxClient = LO(WORD, lParam)
@pRectData.cyClient = HI(WORD, lParam)
END IF
' %WM_SIZE must be processed by DefMDIChildProc
CASE %WM_TIMER ' // Display a random rectangle
pRectData = GetWindowLong(hwnd, 0)
xLeft = RND * @pRectData.cxClient
xRight = RND * @pRectData.cxClient
yTop = RND * @pRectData.cyClient
yBottom = RND * @pRectData.cyClient
nRed = RND * 255
nGreen = RND * 255
nBlue = RND * 255
hdc = GetDC(hwnd)
hBrush = CreateSolidBrush(RGB(nRed, nGreen, nBlue))
SelectObject hdc, hBrush
Rectangle hdc, min (xLeft, xRight), min (yTop, yBottom), _
MAX&(xLeft, xRight), MAX&(yTop, yBottom)
ReleaseDC hwnd, hdc
DeleteObject hBrush
EXIT FUNCTION
CASE %WM_PAINT ' Clear the window
InvalidateRect hwnd, BYVAL %NULL, %TRUE
hdc = BeginPaint(hwnd, ps)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_MDIACTIVATE '/ Set the appropriate menu
IF lParam = hwnd THEN
SendMessage hwndClient, %WM_MDISETMENU, hMenuRect, hMenuRectWindow
ELSE
SendMessage hwndClient, %WM_MDISETMENU, hMenuInit, hMenuInitWindow
END IF
DrawMenuBar hwndFrame
EXIT FUNCTION
CASE %WM_DESTROY
pRectData = GetWindowLong(hwnd, 0)
HeapFree GetProcessHeap, 0, pRectData
KillTimer hwnd, 1
EXIT FUNCTION
END SELECT
' Pass unprocessed message to DefMDIChildProc
FUNCTION = DefMDIChildProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of MENUDEMO.C -- Menu Demonstration © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
The MENUDEMO program has five items in the main menu-File, Edit, Background, Timer, and Help. Each of these items has a popup. MENUDEMO does the simplest and most common type of menu processing, which involves trapping WM_COMMAND messages and checking the low word of wParam.
' ========================================================================================
' MENUDEMO.BAS
' This program is a translation/adaptation of MENUDEMO.C -- Menu Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' The MENUDEMO program has five items in the main menu-File, Edit, Background, Timer, and
' Help. Each of these items has a popup. MENUDEMO does the simplest and most common type
' of menu processing, which involves trapping WM_COMMAND messages and checking the low
' word of wParam.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "menudemo.res"
%ID_TIMER = 1
%IDM_FILE_NEW = 40001
%IDM_FILE_OPEN = 40002
%IDM_FILE_SAVE = 40003
%IDM_FILE_SAVE_AS = 40004
%IDM_APP_EXIT = 40005
%IDM_EDIT_UNDO = 40006
%IDM_EDIT_CUT = 40007
%IDM_EDIT_COPY = 40008
%IDM_EDIT_PASTE = 40009
%IDM_EDIT_CLEAR = 40010
%IDM_BKGND_WHITE = 40011
%IDM_BKGND_LTGRAY = 40012
%IDM_BKGND_GRAY = 40013
%IDM_BKGND_DKGRAY = 40014
%IDM_BKGND_BLACK = 40015
%IDM_TIMER_START = 40016
%IDM_TIMER_STOP = 40017
%IDM_APP_HELP = 40018
%IDM_APP_ABOUT = 40019
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
szAppName = "MenuDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Menu Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM idColor(0 TO 4) AS STATIC LONG
STATIC iSelection AS LONG
LOCAL hMenu AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
idColor(0) = %WHITE_BRUSH
idColor(1) = %LTGRAY_BRUSH
idColor(2) = %GRAY_BRUSH
idColor(3) = %DKGRAY_BRUSH
idColor(4) = %BLACK_BRUSH
iSelection = %IDM_BKGND_WHITE
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
hMenu = GetMenu(hwnd)
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_NEW, _
%IDM_FILE_OPEN, _
%IDM_FILE_SAVE, _
%IDM_FILE_SAVE_AS
MessageBeep 0
CASE %IDM_APP_EXIT:
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_EDIT_UNDO, _
%IDM_EDIT_CUT, _
%IDM_EDIT_COPY, _
%IDM_EDIT_PASTE, _
%IDM_EDIT_CLEAR
MessageBeep 0
CASE %IDM_BKGND_WHITE, _ ' // Note: Logic below
%IDM_BKGND_LTGRAY, _ ' // assumes that IDM_WHITE
%IDM_BKGND_GRAY, _ ' // through IDM_BLACK are
%IDM_BKGND_DKGRAY, _ ' // consecutive numbers in
%IDM_BKGND_BLACK ' // the order shown here.
CheckMenuItem hMenu, iSelection, %MF_UNCHECKED
iSelection = LO(WORD, wParam)
CheckMenuItem hMenu, iSelection, %MF_CHECKED
SetClassLong hwnd, %GCL_HBRBACKGROUND, _
GetStockObject(idColor(LO(WORD, wParam) - %IDM_BKGND_WHITE))
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_TIMER_START
IF SetTimer(hwnd, %ID_TIMER, 1000, %NULL) THEN
EnableMenuItem hMenu, %IDM_TIMER_START, %MF_GRAYED
EnableMenuItem hMenu, %IDM_TIMER_STOP, %MF_ENABLED
END IF
CASE %IDM_TIMER_STOP
KillTimer hwnd, %ID_TIMER
EnableMenuItem hMenu, %IDM_TIMER_START, %MF_ENABLED
EnableMenuItem hMenu, %IDM_TIMER_STOP, %MF_GRAYED
CASE %IDM_APP_HELP
MessageBox hwnd, "Help not yet implemented!", _
"MenuDemo", %MB_ICONEXCLAMATION OR %MB_OK
CASE %IDM_APP_ABOUT
MessageBox hwnd, "Menu Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
"MenuDemo", %MB_ICONINFORMATION OR %MB_OK
END SELECT
EXIT FUNCTION
CASE %WM_TIMER
MessageBeep 0
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
MenuDemo.rc
#define IDM_FILE_NEW 40001
#define IDM_FILE_OPEN 40002
#define IDM_FILE_SAVE 40003
#define IDM_FILE_SAVE_AS 40004
#define IDM_APP_EXIT 40005
#define IDM_EDIT_UNDO 40006
#define IDM_EDIT_CUT 40007
#define IDM_EDIT_COPY 40008
#define IDM_EDIT_PASTE 40009
#define IDM_EDIT_CLEAR 40010
#define IDM_BKGND_WHITE 40011
#define IDM_BKGND_LTGRAY 40012
#define IDM_BKGND_GRAY 40013
#define IDM_BKGND_DKGRAY 40014
#define IDM_BKGND_BLACK 40015
#define IDM_TIMER_START 40016
#define IDM_TIMER_STOP 40017
#define IDM_APP_HELP 40018
#define IDM_APP_ABOUT 40019
/////////////////////////////////////////////////////////////////////////////
// Menu
MENUDEMO MENU DISCARDABLE
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&New", IDM_FILE_NEW
MENUITEM "&Open", IDM_FILE_OPEN
MENUITEM "&Save", IDM_FILE_SAVE
MENUITEM "Save &As...", IDM_FILE_SAVE_AS
MENUITEM SEPARATOR
MENUITEM "E&xit", IDM_APP_EXIT
END
POPUP "&Edit"
BEGIN
MENUITEM "&Undo", IDM_EDIT_UNDO
MENUITEM SEPARATOR
MENUITEM "C&ut", IDM_EDIT_CUT
MENUITEM "&Copy", IDM_EDIT_COPY
MENUITEM "&Paste", IDM_EDIT_PASTE
MENUITEM "De&lete", IDM_EDIT_CLEAR
END
POPUP "&Background"
BEGIN
MENUITEM "&White", IDM_BKGND_WHITE, CHECKED
MENUITEM "&Light Gray", IDM_BKGND_LTGRAY
MENUITEM "&Gray", IDM_BKGND_GRAY
MENUITEM "&Dark Gray", IDM_BKGND_DKGRAY
MENUITEM "&Black", IDM_BKGND_BLACK
END
POPUP "&Timer"
BEGIN
MENUITEM "&Start", IDM_TIMER_START
MENUITEM "S&top", IDM_TIMER_STOP, GRAYED
END
POPUP "&Help"
BEGIN
MENUITEM "&Help...", IDM_APP_HELP
MENUITEM "&About MenuDemo...", IDM_APP_ABOUT
END
END
Code that creates the same menu as used in the MENUDEMO program but without requiring a resource script file.
' ========================================================================================
' MENUDEMO2.BAS
' Code that creates the same menu as used in the MENUDEMO program but without requiring a
' resource script file.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
%IDM_FILE_NEW = 40001
%IDM_FILE_OPEN = 40002
%IDM_FILE_SAVE = 40003
%IDM_FILE_SAVE_AS = 40004
%IDM_APP_EXIT = 40005
%IDM_EDIT_UNDO = 40006
%IDM_EDIT_CUT = 40007
%IDM_EDIT_COPY = 40008
%IDM_EDIT_PASTE = 40009
%IDM_EDIT_CLEAR = 40010
%IDM_BKGND_WHITE = 40011
%IDM_BKGND_LTGRAY = 40012
%IDM_BKGND_GRAY = 40013
%IDM_BKGND_DKGRAY = 40014
%IDM_BKGND_BLACK = 40015
%IDM_TIMER_START = 40016
%IDM_TIMER_STOP = 40017
%IDM_APP_HELP = 40018
%IDM_APP_ABOUT = 40019
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
LOCAL hMenu AS DWORD
LOCAL hMenuPopup AS DWORD
szAppName = "MenuDemo2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Menu Demonstration #2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
hMenu = CreateMenu()
hMenuPopup = CreateMenu()
AppendMenu hMenuPopup, %MF_STRING, %IDM_FILE_NEW, "&New"
AppendMenu hMenuPopup, %MF_STRING, %IDM_FILE_OPEN, "&Open..."
AppendMenu hMenuPopup, %MF_STRING, %IDM_FILE_SAVE, "&Save"
AppendMenu hMenuPopup, %MF_STRING, %IDM_FILE_SAVE_AS, "Save &As..."
AppendMenu hMenuPopup, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenuPopup, %MF_STRING, %IDM_APP_EXIT, "E&xit"
AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&File"
hMenuPopup = CreateMenu()
AppendMenu hMenuPopup, %MF_STRING, %IDM_EDIT_UNDO, "&Undo"
AppendMenu hMenuPopup, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenuPopup, %MF_STRING, %IDM_EDIT_CUT, "Cu&t"
AppendMenu hMenuPopup, %MF_STRING, %IDM_EDIT_COPY, "&Copy"
AppendMenu hMenuPopup, %MF_STRING, %IDM_EDIT_PASTE, "&Paste"
AppendMenu hMenuPopup, %MF_STRING, %IDM_EDIT_CLEAR, "De&lete"
AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Edit"
hMenuPopup = CreateMenu()
AppendMenu hMenuPopup, %MF_STRING OR %MF_CHECKED, %IDM_BKGND_WHITE, "&White"
AppendMenu hMenuPopup, %MF_STRING, %IDM_BKGND_LTGRAY, "&Light Gray"
AppendMenu hMenuPopup, %MF_STRING, %IDM_BKGND_GRAY, "&Gray"
AppendMenu hMenuPopup, %MF_STRING, %IDM_BKGND_DKGRAY, "&Dark Gray"
AppendMenu hMenuPopup, %MF_STRING, %IDM_BKGND_BLACK, "&Black"
AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Background"
hMenuPopup = CreateMenu()
AppendMenu hMenuPopup, %MF_STRING, %IDM_TIMER_START, "&Start"
AppendMenu hMenuPopup, %MF_STRING OR %MF_GRAYED, %IDM_TIMER_STOP, "S&top"
AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Timer"
hMenuPopup = CreateMenu()
AppendMenu hMenuPopup, %MF_STRING, %IDM_APP_HELP, "&Help"
AppendMenu hMenuPopup, %MF_STRING, %IDM_APP_ABOUT, "&About MenuDemo..."
AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Help"
SetMenu hwnd, hMenu
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
DIM idColor(0 TO 4) AS STATIC LONG
STATIC iSelection AS LONG
LOCAL hMenu AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
idColor(0) = %WHITE_BRUSH
idColor(1) = %LTGRAY_BRUSH
idColor(2) = %GRAY_BRUSH
idColor(3) = %DKGRAY_BRUSH
idColor(4) = %BLACK_BRUSH
iSelection = %IDM_BKGND_WHITE
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
hMenu = GetMenu(hwnd)
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_NEW, _
%IDM_FILE_OPEN, _
%IDM_FILE_SAVE, _
%IDM_FILE_SAVE_AS
MessageBeep 0
CASE %IDM_APP_EXIT:
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_EDIT_UNDO, _
%IDM_EDIT_CUT, _
%IDM_EDIT_COPY, _
%IDM_EDIT_PASTE, _
%IDM_EDIT_CLEAR
MessageBeep 0
CASE %IDM_BKGND_WHITE, _ ' // Note: Logic below
%IDM_BKGND_LTGRAY, _ ' // assumes that IDM_WHITE
%IDM_BKGND_GRAY, _ ' // through IDM_BLACK are
%IDM_BKGND_DKGRAY, _ ' // consecutive numbers in
%IDM_BKGND_BLACK ' // the order shown here.
CheckMenuItem hMenu, iSelection, %MF_UNCHECKED
iSelection = LO(WORD, wParam)
CheckMenuItem hMenu, iSelection, %MF_CHECKED
SetClassLong hwnd, %GCL_HBRBACKGROUND, _
GetStockObject(idColor(LO(WORD, wParam) - %IDM_BKGND_WHITE))
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_TIMER_START
IF SetTimer(hwnd, %ID_TIMER, 1000, %NULL) THEN
EnableMenuItem hMenu, %IDM_TIMER_START, %MF_GRAYED
EnableMenuItem hMenu, %IDM_TIMER_STOP, %MF_ENABLED
END IF
CASE %IDM_TIMER_STOP
KillTimer hwnd, %ID_TIMER
EnableMenuItem hMenu, %IDM_TIMER_START, %MF_ENABLED
EnableMenuItem hMenu, %IDM_TIMER_STOP, %MF_GRAYED
CASE %IDM_APP_HELP
MessageBox hwnd, "Help not yet implemented!", _
"MenuDemo", %MB_ICONEXCLAMATION OR %MB_OK
CASE %IDM_APP_ABOUT
MessageBox hwnd, "Menu Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
"MenuDemo", %MB_ICONINFORMATION OR %MB_OK
END SELECT
EXIT FUNCTION
CASE %WM_TIMER
MessageBeep 0
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of METAFILE.C -- Metafile Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.
Shows how to create a memory metafile during the %WM_CREATE message and display the image 100 times during the %WM_PAINT message.
' ========================================================================================
' METAFILE.BAS
' This program is a translation/adaptation of METAFILE.C -- Metafile Demonstration Program
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Shows how to create a memory metafile during the %WM_CREATE message and display the image
' 100 times during the %WM_PAINT message.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Metafile"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Metafile Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hmf AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL hdcMeta AS DWORD
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
hdcMeta = CreateMetaFile(BYVAL %NULL)
hBrush = CreateSolidBrush(RGB(0, 0, 255))
Rectangle hdcMeta, 0, 0, 100, 100
MoveToEx hdcMeta, 0, 0, BYVAL %NULL
LineTo hdcMeta, 100, 100
MoveToEx hdcMeta, 0, 100, BYVAL %NULL
LineTo hdcMeta, 100, 0
SelectObject hdcMeta, hBrush
Ellipse hdcMeta, 20, 20, 80, 80
hmf = CloseMetaFile(hdcMeta)
DeleteObject hBrush
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1000, 1000, BYVAL %NULL
SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
FOR x = 0 TO 10
FOR y = 0 TO 10
SetWindowOrgEx hdc, -100 * x, -100 * y, BYVAL %NULL
PlayMetaFile hdc, hmf
NEXT
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteMetaFile hmf
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of NOPOPUPS.C -- Demonstrates No-Popup Nested Menu © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
Now let's step a little off the beaten path. Instead of having drop-down menus in your program, how about creating multiple top-level menus without any popups and switching between the top-level menus using the SetMenu call? Such a menu might remind old-timers of that character-mode classic, Lotus 1-2-3. The NOPOPUPS program demonstrates how to do it. This program includes File and Edit items similar to those that MENUDEMO uses but displays them as alternate top-level menus.
' ========================================================================================
' NOPOPUPS.BAS
' This program is a translation/adaptation of NOPOPUPS.C -- Demonstrates No-Popup Nested
' Menu © Charles Petzold, 1998, described and analysed in Chapter 10 of the book
' Programming Windows, 5th Edition.
' Now let's step a little off the beaten path. Instead of having drop-down menus in your
' program, how about creating multiple top-level menus without any popups and switching
' between the top-level menus using the SetMenu call? Such a menu might remind old-timers
' of that character-mode classic, Lotus 1-2-3. The NOPOPUPS program demonstrates how to do
' it. This program includes File and Edit items similar to those that MENUDEMO uses but
' displays them as alternate top-level menus.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "nopopups.res"
%IDM_FILE = 40001
%IDM_EDIT = 40002
%IDM_FILE_NEW = 40003
%IDM_FILE_OPEN = 40004
%IDM_FILE_SAVE = 40005
%IDM_FILE_SAVE_AS = 40006
%IDM_MAIN = 40007
%IDM_EDIT_UNDO = 40008
%IDM_EDIT_CUT = 40009
%IDM_EDIT_COPY = 40010
%IDM_EDIT_PASTE = 40011
%IDM_EDIT_CLEAR = 40012
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "NoPopUps"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "No-Popup Nested Menu Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hMenuMain AS DWORD
STATIC hMenuEdit AS DWORD
STATIC hMenuFile AS DWORD
LOCAL hInstance AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
hInstance = GetWindowLong(hwnd, %GWL_HINSTANCE)
hMenuMain = LoadMenu(hInstance, "MenuMain")
hMenuFile = LoadMenu(hInstance, "MenuFile")
hMenuEdit = LoadMenu(hInstance, "MenuEdit")
SetMenu hwnd, hMenuMain
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_MAIN
SetMenu hwnd, hMenuMain
CASE %IDM_FILE
SetMenu hwnd, hMenuFile
CASE %IDM_EDIT
SetMenu hwnd, hMenuEdit
CASE %IDM_FILE_NEW, _
%IDM_FILE_OPEN, _
%IDM_FILE_SAVE, _
%IDM_FILE_SAVE_AS, _
%IDM_EDIT_UNDO, _
%IDM_EDIT_CUT, _
%IDM_EDIT_COPY, _
%IDM_EDIT_PASTE, _
%IDM_EDIT_CLEAR
MessageBeep 0
END SELECT
EXIT FUNCTION
CASE %WM_DESTROY
SetMenu hwnd, hMenuMain
DestroyMenu hMenuFile
DestroyMenu hMenuEdit
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
NOPOPUPS.RC
#define IDM_FILE 40001
#define IDM_EDIT 40002
#define IDM_FILE_NEW 40003
#define IDM_FILE_OPEN 40004
#define IDM_FILE_SAVE 40005
#define IDM_FILE_SAVE_AS 40006
#define IDM_MAIN 40007
#define IDM_EDIT_UNDO 40008
#define IDM_EDIT_CUT 40009
#define IDM_EDIT_COPY 40010
#define IDM_EDIT_PASTE 40011
#define IDM_EDIT_CLEAR 40012
/////////////////////////////////////////////////////////////////////////////
// Menu
MENUMAIN MENU DISCARDABLE
BEGIN
MENUITEM "MAIN:", 0, INACTIVE
MENUITEM "&File...", IDM_FILE
MENUITEM "&Edit...", IDM_EDIT
END
MENUFILE MENU DISCARDABLE
BEGIN
MENUITEM "FILE:", 0, INACTIVE
MENUITEM "&New", IDM_FILE_NEW
MENUITEM "&Open...", IDM_FILE_OPEN
MENUITEM "&Save", IDM_FILE_SAVE
MENUITEM "Save &As", IDM_FILE_SAVE_AS
MENUITEM "(&Main)", IDM_MAIN
END
MENUEDIT MENU DISCARDABLE
BEGIN
MENUITEM "EDIT:", 0, INACTIVE
MENUITEM "&Undo", IDM_EDIT_UNDO
MENUITEM "Cu&t", IDM_EDIT_CUT
MENUITEM "&Copy", IDM_EDIT_COPY
MENUITEM "&Paste", IDM_EDIT_PASTE
MENUITEM "De&lete", IDM_EDIT_CLEAR
MENUITEM "(&Main)", IDM_MAIN
END
This program is a translation of OWNDRAW.C -- Owner-Draw Button Demo Program © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.
If you want to have total control over the visual appearance of a button but don't want to bother with keyboard and mouse logic, you can create a button with the BS_OWNERDRAW style.
' ========================================================================================
' OWNDRAW.BAS
' This program is a translation/adaptation of OWNDRAW.C -- Owner-Draw Button Demo Program
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' If you want to have total control over the visual appearance of a button but don't want
' to bother with keyboard and mouse logic, you can create a button with the BS_OWNERDRAW
' style.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_SMALLER = 1
%ID_LARGER = 2
GLOBAL hInst AS DWORD
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
hInst = hInstance
szAppName = "OwnDraw"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Owner-Draw Button Demo"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB Triangle (BYVAL hdc AS DWORD, pt() AS POINTAPI)
SelectObject hdc, GetStockObject(%BLACK_BRUSH)
Polygon hdc, pt(0), 3
SelectObject hdc, GetStockObject(%WHITE_BRUSH)
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndSmaller AS DWORD
STATIC hwndLarger AS DWORD
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxChar AS LONG
STATIC cyChar AS LONG
STATIC BTN_WIDTH AS LONG
STATIC BTN_HEIGHT AS LONG
LOCAL cx AS LONG
LOCAL cy AS LONG
LOCAL pdis AS DRAWITEMSTRUCT PTR
LOCAL rc AS RECT
DIM pt(0 TO 2) AS POINT
SELECT CASE uMsg
CASE %WM_CREATE
cxChar = LO(WORD, GetDialogBaseUnits)
cyChar = HI(WORD, GetDialogBaseUnits)
BTN_WIDTH = 8 * cxChar
BTN_HEIGHT = 4 * cyChar
' Create the owner-draw pushbuttons
hwndSmaller = CreateWindowEx(%WS_EX_CONTROLPARENT, "Button", "", _
%WS_CHILD OR %WS_VISIBLE OR %BS_OWNERDRAW, _
0, 0, BTN_WIDTH, BTN_HEIGHT, _
hwnd, %ID_SMALLER, hInst, BYVAL %NULL)
hwndLarger = CreateWindowEx(%WS_EX_CONTROLPARENT, "Button", "", _
%WS_CHILD OR %WS_VISIBLE OR %BS_OWNERDRAW, _
0, 0, BTN_WIDTH, BTN_HEIGHT, _
hwnd, %ID_LARGER, hInst, BYVAL %NULL)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
' Move the buttons to the new center
MoveWindow hwndSmaller, cxClient / 2 - 3 * BTN_WIDTH / 2, _
cyClient / 2 - BTN_HEIGHT / 2, _
BTN_WIDTH, BTN_HEIGHT, %TRUE
MoveWindow hwndLarger, cxClient / 2 + BTN_WIDTH / 2, _
cyClient / 2 - BTN_HEIGHT / 2, _
BTN_WIDTH, BTN_HEIGHT, %TRUE
EXIT FUNCTION
CASE %WM_COMMAND
GetWindowRect hwnd, rc
' Make the window 10% smaller or larger
SELECT CASE wParam
CASE %ID_SMALLER
rc.nLeft = rc.nLeft + cxClient / 20
rc.nRight = rc.nRight - cxClient / 20
rc.nTop = rc.nTop + cyClient / 20
rc.nBottom = rc.nBottom - cyClient / 20
CASE %ID_LARGER
rc.nLeft = rc.nLeft - cxClient / 20
rc.nRight = rc.nRight + cxClient / 20
rc.nTop = rc.nTop - cyClient / 20
rc.nBottom = rc.nBottom + cyClient / 20
END SELECT
MoveWindow hwnd, rc.nLeft, rc.nTop, rc.nRight - rc.nLeft, _
rc.nBottom - rc.nTop, %TRUE
EXIT FUNCTION
CASE %WM_DRAWITEM
pdis = lParam
' Fill area with white and frame it black
FillRect @pdis.hDC, @pdis.rcItem, _
GetStockObject(%WHITE_BRUSH)
FrameRect @pdis.hDC, @pdis.rcItem, _
GetStockObject(%BLACK_BRUSH)
' Draw inward and outward black triangles
cx = @pdis.rcItem.nRight - @pdis.rcItem.nLeft
cy = @pdis.rcItem.nBottom - @pdis.rcItem.nTop
SELECT CASE @pdis.CtlID
CASE %ID_SMALLER
pt(0).x = 3 * cx / 8 : pt(0).y = 1 * cy / 8
pt(1).x = 5 * cx / 8 : pt(1).y = 1 * cy / 8
pt(2).x = 4 * cx / 8 : pt(2).y = 3 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 7 * cx / 8 : pt(0).y = 3 * cy / 8
pt(1).x = 7 * cx / 8 : pt(1).y = 5 * cy / 8
pt(2).x = 5 * cx / 8 : pt(2).y = 4 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 5 * cx / 8 : pt(0).y = 7 * cy / 8
pt(1).x = 3 * cx / 8 : pt(1).y = 7 * cy / 8
pt(2).x = 4 * cx / 8 : pt(2).y = 5 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 1 * cx / 8 : pt(0).y = 5 * cy / 8
pt(1).x = 1 * cx / 8 : pt(1).y = 3 * cy / 8
pt(2).x = 3 * cx / 8 : pt(2).y = 4 * cy / 8
Triangle @pdis.hDC, pt()
CASE %ID_LARGER
pt(0).x = 5 * cx / 8 : pt(0).y = 3 * cy / 8
pt(1).x = 3 * cx / 8 : pt(1).y = 3 * cy / 8
pt(2).x = 4 * cx / 8 : pt(2).y = 1 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 5 * cx / 8 : pt(0).y = 5 * cy / 8
pt(1).x = 5 * cx / 8 : pt(1).y = 3 * cy / 8
pt(2).x = 7 * cx / 8 : pt(2).y = 4 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 3 * cx / 8 : pt(0).y = 5 * cy / 8
pt(1).x = 5 * cx / 8 : pt(1).y = 5 * cy / 8
pt(2).x = 4 * cx / 8 : pt(2).y = 7 * cy / 8
Triangle @pdis.hDC, pt()
pt(0).x = 3 * cx / 8 : pt(0).y = 3 * cy / 8
pt(1).x = 3 * cx / 8 : pt(1).y = 5 * cy / 8
pt(2).x = 1 * cx / 8 : pt(2).y = 4 * cy / 8
Triangle @pdis.hDC, pt()
END SELECT
' Invert the rectangle if the button is selected
IF (@pdis.itemState AND %ODS_SELECTED) THEN _
InvertRect @pdis.hDC, @pdis.rcItem
' Draw a focus rectangle if the button has the focus
IF (@pdis.itemState AND %ODS_FOCUS) THEN
@pdis.rcItem.nLeft = @pdis.rcItem.nLeft + cx / 16
@pdis.rcItem.nTop = @pdis.rcItem.nTop + cy / 16
@pdis.rcItem.nRight = @pdis.rcItem.nRight - cx / 16
@pdis.rcItem.nBottom = @pdis.rcItem.nBottom - cy / 16
DrawFocusRect @pdis.hDC, @pdis.rcItem
END IF
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of PICKFONT.C -- Create Logical Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
With the PICKFONT program you can define many of the fields of a LOGFONT structure. The program creates a logical font and displays the characteristics of the real font after the logical font has been selected in a device context. This is a handy program for understanding how logical fonts are mapped to real fonts.
' ========================================================================================
' PICKFONT.BAS
' This program is a translation/Adaptation of PICKFONT.C -- Create Logical Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' With the PICKFONT program you can define many of the fields of a LOGFONT structure. The
' program creates a logical font and displays the characteristics of the real font after
' the logical font has been selected in a device context. This is a handy program for
' understanding how logical fonts are mapped to real fonts.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "pickfont.res"
%IDC_LF_HEIGHT = 1000
%IDC_LF_WIDTH = 1001
%IDC_LF_ESCAPE = 1002
%IDC_LF_ORIENT = 1003
%IDC_LF_WEIGHT = 1004
%IDC_MM_TEXT = 1005
%IDC_MM_LOMETRIC = 1006
%IDC_MM_HIMETRIC = 1007
%IDC_MM_LOENGLISH = 1008
%IDC_MM_HIENGLISH = 1009
%IDC_MM_TWIPS = 1010
%IDC_MM_LOGTWIPS = 1011
%IDC_LF_ITALIC = 1012
%IDC_LF_UNDER = 1013
%IDC_LF_STRIKE = 1014
%IDC_MATCH_ASPECT = 1015
%IDC_ADV_GRAPHICS = 1016
%IDC_LF_CHARSET = 1017
%IDC_CHARSET_HELP = 1018
%IDC_DEFAULT_QUALITY = 1019
%IDC_DRAFT_QUALITY = 1020
%IDC_PROOF_QUALITY = 1021
%IDC_LF_FACENAME = 1022
%IDC_OUT_DEFAULT = 1023
%IDC_OUT_STRING = 1024
%IDC_OUT_CHARACTER = 1025
%IDC_OUT_STROKE = 1026
%IDC_OUT_TT = 1027
%IDC_OUT_DEVICE = 1028
%IDC_OUT_RASTER = 1029
%IDC_OUT_TT_ONLY = 1030
%IDC_OUT_OUTLINE = 1031
%IDC_DEFAULT_PITCH = 1032
%IDC_FIXED_PITCH = 1033
%IDC_VARIABLE_PITCH = 1034
%IDC_FF_DONTCARE = 1035
%IDC_FF_ROMAN = 1036
%IDC_FF_SWISS = 1037
%IDC_FF_MODERN = 1038
%IDC_FF_SCRIPT = 1039
%IDC_FF_DECORATIVE = 1040
%IDC_TM_HEIGHT = 1041
%IDC_TM_ASCENT = 1042
%IDC_TM_DESCENT = 1043
%IDC_TM_INTLEAD = 1044
%IDC_TM_EXTLEAD = 1045
%IDC_TM_AVECHAR = 1046
%IDC_TM_MAXCHAR = 1047
%IDC_TM_WEIGHT = 1048
%IDC_TM_OVERHANG = 1049
%IDC_TM_DIGASPX = 1050
%IDC_TM_DIGASPY = 1051
%IDC_TM_FIRSTCHAR = 1052
%IDC_TM_LASTCHAR = 1053
%IDC_TM_DEFCHAR = 1054
%IDC_TM_BREAKCHAR = 1055
%IDC_TM_ITALIC = 1056
%IDC_TM_UNDER = 1057
%IDC_TM_STRUCK = 1058
%IDC_TM_VARIABLE = 1059
%IDC_TM_VECTOR = 1060
%IDC_TM_TRUETYPE = 1061
%IDC_TM_DEVICE = 1062
%IDC_TM_FAMILY = 1063
%IDC_TM_CHARSET = 1064
%IDC_TM_FACENAME = 1065
%IDM_DEVICE_SCREEN = 40001
%IDM_DEVICE_PRINTER = 40002
TYPE DLGPARAMS
iDevice AS LONG
iMapMode AS LONG
fMatchAspect AS LONG
fAdvGraphics AS LONG
lf AS LOGFONT
tm AS TEXTMETRIC
szFaceName AS ASCIIZ * %LF_FULLFACESIZE
END TYPE
' Global variables
GLOBAL hDlg AS DWORD
GLOBAL szAppName AS ASCIIZ * 256
DECLARE SUB SetLogFontFromFields (BYVAL hdlg AS DWORD, BYVAL pdp AS DLGPARAMS PTR)
DECLARE SUB SetFieldsFromTextMetric (BYVAL hdlg AS DWORD, BYVAL pdp AS DLGPARAMS PTR)
DECLARE SUB MySetMapMode (BYVAL hdc AS DWORD, BYVAL iMapMode AS LONG)
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "PickFont"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "PickFont: Create Logical Font"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC dp AS DLGPARAMS
STATIC szText AS ASCIIZ * 256
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
LOCAL lpc AS CREATESTRUCT PTR
LOCAL hInstance AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
szText = CHR$(&H41, &H42, &H43, &H44, &H45) & " " & _
CHR$(&H61, &H62, &H63, &H64, &H65) & " " & _
CHR$(&HC0, &HC1, &HC2, &HC3, &HC4, &HC5) & " " & _
CHR$(&HE0, &HE1, &HE2, &HE3, &HE4, &HE5)
dp.iDevice = %IDM_DEVICE_SCREEN
lpc = lParam
hInstance = @lpc.hInstance
hdlg = CreateDialogParam(hInstance, szAppName, hwnd, CODEPTR(DlgProc), VARPTR(dp))
EXIT FUNCTION
CASE %WM_SETFOCUS
SetFocus hdlg
FUNCTION = 0
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_DEVICE_SCREEN, %IDM_DEVICE_PRINTER
CheckMenuItem GetMenu(hwnd), dp.iDevice, %MF_UNCHECKED
dp.iDevice = LO(WORD, wParam)
CheckMenuItem GetMenu (hwnd), dp.iDevice, %MF_CHECKED
SendMessage hwnd, %WM_COMMAND, %IDOK, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Set graphics mode so escapement works in Windows NT
SetGraphicsMode hdc, IIF&(dp.fAdvGraphics <> 0, %GM_ADVANCED, %GM_COMPATIBLE)
' Set the mapping mode and the mapper flag
MySetMapMode hdc, dp.iMapMode
SetMapperFlags hdc, dp.fMatchAspect
' Find the point to begin drawing text
GetClientRect hdlg, rc
rc.nBottom = rc.nBottom + 1
DPtoLP hdc, BYVAL VARPTR(rc), 2
' Create and select the font; display the text
SelectObject hdc, CreateFontIndirect(dp.lf)
TextOut hdc, rc.nLeft, rc.nBottom, szText, LEN(szText)
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
FUNCTION DlgProc (BYVAL hdlg AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC pdp AS DLGPARAMS PTR
LOCAL hdcDevice AS DWORD
LOCAL hFont AS DWORD
LOCAL pd AS PRINTDLGAPI
SELECT CASE uMsg
CASE %WM_INITDIALOG
' Save pointer to dialog-parameters structure in WndProc
pdp = lParam
SendDlgItemMessage hdlg, %IDC_LF_FACENAME, %EM_LIMITTEXT, %LF_FACESIZE - 1, 0
CheckRadioButton hdlg, %IDC_OUT_DEFAULT, %IDC_OUT_OUTLINE, %IDC_OUT_DEFAULT
CheckRadioButton hdlg, %IDC_DEFAULT_QUALITY, %IDC_PROOF_QUALITY, %IDC_DEFAULT_QUALITY
CheckRadioButton hdlg, %IDC_DEFAULT_PITCH, %IDC_VARIABLE_PITCH, %IDC_DEFAULT_PITCH
CheckRadioButton hdlg, %IDC_FF_DONTCARE, %IDC_FF_DECORATIVE, %IDC_FF_DONTCARE
CheckRadioButton hdlg, %IDC_MM_TEXT, %IDC_MM_LOGTWIPS, %IDC_MM_TEXT
SendMessage hdlg, %WM_COMMAND, %IDOK, 0
' fall through
CASE %WM_SETFOCUS
SetFocus GetDlgItem(hdlg, %IDC_LF_HEIGHT)
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDC_CHARSET_HELP
MessageBox hdlg, _
"0 = Ansi" & $LF & _
"1 = Default" & $LF & _
"2 = Symbol" & $LF & _
"128 = Shift JIS (Japanese)" & $LF & _
"129 = Hangul (Korean)" & $LF & _
"130 = Johab (Korean)" & $LF & _
"134 = GB 2312 (Simplified Chinese)" & $LF & _
"136 = Chinese Big 5 (Traditional Chinese)" & $LF & _
"177 = Hebrew" & $LF & _
"178 = Arabic" & $LF & _
"161 = Greek" & $LF & _
"162 = Turkish" & $LF & _
"163 = Vietnamese" & $LF & _
"204 = Russian" & $LF & _
"222 = Thai" & $LF & _
"238 = East European" & $LF & _
"255 = OEM", _
szAppName, %MB_OK OR %MB_ICONINFORMATION
FUNCTION = %TRUE
EXIT FUNCTION
' These radio buttons set the lfOutPrecision field
CASE %IDC_OUT_DEFAULT
@pdp.lf.lfOutPrecision = %OUT_DEFAULT_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_STRING
@pdp.lf.lfOutPrecision = %OUT_STRING_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_CHARACTER
@pdp.lf.lfOutPrecision = %OUT_CHARACTER_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_STROKE
@pdp.lf.lfOutPrecision = %OUT_STROKE_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_TT
@pdp.lf.lfOutPrecision = %OUT_TT_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
case %IDC_OUT_DEVICE:
@pdp.lf.lfOutPrecision = %OUT_DEVICE_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_RASTER
@pdp.lf.lfOutPrecision = %OUT_RASTER_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_TT_ONLY
@pdp.lf.lfOutPrecision = %OUT_TT_ONLY_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_OUT_OUTLINE
@pdp.lf.lfOutPrecision = %OUT_OUTLINE_PRECIS
FUNCTION = %TRUE
EXIT FUNCTION
'/ These three radio buttons set the lfQuality field
CASE %IDC_DEFAULT_QUALITY
@pdp.lf.lfQuality = %DEFAULT_QUALITY
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_DRAFT_QUALITY
@pdp.lf.lfQuality = %DRAFT_QUALITY
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_PROOF_QUALITY
@pdp.lf.lfQuality = %PROOF_QUALITY
FUNCTION = %TRUE
EXIT FUNCTION
' These three radio buttons set the lower nibble
' of the lfPitchAndFamily field
CASE %IDC_DEFAULT_PITCH
@pdp.lf.lfPitchAndFamily = _
(&HF0 AND @pdp.lf.lfPitchAndFamily) OR %DEFAULT_PITCH
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FIXED_PITCH
@pdp.lf.lfPitchAndFamily = _
(&HF0 AND @pdp.lf.lfPitchAndFamily) OR %FIXED_PITCH
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_VARIABLE_PITCH
@pdp.lf.lfPitchAndFamily = _
(&HF0 AND @pdp.lf.lfPitchAndFamily) OR %VARIABLE_PITCH
FUNCTION = %TRUE
EXIT FUNCTION
' These six radio buttons set the upper nibble
' of the lfPitchAndFamily field
CASE %IDC_FF_DONTCARE
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_DONTCARE
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FF_ROMAN
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_ROMAN
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FF_SWISS
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_SWISS
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FF_MODERN
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_MODERN
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FF_SCRIPT
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_SCRIPT
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_FF_DECORATIVE
@pdp.lf.lfPitchAndFamily = _
(&H0F AND @pdp.lf.lfPitchAndFamily) OR %FF_DECORATIVE
FUNCTION = %TRUE
EXIT FUNCTION
' Mapping mode:
CASE %IDC_MM_TEXT, %IDC_MM_LOMETRIC, %IDC_MM_HIMETRIC, _
%IDC_MM_LOENGLISH, %IDC_MM_HIENGLISH, %IDC_MM_TWIPS, %IDC_MM_LOGTWIPS
@pdp.iMapMode = LO(WORD, wParam)
FUNCTION = %TRUE
EXIT FUNCTION
' OK button pressed
' -----------------
CASE %IDOK
' Get LOGFONT structure
SetLogFontFromFields hdlg, pdp
' Set Match-Aspect and Advanced Graphics flags
@pdp.fMatchAspect = IsDlgButtonChecked(hdlg, %IDC_MATCH_ASPECT)
@pdp.fAdvGraphics = IsDlgButtonChecked(hdlg, %IDC_ADV_GRAPHICS)
' Get Information Context
IF @pdp.iDevice = %IDM_DEVICE_SCREEN THEN
hdcDevice = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
ELSE
pd.lStructSize = SIZEOF(pd)
pd.hwndOwner = hdlg
pd.Flags = %PD_RETURNDEFAULT OR %PD_RETURNIC
pd.hDevNames = %NULL
pd.hDevMode = %NULL
PrintDlg pd
hdcDevice = pd.hDC
END IF
' Set the mapping mode and the mapper flag
MySetMapMode hdcDevice, @pdp.iMapMode
SetMapperFlags hdcDevice, @pdp.fMatchAspect
' Create font and select it into IC
hFont = CreateFontIndirect(@pdp.lf)
SelectObject hdcDevice, hFont
' Get the text metrics and face name
GetTextMetrics hdcDevice, @pdp.tm
GetTextFace hdcDevice, %LF_FULLFACESIZE, @pdp.szFaceName
DeleteDC hdcDevice
DeleteObject hFont
' Update dialog fields and invalidate main window
SetFieldsFromTextMetric hdlg, pdp
InvalidateRect GetParent(hdlg), BYVAL %NULL, %TRUE
FUNCTION = %TRUE
EXIT FUNCTION
END SELECT
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB SetLogFontFromFields (BYVAL hdlg AS DWORD, BYVAL pdp AS DLGPARAMS PTR)
@pdp.lf.lfHeight = GetDlgItemInt(hdlg, %IDC_LF_HEIGHT, %NULL, %TRUE)
@pdp.lf.lfWidth = GetDlgItemInt(hdlg, %IDC_LF_WIDTH, %NULL, %TRUE)
@pdp.lf.lfEscapement = GetDlgItemInt(hdlg, %IDC_LF_ESCAPE, %NULL, %TRUE)
@pdp.lf.lfOrientation = GetDlgItemInt(hdlg, %IDC_LF_ORIENT, %NULL, %TRUE)
@pdp.lf.lfWeight = GetDlgItemInt(hdlg, %IDC_LF_WEIGHT, %NULL, %TRUE)
@pdp.lf.lfCharSet = GetDlgItemInt(hdlg, %IDC_LF_CHARSET, %NULL, %FALSE)
@pdp.lf.lfItalic = IsDlgButtonChecked(hdlg, %IDC_LF_ITALIC) = %BST_CHECKED
@pdp.lf.lfUnderline = IsDlgButtonChecked(hdlg, %IDC_LF_UNDER) = %BST_CHECKED
@pdp.lf.lfStrikeOut = IsDlgButtonChecked(hdlg, %IDC_LF_STRIKE) = %BST_CHECKED
GetDlgItemText hdlg, %IDC_LF_FACENAME, @pdp.lf.lfFaceName, %LF_FACESIZE
END SUB
' ========================================================================================
' ========================================================================================
SUB SetFieldsFromTextMetric (BYVAL hdlg AS DWORD, BYVAL pdp AS DLGPARAMS PTR)
LOCAL szBuffer AS ASCIIZ * 10
LOCAL szYes AS ASCIIZ * 4
LOCAL szNo AS ASCIIZ * 3
DIM szFamily (6) AS ASCIIZ * 11
LOCAL BCHARFORM AS ASCIIZ * 7
LOCAL iPitchAndFamily AS LONG
BCHARFORM = "0x%02X"
szYes = "Yes"
szNo = "No"
szFamily(0) = "Don't Know"
szFamily(1) = "Roman"
szFamily(2) = "Swiss"
szFamily(3) = "Modern"
szFamily(4) = "Script"
szFamily(5) = "Decorative"
SzFamily(6) = "Undefined"
SetDlgItemInt hdlg, %IDC_TM_HEIGHT, @pdp.tm.tmHeight, %TRUE
SetDlgItemInt hdlg, %IDC_TM_ASCENT, @pdp.tm.tmAscent, %TRUE
SetDlgItemInt hdlg, %IDC_TM_DESCENT, @pdp.tm.tmDescent, %TRUE
SetDlgItemInt hdlg, %IDC_TM_INTLEAD, @pdp.tm.tmInternalLeading, %TRUE
SetDlgItemInt hdlg, %IDC_TM_EXTLEAD, @pdp.tm.tmExternalLeading, %TRUE
SetDlgItemInt hdlg, %IDC_TM_AVECHAR, @pdp.tm.tmAveCharWidth, %TRUE
SetDlgItemInt hdlg, %IDC_TM_MAXCHAR, @pdp.tm.tmMaxCharWidth, %TRUE
SetDlgItemInt hdlg, %IDC_TM_WEIGHT, @pdp.tm.tmWeight, %TRUE
SetDlgItemInt hdlg, %IDC_TM_OVERHANG, @pdp.tm.tmOverhang, %TRUE
SetDlgItemInt hdlg, %IDC_TM_DIGASPX, @pdp.tm.tmDigitizedAspectX, %TRUE
SetDlgItemInt hdlg, %IDC_TM_DIGASPY, @pdp.tm.tmDigitizedAspectY, %TRUE
wsprintf szBuffer, BCHARFORM, @pdp.tm.tmFirstChar
SetDlgItemText hdlg, %IDC_TM_FIRSTCHAR, szBuffer
wsprintf szBuffer, BCHARFORM, @pdp.tm.tmLastChar
SetDlgItemText hdlg, %IDC_TM_LASTCHAR, szBuffer
wsprintf szBuffer, BCHARFORM, @pdp.tm.tmDefaultChar
SetDlgItemText hdlg, %IDC_TM_DEFCHAR, szBuffer
wsprintf szBuffer, BCHARFORM, @pdp.tm.tmBreakChar
SetDlgItemText hdlg, %IDC_TM_BREAKCHAR, szBuffer
SetDlgItemText hdlg, %IDC_TM_ITALIC, IIF$(@pdp.tm.tmItalic = %TRUE, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_UNDER, IIF$(@pdp.tm.tmUnderlined = %TRUE, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_STRUCK, IIF$(@pdp.tm.tmStruckOut = %TRUE, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_VARIABLE, _
IIF$(%TMPF_FIXED_PITCH AND @pdp.tm.tmPitchAndFamily, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_VECTOR, _
IIF$(%TMPF_VECTOR AND @pdp.tm.tmPitchAndFamily, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_TRUETYPE, _
IIF$(%TMPF_TRUETYPE AND @pdp.tm.tmPitchAndFamily, szYes, szNo)
SetDlgItemText hdlg, %IDC_TM_DEVICE, _
IIF$(%TMPF_DEVICE AND @pdp.tm.tmPitchAndFamily, szYes, szNo)
iPitchAndFamily = @pdp.tm.tmPitchAndFamily
SHIFT RIGHT iPitchAndFamily, 4
SetDlgItemText hdlg, %IDC_TM_FAMILY, szFamily(MIN&(6, iPitchAndFamily))
SetDlgItemInt hdlg, %IDC_TM_CHARSET, @pdp.tm.tmCharSet, %FALSE
SetDlgItemText hdlg, %IDC_TM_FACENAME, @pdp.szFaceName
END SUB
' ========================================================================================
' ========================================================================================
SUB MySetMapMode (BYVAL hdc AS DWORD, BYVAL iMapMode AS LONG)
SELECT CASE iMapMode
CASE %IDC_MM_TEXT: SetMapMode hdc, %MM_TEXT
CASE %IDC_MM_LOMETRIC: SetMapMode hdc, %MM_LOMETRIC
CASE %IDC_MM_HIMETRIC: SetMapMode hdc, %MM_HIMETRIC
CASE %IDC_MM_LOENGLISH: SetMapMode hdc, %MM_LOENGLISH
CASE %IDC_MM_HIENGLISH: SetMapMode hdc, %MM_HIENGLISH
CASE %IDC_MM_TWIPS: SetMapMode hdc, %MM_TWIPS
CASE %IDC_MM_LOGTWIPS:
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
SetViewportExtEx hdc, GetDeviceCaps(hdc, %LOGPIXELSX), _
GetDeviceCaps(hdc, %LOGPIXELSY), BYVAL %NULL
END SELECT
END SUB
' ========================================================================================
PICKFONT.RC
#define WS_CHILD 0x40000000L
#define WS_VISIBLE 0x10000000L
#define WS_BORDER 0x00800000L
#define WS_GROUP 0x00020000L
#define WS_TABSTOP 0x00010000L
#define IDC_STATIC (-1)
#define ES_AUTOHSCROLL 0x0080L
#define BS_AUTORADIOBUTTON 0x00000009L
#define BS_AUTOCHECKBOX 0x00000003L
#define IDOK 1
#define IDC_LF_HEIGHT 1000
#define IDC_LF_WIDTH 1001
#define IDC_LF_ESCAPE 1002
#define IDC_LF_ORIENT 1003
#define IDC_LF_WEIGHT 1004
#define IDC_MM_TEXT 1005
#define IDC_MM_LOMETRIC 1006
#define IDC_MM_HIMETRIC 1007
#define IDC_MM_LOENGLISH 1008
#define IDC_MM_HIENGLISH 1009
#define IDC_MM_TWIPS 1010
#define IDC_MM_LOGTWIPS 1011
#define IDC_LF_ITALIC 1012
#define IDC_LF_UNDER 1013
#define IDC_LF_STRIKE 1014
#define IDC_MATCH_ASPECT 1015
#define IDC_ADV_GRAPHICS 1016
#define IDC_LF_CHARSET 1017
#define IDC_CHARSET_HELP 1018
#define IDC_DEFAULT_QUALITY 1019
#define IDC_DRAFT_QUALITY 1020
#define IDC_PROOF_QUALITY 1021
#define IDC_LF_FACENAME 1022
#define IDC_OUT_DEFAULT 1023
#define IDC_OUT_STRING 1024
#define IDC_OUT_CHARACTER 1025
#define IDC_OUT_STROKE 1026
#define IDC_OUT_TT 1027
#define IDC_OUT_DEVICE 1028
#define IDC_OUT_RASTER 1029
#define IDC_OUT_TT_ONLY 1030
#define IDC_OUT_OUTLINE 1031
#define IDC_DEFAULT_PITCH 1032
#define IDC_FIXED_PITCH 1033
#define IDC_VARIABLE_PITCH 1034
#define IDC_FF_DONTCARE 1035
#define IDC_FF_ROMAN 1036
#define IDC_FF_SWISS 1037
#define IDC_FF_MODERN 1038
#define IDC_FF_SCRIPT 1039
#define IDC_FF_DECORATIVE 1040
#define IDC_TM_HEIGHT 1041
#define IDC_TM_ASCENT 1042
#define IDC_TM_DESCENT 1043
#define IDC_TM_INTLEAD 1044
#define IDC_TM_EXTLEAD 1045
#define IDC_TM_AVECHAR 1046
#define IDC_TM_MAXCHAR 1047
#define IDC_TM_WEIGHT 1048
#define IDC_TM_OVERHANG 1049
#define IDC_TM_DIGASPX 1050
#define IDC_TM_DIGASPY 1051
#define IDC_TM_FIRSTCHAR 1052
#define IDC_TM_LASTCHAR 1053
#define IDC_TM_DEFCHAR 1054
#define IDC_TM_BREAKCHAR 1055
#define IDC_TM_ITALIC 1056
#define IDC_TM_UNDER 1057
#define IDC_TM_STRUCK 1058
#define IDC_TM_VARIABLE 1059
#define IDC_TM_VECTOR 1060
#define IDC_TM_TRUETYPE 1061
#define IDC_TM_DEVICE 1062
#define IDC_TM_FAMILY 1063
#define IDC_TM_CHARSET 1064
#define IDC_TM_FACENAME 1065
#define IDM_DEVICE_SCREEN 40001
#define IDM_DEVICE_PRINTER 40002
/////////////////////////////////////////////////////////////////////////////
// Dialog
PICKFONT DIALOG DISCARDABLE 0, 0, 348, 308
STYLE WS_CHILD | WS_VISIBLE | WS_BORDER
FONT 8, "MS Sans Serif"
BEGIN
LTEXT "&Height:",IDC_STATIC,8,10,44,8
EDITTEXT IDC_LF_HEIGHT,64,8,24,12,ES_AUTOHSCROLL
LTEXT "&Width",IDC_STATIC,8,26,44,8
EDITTEXT IDC_LF_WIDTH,64,24,24,12,ES_AUTOHSCROLL
LTEXT "Escapement:",IDC_STATIC,8,42,44,8
EDITTEXT IDC_LF_ESCAPE,64,40,24,12,ES_AUTOHSCROLL
LTEXT "Orientation:",IDC_STATIC,8,58,44,8
EDITTEXT IDC_LF_ORIENT,64,56,24,12,ES_AUTOHSCROLL
LTEXT "Weight:",IDC_STATIC,8,74,44,8
EDITTEXT IDC_LF_WEIGHT,64,74,24,12,ES_AUTOHSCROLL
GROUPBOX "Mapping Mode",IDC_STATIC,97,3,96,90,WS_GROUP
CONTROL "Text",IDC_MM_TEXT,"Button",BS_AUTORADIOBUTTON,104,13,56,
8
CONTROL "Low Metric",IDC_MM_LOMETRIC,"Button",BS_AUTORADIOBUTTON,
104,24,56,8
CONTROL "High Metric",IDC_MM_HIMETRIC,"Button",
BS_AUTORADIOBUTTON,104,35,56,8
CONTROL "Low English",IDC_MM_LOENGLISH,"Button",
BS_AUTORADIOBUTTON,104,46,56,8
CONTROL "High English",IDC_MM_HIENGLISH,"Button",
BS_AUTORADIOBUTTON,104,57,56,8
CONTROL "Twips",IDC_MM_TWIPS,"Button",BS_AUTORADIOBUTTON,104,68,
56,8
CONTROL "Logical Twips",IDC_MM_LOGTWIPS,"Button",
BS_AUTORADIOBUTTON,104,79,64,8
CONTROL "Italic",IDC_LF_ITALIC,"Button",BS_AUTOCHECKBOX |
WS_TABSTOP,8,90,48,12
CONTROL "Underline",IDC_LF_UNDER,"Button",BS_AUTOCHECKBOX |
WS_TABSTOP,8,104,48,12
CONTROL "Strike Out",IDC_LF_STRIKE,"Button",BS_AUTOCHECKBOX |
WS_TABSTOP,8,118,48,12
CONTROL "Match Aspect",IDC_MATCH_ASPECT,"Button",BS_AUTOCHECKBOX |
WS_TABSTOP,60,104,62,8
CONTROL "Adv Grfx Mode",IDC_ADV_GRAPHICS,"Button",
BS_AUTOCHECKBOX | WS_TABSTOP,60,118,62,8
LTEXT "Character Set:",IDC_STATIC,8,137,46,8
EDITTEXT IDC_LF_CHARSET,58,135,24,12,ES_AUTOHSCROLL
PUSHBUTTON "?",IDC_CHARSET_HELP,90,135,14,14
GROUPBOX "Quality",IDC_STATIC,132,98,62,48,WS_GROUP
CONTROL "Default",IDC_DEFAULT_QUALITY,"Button",
BS_AUTORADIOBUTTON,136,110,40,8
CONTROL "Draft",IDC_DRAFT_QUALITY,"Button",BS_AUTORADIOBUTTON,
136,122,40,8
CONTROL "Proof",IDC_PROOF_QUALITY,"Button",BS_AUTORADIOBUTTON,
136,134,40,8
LTEXT "Face Name:",IDC_STATIC,8,154,44,8
EDITTEXT IDC_LF_FACENAME,58,152,136,12,ES_AUTOHSCROLL
GROUPBOX "Output Precision",IDC_STATIC,8,166,118,133,WS_GROUP
CONTROL "OUT_DEFAULT_PRECIS",IDC_OUT_DEFAULT,"Button",
BS_AUTORADIOBUTTON,12,178,112,8
CONTROL "OUT_STRING_PRECIS",IDC_OUT_STRING,"Button",
BS_AUTORADIOBUTTON,12,191,112,8
CONTROL "OUT_CHARACTER_PRECIS",IDC_OUT_CHARACTER,"Button",
BS_AUTORADIOBUTTON,12,204,112,8
CONTROL "OUT_STROKE_PRECIS",IDC_OUT_STROKE,"Button",
BS_AUTORADIOBUTTON,12,217,112,8
CONTROL "OUT_TT_PRECIS",IDC_OUT_TT,"Button",BS_AUTORADIOBUTTON,
12,230,112,8
CONTROL "OUT_DEVICE_PRECIS",IDC_OUT_DEVICE,"Button",
BS_AUTORADIOBUTTON,12,243,112,8
CONTROL "OUT_RASTER_PRECIS",IDC_OUT_RASTER,"Button",
BS_AUTORADIOBUTTON,12,256,112,8
CONTROL "OUT_TT_ONLY_PRECIS",IDC_OUT_TT_ONLY,"Button",
BS_AUTORADIOBUTTON,12,269,112,8
CONTROL "OUT_OUTLINE_PRECIS",IDC_OUT_OUTLINE,"Button",
BS_AUTORADIOBUTTON,12,282,112,8
GROUPBOX "Pitch",IDC_STATIC,132,166,62,50,WS_GROUP
CONTROL "Default",IDC_DEFAULT_PITCH,"Button",BS_AUTORADIOBUTTON,
137,176,52,8
CONTROL "Fixed",IDC_FIXED_PITCH,"Button",BS_AUTORADIOBUTTON,137,
189,52,8
CONTROL "Variable",IDC_VARIABLE_PITCH,"Button",
BS_AUTORADIOBUTTON,137,203,52,8
GROUPBOX "Family",IDC_STATIC,132,218,62,82,WS_GROUP
CONTROL "Don't Care",IDC_FF_DONTCARE,"Button",BS_AUTORADIOBUTTON,
137,229,52,8
CONTROL "Roman",IDC_FF_ROMAN,"Button",BS_AUTORADIOBUTTON,137,241,
52,8
CONTROL "Swiss",IDC_FF_SWISS,"Button",BS_AUTORADIOBUTTON,137,253,
52,8
CONTROL "Modern",IDC_FF_MODERN,"Button",BS_AUTORADIOBUTTON,137,
265,52,8
CONTROL "Script",IDC_FF_SCRIPT,"Button",BS_AUTORADIOBUTTON,137,
277,52,8
CONTROL "Decorative",IDC_FF_DECORATIVE,"Button",
BS_AUTORADIOBUTTON,137,289,52,8
DEFPUSHBUTTON "OK",IDOK,247,286,50,14
GROUPBOX "Text Metrics",IDC_STATIC,201,2,140,272,WS_GROUP
LTEXT "Height:",IDC_STATIC,207,12,64,8
LTEXT "0",IDC_TM_HEIGHT,281,12,44,8
LTEXT "Ascent:",IDC_STATIC,207,22,64,8
LTEXT "0",IDC_TM_ASCENT,281,22,44,8
LTEXT "Descent:",IDC_STATIC,207,32,64,8
LTEXT "0",IDC_TM_DESCENT,281,32,44,8
LTEXT "Internal Leading:",IDC_STATIC,207,42,64,8
LTEXT "0",IDC_TM_INTLEAD,281,42,44,8
LTEXT "External Leading:",IDC_STATIC,207,52,64,8
LTEXT "0",IDC_TM_EXTLEAD,281,52,44,8
LTEXT "Ave Char Width:",IDC_STATIC,207,62,64,8
LTEXT "0",IDC_TM_AVECHAR,281,62,44,8
LTEXT "Max Char Width:",IDC_STATIC,207,72,64,8
LTEXT "0",IDC_TM_MAXCHAR,281,72,44,8
LTEXT "Weight:",IDC_STATIC,207,82,64,8
LTEXT "0",IDC_TM_WEIGHT,281,82,44,8
LTEXT "Overhang:",IDC_STATIC,207,92,64,8
LTEXT "0",IDC_TM_OVERHANG,281,92,44,8
LTEXT "Digitized Aspect X:",IDC_STATIC,207,102,64,8
LTEXT "0",IDC_TM_DIGASPX,281,102,44,8
LTEXT "Digitized Aspect Y:",IDC_STATIC,207,112,64,8
LTEXT "0",IDC_TM_DIGASPY,281,112,44,8
LTEXT "First Char:",IDC_STATIC,207,122,64,8
LTEXT "0",IDC_TM_FIRSTCHAR,281,122,44,8
LTEXT "Last Char:",IDC_STATIC,207,132,64,8
LTEXT "0",IDC_TM_LASTCHAR,281,132,44,8
LTEXT "Default Char:",IDC_STATIC,207,142,64,8
LTEXT "0",IDC_TM_DEFCHAR,281,142,44,8
LTEXT "Break Char:",IDC_STATIC,207,152,64,8
LTEXT "0",IDC_TM_BREAKCHAR,281,152,44,8
LTEXT "Italic?",IDC_STATIC,207,162,64,8
LTEXT "0",IDC_TM_ITALIC,281,162,44,8
LTEXT "Underlined?",IDC_STATIC,207,172,64,8
LTEXT "0",IDC_TM_UNDER,281,172,44,8
LTEXT "Struck Out?",IDC_STATIC,207,182,64,8
LTEXT "0",IDC_TM_STRUCK,281,182,44,8
LTEXT "Variable Pitch?",IDC_STATIC,207,192,64,8
LTEXT "0",IDC_TM_VARIABLE,281,192,44,8
LTEXT "Vector Font?",IDC_STATIC,207,202,64,8
LTEXT "0",IDC_TM_VECTOR,281,202,44,8
LTEXT "TrueType Font?",IDC_STATIC,207,212,64,8
LTEXT "0",IDC_TM_TRUETYPE,281,212,44,8
LTEXT "Device Font?",IDC_STATIC,207,222,64,8
LTEXT "0",IDC_TM_DEVICE,281,222,44,8
LTEXT "Family:",IDC_STATIC,207,232,64,8
LTEXT "0",IDC_TM_FAMILY,281,232,44,8
LTEXT "Character Set:",IDC_STATIC,207,242,64,8
LTEXT "0",IDC_TM_CHARSET,281,242,44,8
LTEXT "0",IDC_TM_FACENAME,207,262,128,8
END
/////////////////////////////////////////////////////////////////////////////
// Menu
PICKFONT MENU DISCARDABLE
BEGIN
POPUP "&Device"
BEGIN
MENUITEM "&Screen", IDM_DEVICE_SCREEN, CHECKED
MENUITEM "&Printer", IDM_DEVICE_PRINTER
END
END
This program is a translation of POEPOEM.C -- Demonstrates Custom Resource © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
Let's look at a sample program that uses three resources-an icon, a string table, and a custom resource. The POEPOEM program, shown in Figure 10-5 beginning below, displays the text of Edgar Allan Poe's "Annabel Lee" in its client area. The custom resource is the file POEPOEM.TXT, which contains the text of the poem. The text file is terminated with a backslash (\).
' ========================================================================================
' POEPOEM.BAS
' This program is a translation/adaptation of POEPOEM.C -- Demonstrates Custom Resource
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' Let's look at a sample program that uses three resources-an icon, a string table, and a
' custom resource. The POEPOEM program, shown in Figure 10-5 beginning below, displays the
' text of Edgar Allan Poe's "Annabel Lee" in its client area. The custom resource is the
' file POEPOEM.TXT, which contains the text of the poem. The text file is terminated with
' a backslash (\).
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "poepoem.res"
%IDS_APPNAME = 1
%IDS_CAPTION = 2
%IDS_ERRMSG = 3
GLOBAL hInst AS DWORD
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 16
LOCAL szCaption AS ASCIIZ * 64
LOCAL szErrMsg AS ASCIIZ * 64
LOCAL wcex AS WNDCLASSEX
hInst = hInstance
LoadString hInstance, %IDS_APPNAME, szAppName, SIZEOF(szAppName)
LoadString hInstance, %IDS_CAPTION, szCaption, SIZEOF(szCaption)
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
LoadString hInstance, %IDS_APPNAME, szAppName, SIZEOF(szAppName)
LoadString hInstance, %IDS_ERRMSG, szErrMsg, SIZEOF(szErrMsg)
MessageBox %NULL, szErrMsg, szAppName, %MB_ICONERROR
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
IF IsDialogMessage(hwnd, uMsg) = 0 THEN
TranslateMessage uMsg
DispatchMessage uMsg
END IF
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC pText AS BYTE PTR
STATIC hResource AS DWORD
STATIC hScroll AS DWORD
STATIC iPosition AS LONG
STATIC cxChar AS LONG
STATIC cyChar AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC iNumLines AS LONG
STATIC xScroll AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL rc AS RECT
LOCAL tm AS TEXTMETRIC
SELECT CASE uMsg
CASE %WM_CREATE
hdc = GetDC(hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
xScroll = GetSystemMetrics(%SM_CXVSCROLL)
hScroll = CreateWindowEx(0, "scrollbar", BYVAL %NULL, _
%WS_CHILD OR %WS_VISIBLE OR %SBS_VERT, _
0, 0, 0, 0, _
hwnd, 1, hInst, BYVAL %NULL)
hResource = LoadResource (hInst, _
FindResource (hInst, "AnnabelLee", "TEXT"))
pText = LockResource(hResource)
iNumLines = 0
' Read characters until we found a backslah or a nul
WHILE @pText <> 92 AND @pText <> 0
' If it is a line fee, increse the count of lines
IF @pText = 10 THEN iNumLines = iNumLines + 1
' Petzold uses AnsiNext, now obsolete
pText = CharNext(BYVAL pText)
WEND
@pText = 0
SetScrollRange hScroll, %SB_CTL, 0, iNumLines, %FALSE
SetScrollPos hScroll, %SB_CTL, 0, %FALSE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDCANCEL
IF HI(WORD, wParam) = %BN_CLICKED THEN
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cyClient = HI(WORD, lParam)
MoveWindow hScroll, LO(WORD, lParam) - xScroll, 0, xScroll, cyClient, %TRUE
SetFocus hwnd
EXIT FUNCTION
CASE %WM_SETFOCUS
SetFocus hScroll
EXIT FUNCTION
CASE %WM_VSCROLL
SELECT CASE wParam
CASE %SB_TOP
iPosition = 0
CASE %SB_BOTTOM
iPosition = iNumLines
CASE %SB_LINEUP
iPosition = iPosition - 1
CASE %SB_LINEDOWN
iPosition = iPosition + 1
CASE %SB_PAGEUP
iPosition = iPosition - cyClient / cyChar
CASE %SB_PAGEDOWN
iPosition = iPosition + cyClient / cyChar
CASE %SB_THUMBPOSITION
iPosition = LO(WORD, lParam)
END SELECT
iPosition = MAX&(0, MIN&(iPosition, iNumLines))
IF iPosition <> GetScrollPos (hScroll, %SB_CTL) THEN
SetScrollPos hScroll, %SB_CTL, iPosition, %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
pText = LockResource(hResource)
GetClientRect hwnd, rc
rc.nLeft = rc.nLeft + cxChar
rc.nTop = rc.nTop + cyChar * (1 - iPosition)
DrawText hdc, BYVAL pText, -1, rc, %DT_EXTERNALLEADING
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
FreeResource hResource
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of POORMENU.C -- The Poor Person's Menu © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
The program POORMENU ("Poor Person's Menu") adds a separator bar and three commands to the system menu. The last of these commands removes the additions.
' ========================================================================================
' POORMENU.BAS
' This program is a translation/adaptation of POORMENU.C -- The Poor Person's Menu
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' The program POORMENU ("Poor Person's Menu") adds a separator bar and three commands to
' the system menu. The last of these commands removes the additions.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%IDM_SYS_ABOUT = 1
%IDM_SYS_HELP = 2
%IDM_SYS_REMOVE = 3
GLOBAL szAppName AS ASCIIZ * 256
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hMenu AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "PoorMenu"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "The Poor-Person's Menu"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
hMenu = GetSystemMenu(hwnd, %FALSE)
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, %MF_STRING, %IDM_SYS_ABOUT, "About..."
AppendMenu hMenu, %MF_STRING, %IDM_SYS_HELP, "Help..."
AppendMenu hMenu, %MF_STRING, %IDM_SYS_REMOVE, "Remove Additions"
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_SYSCOMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_SYS_ABOUT
MessageBox hwnd, "A Poor-Person's Menu Program" & $LF & _
"(c) Charles Petzold, 1998", _
szAppName, %MB_OK OR %MB_ICONINFORMATION
EXIT FUNCTION
CASE %IDM_SYS_HELP
MessageBox hwnd, "Help not yet implemented!", _
szAppName, %MB_OK OR %MB_ICONEXCLAMATION
EXIT FUNCTION
CASE %IDM_SYS_REMOVE
GetSystemMenu hwnd, %TRUE
EXIT FUNCTION
END SELECT
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of POPMENU.C -- Popup Menu Demonstration © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.
You can also make use of menus without having a top-level menu bar. You can instead cause a popup menu to appear on top of any part of the screen. One approach is to invoke this popup menu in response to a click of the right mouse button. The POPMENU program in shows how this is done.
' ========================================================================================
' POPMENU.BAS
' This program is a translation/adaptation of POPMENU.C -- Popup Menu Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' You can also make use of menus without having a top-level menu bar. You can instead
' cause a popup menu to appear on top of any part of the screen. One approach is to invoke
' this popup menu in response to a click of the right mouse button. The POPMENU program in
' shows how this is done.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "popmenu.res"
%IDM_FILE_NEW = 40001
%IDM_FILE_OPEN = 40002
%IDM_FILE_SAVE = 40003
%IDM_FILE_SAVE_AS = 40004
%IDM_APP_EXIT = 40005
%IDM_EDIT_UNDO = 40006
%IDM_EDIT_CUT = 40007
%IDM_EDIT_COPY = 40008
%IDM_EDIT_PASTE = 40009
%IDM_EDIT_CLEAR = 40010
%IDM_BKGND_WHITE = 40011
%IDM_BKGND_LTGRAY = 40012
%IDM_BKGND_GRAY = 40013
%IDM_BKGND_DKGRAY = 40014
%IDM_BKGND_BLACK = 40015
%IDM_APP_HELP = 40016
%IDM_APP_ABOUT = 40017
GLOBAL hInst AS DWORD
GLOBAL szAppName AS ASCIIZ * 256
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
hInst = hInstance
szAppName = "PopMenu"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Popup Menu Demonstration"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hMenu AS DWORD
DIM idColor(0 TO 4) AS STATIC LONG
STATIC iSelection AS LONG
LOCAL pt AS POINTAPI
SELECT CASE uMsg
CASE %WM_CREATE
idColor(0) = %WHITE_BRUSH
idColor(1) = %LTGRAY_BRUSH
idColor(2) = %GRAY_BRUSH
idColor(3) = %DKGRAY_BRUSH
idColor(4) = %BLACK_BRUSH
iSelection = %IDM_BKGND_WHITE
hMenu = LoadMenu(hInst, szAppName)
hMenu = GetSubMenu(hMenu, 0)
EXIT FUNCTION
CASE %WM_RBUTTONUP
pt.x = LO(WORD, lParam)
pt.y = HI(WORD, lParam)
ClientToScreen hwnd, pt
TrackPopupMenu hMenu, %TPM_RIGHTBUTTON, pt.x, pt.y, 0, hwnd, BYVAL %NULL
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_NEW, _
%IDM_FILE_OPEN, _
%IDM_FILE_SAVE, _
%IDM_FILE_SAVE_AS, _
%IDM_EDIT_UNDO, _
%IDM_EDIT_CUT, _
%IDM_EDIT_COPY, _
%IDM_EDIT_PASTE, _
%IDM_EDIT_CLEAR
MessageBeep 0
CASE %IDM_BKGND_WHITE, _ ' // Note: Logic below
%IDM_BKGND_LTGRAY, _ ' // assumes that IDM_WHITE
%IDM_BKGND_GRAY, _ ' // through IDM_BLACK are
%IDM_BKGND_DKGRAY, _ ' // consecutive numbers in
%IDM_BKGND_BLACK ' // the order shown here.
CheckMenuItem hMenu, iSelection, %MF_UNCHECKED
iSelection = LO(WORD, wParam)
CheckMenuItem hMenu, iSelection, %MF_CHECKED
SetClassLong hwnd, %GCL_HBRBACKGROUND, _
GetStockObject(idColor(LO(WORD, wParam) - %IDM_BKGND_WHITE))
InvalidateRect hwnd, BYVAL %NULL, %TRUE
CASE %IDM_APP_ABOUT
MessageBox hwnd, "Popup Menu Demonstration Program" & $LF & _
"(c) Charles Petzold, 1998", _
"PopMenu", %MB_ICONINFORMATION OR %MB_OK
CASE %IDM_APP_EXIT:
SendMessage hwnd, %WM_CLOSE, 0, 0
CASE %IDM_APP_HELP
MessageBox hwnd, "Help not yet implemented!", _
"PopMenu", %MB_ICONEXCLAMATION OR %MB_OK
END SELECT
EXIT FUNCTION
CASE %WM_TIMER
MessageBeep 0
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
POPMENU.RC
#define IDM_FILE_NEW 40001
#define IDM_FILE_OPEN 40002
#define IDM_FILE_SAVE 40003
#define IDM_FILE_SAVE_AS 40004
#define IDM_APP_EXIT 40005
#define IDM_EDIT_UNDO 40006
#define IDM_EDIT_CUT 40007
#define IDM_EDIT_COPY 40008
#define IDM_EDIT_PASTE 40009
#define IDM_EDIT_CLEAR 40010
#define IDM_BKGND_WHITE 40011
#define IDM_BKGND_LTGRAY 40012
#define IDM_BKGND_GRAY 40013
#define IDM_BKGND_DKGRAY 40014
#define IDM_BKGND_BLACK 40015
#define IDM_APP_HELP 40016
#define IDM_APP_ABOUT 40017
//////////////////////////////////////////////////////////////////////////////
// Menu
POPMENU MENU DISCARDABLE
BEGIN
POPUP "MyMenu"
BEGIN
POPUP "&File"
BEGIN
MENUITEM "&New", IDM_FILE_NEW
MENUITEM "&Open", IDM_FILE_OPEN
MENUITEM "&Save", IDM_FILE_SAVE
MENUITEM "Save &As", IDM_FILE_SAVE_AS
MENUITEM SEPARATOR
MENUITEM "E&xit", IDM_APP_EXIT
END
POPUP "&Edit"
BEGIN
MENUITEM "&Undo", IDM_EDIT_UNDO
MENUITEM SEPARATOR
MENUITEM "Cu&t", IDM_EDIT_CUT
MENUITEM "&Copy", IDM_EDIT_COPY
MENUITEM "&Paste", IDM_EDIT_PASTE
MENUITEM "De&lete", IDM_EDIT_CLEAR
END
POPUP "&Background"
BEGIN
MENUITEM "&White", IDM_BKGND_WHITE, CHECKED
MENUITEM "&Light Gray", IDM_BKGND_LTGRAY
MENUITEM "&Gray", IDM_BKGND_GRAY
MENUITEM "&Dark Gray", IDM_BKGND_DKGRAY
MENUITEM "&Black", IDM_BKGND_BLACK
END
POPUP "&Help"
BEGIN
MENUITEM "&Help...", IDM_APP_HELP
MENUITEM "&About PopMenu...", IDM_APP_ABOUT
END
END
END
This program is a translation of PRINT1.C -- Bare Bones Printing © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.
After compiling PRINT1, you can execute it and then select Print from the system menu. In quick succession, GDI saves the necessary printer output in a temporary file, and then the spooler sends it to the printer.
' ========================================================================================
' PRINT1.BAS
' This program is a translation/adaptation of PRINT1.C -- Bare Bones Printing
' © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming
' Windows, 5th Edition.
' After compiling PRINT1, you can execute it and then select Print from the system menu.
' In quick succession, GDI saves the necessary printer output in a temporary file, and
' then the spooler sends it to the printer.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
GLOBAL hInst AS DWORD
GLOBAL szAppName AS ASCIIZ * 256
GLOBAL szCaption AS ASCIIZ * 256
' ========================================================================================
' GetPrinterDC function
' Methods for obtaining the default printer device context have changed over the years.
' Currently, the standard method involves using the EnumPrinters function. This function
' fills an array of structures that contain information about each attached printer. You
' even have a choice of several structures to use with this function, depending on the
' level of detail you want. These structures have names of PRINTER_INFO_x, where x is a
' number.
' ========================================================================================
FUNCTION GetPrinterDC () AS DWORD
LOCAL dwLevel AS DWORD
LOCAL dwFlags AS DWORD
LOCAL dwNeeded AS DWORD
LOCAL dwReturned AS DWORD
LOCAL hdc AS DWORD
LOCAL tos AS OSVERSIONINFO
LOCAL pinfo4 AS PRINTER_INFO_4 PTR
LOCAL pinfo5 AS PRINTER_INFO_5 PTR
dwLevel = 5
dwFlags = %PRINTER_ENUM_LOCAL
IF ISTRUE GetVersionEx(tos) THEN
IF tos.dwPlatformId = %VER_PLATFORM_WIN32_NT THEN
dwLevel = 4
dwFlags = %PRINTER_ENUM_NETWORK OR %PRINTER_ENUM_LOCAL
END IF
END IF
EnumPrinters dwFlags, "", dwLevel, BYVAL %NULL, 0, dwNeeded, dwReturned
IF dwLevel = 4 THEN
pInfo4 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo4, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", @pInfo4.@pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo4
ELSE
pInfo5 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo5, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", BYVAL @pInfo5.pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo5
END IF
FUNCTION = hdc
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PageGDICalls (BYVAL hdcPrn AS DWORD, BYVAL cxPage AS LONG, BYVAL cyPage AS LONG)
LOCAL szTextStr AS ASCIIZ * 267
szTextStr = "Hello, Printer!"
Rectangle hdcPrn, 0, 0, cxPage, cyPage
MoveToEx hdcPrn, 0, 0, BYVAL %NULL
LineTo hdcPrn, cxPage, cyPage
MoveToEx hdcPrn, cxPage, 0, BYVAL %NULL
LineTo hdcPrn, 0, cyPage
SaveDC hdcPrn
SetMapMode hdcPrn, %MM_ISOTROPIC
SetWindowExtEx hdcPrn, 1000, 1000, BYVAL %NULL
SetViewportExtEx hdcPrn, cxPage \ 2, -cyPage \ 2, BYVAL %NULL
SetViewportOrgEx hdcPrn, cxPage \ 2, cyPage \ 2, BYVAL %NULL
Ellipse hdcPrn, -500, 500, 500, -500
SetTextAlign hdcPrn, %TA_BASELINE OR %TA_CENTER
TextOut hdcPrn, 0, 0, szTextStr, LEN(szTextStr)
RestoreDC hdcPrn, -1
END SUB
' ========================================================================================
' ========================================================================================
FUNCTION PrintMyPage (BYVAL hwnd AS DWORD) AS LONG
LOCAL dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL xPage AS LONG
LOCAL yPage AS LONG
szDocName = "Print1: Printing"
bSuccess = %TRUE
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
hdcPrn = GetPrinterDC
IF hdcPrn = %NULL THEN EXIT FUNCTION
xPage = GetDeviceCaps(hdcPrn, %HORZRES)
yPage = GetDeviceCaps(hdcPrn, %VERTRES)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PageGDICalls hdcPrn, xPage, yPage
IF EndPage(hdcPrn) > 0 THEN
EndDoc hdcPrn
ELSE
bSuccess = %FALSE
END IF
END IF
ELSE
bSuccess = %FALSE
END IF
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
hInst = hInstance
szAppName = "Print1"
szCaption = "Print Program 1"
szAppName = "IconDemo"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL hMenu AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
hMenu = GetSystemMenu(hwnd, %FALSE)
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, 0, 1, "&Print"
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_SYSCOMMAND
IF wParam = 1 THEN
IF ISFALSE PrintMyPage(hwnd) THEN
MessageBox hwnd, "Could not print page!", _
szAppName, %MB_OK OR %MB_ICONEXCLAMATION
EXIT FUNCTION
END IF
END IF
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PageGDICalls hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of PRINT2.C -- Printing with Abort Procedure © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.
The PRINT2 program adds to PRINT1 an abort procedure and the necessary support-a call to the AbortProc function and two calls to EnableWindow, the first to disable the window and the second to reenable it.
' ========================================================================================
' PRINT2.BAS
' This program is a translation/adaptation of PRINT2.C -- Printing with Abort Procedure
' © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming
' Windows, 5th Edition.
' The PRINT2 program adds to PRINT1 an abort procedure and the necessary support-a call to
' the AbortProc function and two calls to EnableWindow, the first to disable the window
' and the second to reenable it.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
GLOBAL hInst AS DWORD
GLOBAL szAppName AS ASCIIZ * 256
GLOBAL szCaption AS ASCIIZ * 256
' ========================================================================================
' GetPrinterDC function
' Methods for obtaining the default printer device context have changed over the years.
' Currently, the standard method involves using the EnumPrinters function. This function
' fills an array of structures that contain information about each attached printer. You
' even have a choice of several structures to use with this function, depending on the
' level of detail you want. These structures have names of PRINTER_INFO_x, where x is a
' number.
' ========================================================================================
FUNCTION GetPrinterDC () AS DWORD
LOCAL dwLevel AS DWORD
LOCAL dwFlags AS DWORD
LOCAL dwNeeded AS DWORD
LOCAL dwReturned AS DWORD
LOCAL hdc AS DWORD
LOCAL tos AS OSVERSIONINFO
LOCAL pinfo4 AS PRINTER_INFO_4 PTR
LOCAL pinfo5 AS PRINTER_INFO_5 PTR
dwLevel = 5
dwFlags = %PRINTER_ENUM_LOCAL
IF ISTRUE GetVersionEx(tos) THEN
IF tos.dwPlatformId = %VER_PLATFORM_WIN32_NT THEN
dwLevel = 4
dwFlags = %PRINTER_ENUM_NETWORK OR %PRINTER_ENUM_LOCAL
END IF
END IF
EnumPrinters dwFlags, "", dwLevel, BYVAL %NULL, 0, dwNeeded, dwReturned
IF dwLevel = 4 THEN
pInfo4 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo4, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", @pInfo4.@pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo4
ELSE
pInfo5 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo5, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", BYVAL @pInfo5.pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo5
END IF
FUNCTION = hdc
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PageGDICalls (BYVAL hdcPrn AS DWORD, BYVAL cxPage AS LONG, BYVAL cyPage AS LONG)
LOCAL szTextStr AS ASCIIZ * 267
szTextStr = "Hello, Printer!"
Rectangle hdcPrn, 0, 0, cxPage, cyPage
MoveToEx hdcPrn, 0, 0, BYVAL %NULL
LineTo hdcPrn, cxPage, cyPage
MoveToEx hdcPrn, cxPage, 0, BYVAL %NULL
LineTo hdcPrn, 0, cyPage
SaveDC hdcPrn
SetMapMode hdcPrn, %MM_ISOTROPIC
SetWindowExtEx hdcPrn, 1000, 1000, BYVAL %NULL
SetViewportExtEx hdcPrn, cxPage \ 2, -cyPage \ 2, BYVAL %NULL
SetViewportOrgEx hdcPrn, cxPage \ 2, cyPage \ 2, BYVAL %NULL
Ellipse hdcPrn, -500, 500, 500, -500
SetTextAlign hdcPrn, %TA_BASELINE OR %TA_CENTER
TextOut hdcPrn, 0, 0, szTextStr, LEN(szTextStr)
RestoreDC hdcPrn, -1
END SUB
' ========================================================================================
' ========================================================================================
FUNCTION AbortProc (BYVAL hdcPrn AS DWORD, BYVAL iCode AS LONG) AS LONG
LOCAL uMsg AS tagMSG
WHILE PeekMessage(uMsg, %NULL, 0, 0, %PM_REMOVE)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION PrintMyPage (BYVAL hwnd AS DWORD) AS LONG
LOCAL dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL xPage AS LONG
LOCAL yPage AS LONG
szDocName = "Print2: Printing"
bSuccess = %TRUE
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
hdcPrn = GetPrinterDC
IF hdcPrn = %NULL THEN EXIT FUNCTION
xPage = GetDeviceCaps(hdcPrn, %HORZRES)
yPage = GetDeviceCaps(hdcPrn, %VERTRES)
EnableWindow hwnd, %FALSE
SetAbortProc hdcPrn, CODEPTR(AbortProc)
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PageGDICalls hdcPrn, xPage, yPage
IF EndPage(hdcPrn) > 0 THEN
EndDoc hdcPrn
ELSE
bSuccess = %FALSE
END IF
END IF
ELSE
bSuccess = %FALSE
END IF
EnableWindow hwnd, %TRUE
DeleteDC hdcPrn
FUNCTION = bSuccess
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
hInst = hInstance
szAppName = "Print2"
szCaption = "Print Program 2 (Abort Procedure)"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL hMenu AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
hMenu = GetSystemMenu(hwnd, %FALSE)
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, 0, 1, "&Print"
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_SYSCOMMAND
IF wParam = 1 THEN
IF ISFALSE PrintMyPage(hwnd) THEN
MessageBox hwnd, "Could not print page!", _
szAppName, %MB_OK OR %MB_ICONEXCLAMATION
EXIT FUNCTION
END IF
END IF
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PageGDICalls hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of PRINT3.C -- Printing with Dialog Box © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.
The PRINT3 program adds a printing dialog box to the PRINT2 program to give the user the opportunity to cancel the print job while it is spooling. If you experiment with PRINT3, you may want to temporarily disable print spooling. Otherwise, the Cancel button, which is visible only while the spooler collects data from PRINT3, might disappear too quickly for you to actually click on it. Don't be surprised if things don't come to an immediate halt when you click the Cancel button, especially on a slow printer. The printer has an internal buffer that must drain before the printer stops. Clicking Cancel merely tells GDI not to send any more data to the printer's buffer.
Two global variables are added to PRINT3: a boolean called bUserAbort and a handle to the dialog box window called hDlgPrint. The PrintMyPage function initializes bUserAbort to FALSE, and as in PRINT2, the program's main window is disabled. The pointer to AbortProc is used in the SetAbortProc call, and the pointer to PrintDlgProc is used in a CreateDialog call. The window handle returned from CreateDialog is saved in hDlgPrint.
' ========================================================================================
' PRINT3.BAS
' This program is a translation/adaptation of PRINT3.C -- Printing with Dialog Box
' © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming
' Windows, 5th Edition.
' The PRINT3 program adds a printing dialog box to the PRINT2 program to give the user the
' opportunity to cancel the print job while it is spooling.
' If you experiment with PRINT3, you may want to temporarily disable print spooling.
' Otherwise, the Cancel button, which is visible only while the spooler collects data from
' PRINT3, might disappear too quickly for you to actually click on it. Don't be surprised
' if things don't come to an immediate halt when you click the Cancel button, especially
' on a slow printer. The printer has an internal buffer that must drain before the printer
' stops. Clicking Cancel merely tells GDI not to send any more data to the printer's
' buffer.
' Two global variables are added to PRINT3: a boolean called bUserAbort and a handle to
' the dialog box window called hDlgPrint. The PrintMyPage function initializes bUserAbort
' to FALSE, and as in PRINT2, the program's main window is disabled. The pointer to
' AbortProc is used in the SetAbortProc call, and the pointer to PrintDlgProc is used in
' a CreateDialog call. The window handle returned from CreateDialog is saved in hDlgPrint.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "print.res"
GLOBAL hInst AS DWORD
GLOBAL szAppName AS ASCIIZ * 256
GLOBAL szCaption AS ASCIIZ * 256
GLOBAL bUserAbort AS LONG
GLOBAL hDlgPrint AS DWORD
' ========================================================================================
' GetPrinterDC function
' Methods for obtaining the default printer device context have changed over the years.
' Currently, the standard method involves using the EnumPrinters function. This function
' fills an array of structures that contain information about each attached printer. You
' even have a choice of several structures to use with this function, depending on the
' level of detail you want. These structures have names of PRINTER_INFO_x, where x is a
' number.
' ========================================================================================
FUNCTION GetPrinterDC () AS DWORD
LOCAL dwLevel AS DWORD
LOCAL dwFlags AS DWORD
LOCAL dwNeeded AS DWORD
LOCAL dwReturned AS DWORD
LOCAL hdc AS DWORD
LOCAL tos AS OSVERSIONINFO
LOCAL pinfo4 AS PRINTER_INFO_4 PTR
LOCAL pinfo5 AS PRINTER_INFO_5 PTR
dwLevel = 5
dwFlags = %PRINTER_ENUM_LOCAL
IF ISTRUE GetVersionEx(tos) THEN
IF tos.dwPlatformId = %VER_PLATFORM_WIN32_NT THEN
dwLevel = 4
dwFlags = %PRINTER_ENUM_NETWORK OR %PRINTER_ENUM_LOCAL
END IF
END IF
EnumPrinters dwFlags, "", dwLevel, BYVAL %NULL, 0, dwNeeded, dwReturned
IF dwLevel = 4 THEN
pInfo4 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo4, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", @pInfo4.@pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo4
ELSE
pInfo5 = CoTaskMemAlloc(dwNeeded)
EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo5, dwNeeded, dwNeeded, dwReturned
hdc = CreateDC("", BYVAL @pInfo5.pPrinterName, "", BYVAL %NULL)
CoTaskMemFree pInfo5
END IF
FUNCTION = hdc
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB PageGDICalls (BYVAL hdcPrn AS DWORD, BYVAL cxPage AS LONG, BYVAL cyPage AS LONG)
LOCAL szTextStr AS ASCIIZ * 267
szTextStr = "Hello, Printer!"
Rectangle hdcPrn, 0, 0, cxPage, cyPage
MoveToEx hdcPrn, 0, 0, BYVAL %NULL
LineTo hdcPrn, cxPage, cyPage
MoveToEx hdcPrn, cxPage, 0, BYVAL %NULL
LineTo hdcPrn, 0, cyPage
SaveDC hdcPrn
SetMapMode hdcPrn, %MM_ISOTROPIC
SetWindowExtEx hdcPrn, 1000, 1000, BYVAL %NULL
SetViewportExtEx hdcPrn, cxPage \ 2, -cyPage \ 2, BYVAL %NULL
SetViewportOrgEx hdcPrn, cxPage \ 2, cyPage \ 2, BYVAL %NULL
Ellipse hdcPrn, -500, 500, 500, -500
SetTextAlign hdcPrn, %TA_BASELINE OR %TA_CENTER
TextOut hdcPrn, 0, 0, szTextStr, LEN(szTextStr)
RestoreDC hdcPrn, -1
END SUB
' ========================================================================================
' ========================================================================================
FUNCTION PrintDlgProc (BYVAL hDlg AS DWORD, BYVAL message AS DWORD, _
BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE message
CASE %WM_INITDIALOG
SetWindowText hDlg, szAppName
EnableMenuItem GetSystemMenu(hDlg, %FALSE), %SC_CLOSE, %MF_GRAYED
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_COMMAND
bUserAbort = %TRUE
EnableWindow GetParent(hDlg), %TRUE
DestroyWindow hDlg
hDlgPrint = %NULL
FUNCTION = %TRUE
EXIT FUNCTION
END SELECT
FUNCTION = %FALSE
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AbortProc (BYVAL hdcPrn AS DWORD, BYVAL iCode AS LONG) AS LONG
LOCAL uMsg AS tagMSG
WHILE (NOT bUserAbort) AND PeekMessage(uMsg, %NULL, 0, 0, %PM_REMOVE)
IF ISFALSE hDlgPrint OR ISFALSE IsDialogMessage(hDlgPrint, uMsg) THEN
TranslateMessage uMsg
DispatchMessage uMsg
END IF
WEND
FUNCTION = NOT bUserAbort
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION PrintMyPage (BYVAL hwnd AS DWORD) AS LONG
LOCAL dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL bSuccess AS LONG
LOCAL hdcPrn AS DWORD
LOCAL xPage AS LONG
LOCAL yPage AS LONG
szDocName = "Print3: Printing"
bSuccess = %TRUE
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
hdcPrn = GetPrinterDC
IF hdcPrn = %NULL THEN EXIT FUNCTION
xPage = GetDeviceCaps(hdcPrn, %HORZRES)
yPage = GetDeviceCaps(hdcPrn, %VERTRES)
EnableWindow hwnd, %FALSE
SetAbortProc hdcPrn, CODEPTR(AbortProc)
hDlgPrint = CreateDialog(hInst, "PrintDlgBox", hwnd, CODEPTR(PrintDlgProc))
IF StartDoc(hdcPrn, dinfo) > 0 THEN
IF StartPage(hdcPrn) > 0 THEN
PageGDICalls hdcPrn, xPage, yPage
IF EndPage(hdcPrn) > 0 THEN
EndDoc hdcPrn
ELSE
bSuccess = %FALSE
END IF
END IF
ELSE
bSuccess = %FALSE
END IF
IF NOT bUserAbort THEN
EnableWindow hwnd, %TRUE
DestroyWindow hDlgPrint
END IF
EnableWindow hwnd, %TRUE
DeleteDC hdcPrn
FUNCTION = bSuccess AND NOT bUserAbort
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL wcex AS WNDCLASSEX
hInst = hInstance
szAppName = "Print3"
szCaption = "Print Program 3 (Dialog Box"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL hMenu AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
hMenu = GetSystemMenu(hwnd, %FALSE)
AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
AppendMenu hMenu, 0, 1, "&Print"
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_SYSCOMMAND
IF wParam = 1 THEN
IF ISFALSE PrintMyPage(hwnd) THEN
MessageBox hwnd, "Could not print page!", _
szAppName, %MB_OK OR %MB_ICONEXCLAMATION
EXIT FUNCTION
END IF
END IF
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
PageGDICalls hdc, cxClient, cyClient
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
PRINT.RC
#define DS_MODALFRAME 0x80L /* Can be combined with WS_CAPTION */
#define WS_POPUP 0x80000000L
#define WS_VISIBLE 0x10000000L
#define WS_CAPTION 0x00C00000L /* WS_BORDER | WS_DLGFRAME */
#define WS_SYSMENU 0x00080000L
#define IDCANCEL 2
#define IDC_STATIC (-1)
/////////////////////////////////////////////////////////////////////////////
// Dialog
PRINTDLGBOX DIALOG DISCARDABLE 20, 20, 186, 63
STYLE DS_MODALFRAME | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
FONT 8, "MS Sans Serif"
BEGIN
PUSHBUTTON "Cancel",IDCANCEL,67,42,50,14
CTEXT "Cancel Printing",IDC_STATIC,7,21,172,8
END
This program is a translation of the RANDRECT.C-Displays Random Rectangles program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Relentlessly displays random rectangles.
' ========================================================================================
' RANDRECT.BAS
' This program is a translation/adaptation of the RANDRECT.C-Displays Random Rectangles
' program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Relentlessly displays random rectangles.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
GLOBAL cxClient AS LONG
GLOBAL cyClient AS LONG
' ========================================================================================
' Draws a rectangle
' ========================================================================================
SUB DrawRectangle (BYVAL hwnd AS DWORD)
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL rc AS RECT
IF (cxClient = 0) OR (cyClient = 0) THEN EXIT SUB
SetRect rc, RND * cxClient, RND * cyClient, RND * cxClient, RND * cyClient
hBrush = CreateSolidBrush(RGB(RND * 256, RND * 256, RND * 256))
hdc = GetDC(hwnd)
FillRect hdc, rc, hBrush
ReleaseDC hwnd, hdc
DeleteObject hBrush
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "RandRect"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Random Rectangles"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
DO
IF PeekMessage(uMsg, %NULL, 0, 0, %PM_REMOVE) THEN
IF (uMsg.message = %WM_QUIT) THEN EXIT LOOP
TranslateMessage uMsg
DispatchMessage uMsg
ELSE
DrawRectangle hwnd
END IF
LOOP
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of RNDRCTMT.C -- Displays Random Rectangles © Charles Petzold, 1998, described and analysed in Chapter 20 of the book Programming Windows, 5th Edition.
Relentlessly displays random rectangles. A multithreaded version of the RANDRECT program shown in Chapter 5, that used the PeekMessage loop to display a series of random rectangles.
Note: The translation uses the PowerBASIC statements THREAD CREATE and THREAD CLOSE instead of the API function CreateThread because this function can't safely be used with PowerBASIC.
' ========================================================================================
' RNDRCTTM.BAS
' This program is a translation/adaptation of RNDRCTMT.C -- Displays Random Rectangles
' © Charles Petzold, 1998, described and analysed in Chapter 20 of the book Programming
' Windows, 5th Edition.
' Relentlessly displays random rectangles. A multithreaded version of the RANDRECT program
' shown in Chapter 5. As you'll recall, RANDRECT used the PeekMessage loop to display a
' series of random rectangles.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
GLOBAL hwnd AS DWORD
GLOBAL cxClient AS LONG
GLOBAL cyClient AS LONG
GLOBAL flag AS LONG
' ========================================================================================
' Draws a rectangle
' ========================================================================================
THREAD FUNCTION DrawRectangleThread (BYVAL pvoid AS DWORD) AS DWORD
LOCAL hBrush AS DWORD
LOCAL hdc AS DWORD
LOCAL xLeft AS LONG
LOCAL xRight AS LONG
LOCAL yTop AS LONG
LOCAL yBottom AS LONG
LOCAL iRed AS LONG
LOCAL iGreen AS LONG
LOCAL iBlue AS LONG
DO
IF flag = %TRUE THEN EXIT DO
IF cxClient <> 0 OR cyClient <> 0 THEN
xLeft = RND * cxClient
xRight = RND * cxClient
yTop = RND * cyClient
yBottom = RND * cyClient
iRed = RND * 255
iGreen = RND * 255
iBlue = RND * 255
hdc = GetDC(hwnd)
hBrush = CreateSolidBrush(RGB(iRed, iGreen, iBlue))
SelectObject hdc, hBrush
Rectangle hdc, MIN&(xLeft, xRight), MIN&(yTop, yBottom), _
MAX&(xLeft, xRight), MAX&(yTop, yBottom)
ReleaseDC hwnd, hdc
DeleteObject hBrush
END IF
LOOP
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "RndRctMT"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Random Rectangles"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hThread AS DWORD
LOCAL hr AS LONG
SELECT CASE uMsg
CASE %WM_CREATE
THREAD CREATE DrawRectangleThread(0) TO hThread
THREAD CLOSE hThread TO hr
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_SYSCOMMAND
' Capture this message and send a WM_CLOSE message
IF (wParam AND &HFFF0) = %SC_CLOSE THEN
SendMessage hwnd, %WM_CLOSE, wParam, lParam
EXIT FUNCTION
END IF
CASE %WM_CLOSE
flag = %TRUE
SLEEP 50
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of BITLIB.C -- BITLIB dynamic-link library © Charles Petzold, 1998, described and analysed in Chapter 21 of the book Programming Windows, 5th Edition.
Demonstrates how to create a resource-only library file called BITLIB.DLL that contains nine bitmaps. The BITLIB.RC file lists all the separate bitmap files and assigns each one a number. To create BITLIB.DLL, you need nine bitmaps named BITMAP1.BMP, BITMAP2.BMP, and so forth. You can use the bitmaps provided on this book's companion disc or create them yourself. They are associated with numeric IDs of 1 through 9.
' ========================================================================================
' BITLIB.BAS
' This program is a translation of BITLIB.C -- BITLIB dynamic-link library
' © Charles Petzold, 1998, described and analysed in Chapter 21 of the book Programming
' Windows, 5th Edition.
' Demonstrates how to create a resource-only library file called BITLIB.DLL that contains
' nine bitmaps. The BITLIB.RC file lists all the separate bitmap files and assigns each
' one a number. To create BITLIB.DLL, you need nine bitmaps named BITMAP1.BMP, BITMAP2.BMP,
' and so forth. You can use the bitmaps provided on this book's companion disc or create
' them yourself. They are associated with numeric IDs of 1 through 9.
' ========================================================================================
#COMPILE DLL
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "bitlib.res"
BITLIB.RC
/////////////////////////////////////////////////////////////////////////////
// Bitmap
1 BITMAP DISCARDABLE "bitmap1.bmp"
2 BITMAP DISCARDABLE "bitmap2.bmp"
3 BITMAP DISCARDABLE "bitmap3.bmp"
4 BITMAP DISCARDABLE "bitmap4.bmp"
5 BITMAP DISCARDABLE "bitmap5.bmp"
6 BITMAP DISCARDABLE "bitmap6.bmp"
7 BITMAP DISCARDABLE "bitmap7.bmp"
8 BITMAP DISCARDABLE "bitmap8.bmp"
9 BITMAP DISCARDABLE "bitmap9.bmp"
This program is a translation of SHOWBIT.C -- Shows bitmaps in BITLIB dynamic-link library © Charles Petzold, 1998, described and analysed in Chapter 21 of the book Programming Windows, 5th Edition.
Reads the bitmap resources from BITLIB and displays them in its client area. You can cycle through the bitmaps by pressing a key on the keyboard.
' ========================================================================================
' SHOWBIT.BAS
' This program is a translation/adaptation of SHOWBIT.C -- Shows bitmaps in BITLIB
' dynamic-link library © Charles Petzold, 1998, described and analysed in Chapter 21 of
' the book Programming Windows, 5th Edition.
' Reads the bitmap resources from BITLIB and displays them in its client area. You can
' cycle through the bitmaps by pressing a key on the keyboard.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "BitBlt"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Show Bitmaps from BITLIB (Press Key)"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB DrawBitmap (BYVAL hdc AS DWORD, BYVAL xStart AS LONG, BYVAL yStart AS LONG, BYVAL hBitmap AS DWORD)
LOCAL bm AS BITMAP
LOCAL hMemDC AS DWORD
LOCAL pt AS POINT
hMemDC = CreateCompatibleDC(hdc)
SelectObject hMemDC, hBitmap
GetObject hBitmap, SIZEOF(BITMAP), bm
pt.x = bm.bmWidth
pt.y = bm.bmHeight
BitBlt hdc, xStart, yStart, pt.x, pt.y, hMemDC, 0, 0, %SRCCOPY
DeleteDC hMemDC
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hLibrary AS DWORD
STATIC iCurrent AS LONG
LOCAL hBitmap AS DWORD
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
iCurrent = 1
hLibrary = LoadLibrary("BITLIB.DLL")
IF hLibrary = %NULL THEN
MessageBox hwnd, "Can't load BITLIB.DLL.", "ShowBit", 0
FUNCTION = -1
EXIT FUNCTION
END IF
EXIT FUNCTION
CASE %WM_CHAR
IF hLibrary THEN
iCurrent = iCurrent + 1
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
IF hLibrary THEN
hBitmap = LoadBitmap(hLibrary, BYVAL iCurrent)
IF ISFALSE hBitmap THEN
iCurrent = 1
hBitmap = LoadBitmap(hLibrary, BYVAL iCurrent)
END IF
IF hBitmap THEN
DrawBitmap hdc, 0, 0, hBitmap
DeleteObject hBitmap
END IF
END IF
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
IF hLibrary THEN FreeLibrary hLibrary
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of SHOWDIB1.C -- Shows a DIB in the client area © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming Windows, 5th Edition.
After loading in a DIB file, the program calculates the offsets of the BITMAPINFOHEADER structure and the pixel bits within the memory block. The program also obtains the pixel width and height of the DIB. All of this information is stored in static variables. During the %WM_PAINT message, the program displays the DIB by calling SetDIBitsToDevice.
' ========================================================================================
' SHOWDIB1.BAS
' This program is a translation/adaptation of SHOWDIB1.C -- Shows a DIB in the client area
' © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming
' Windows, 5th Edition.
' After loading in a DIB file, the program calculates the offsets of the BITMAPINFOHEADER
' structure and the pixel bits within the memory block. The program also obtains the pixel
' width and height of the DIB. All of this information is stored in static variables.
' During the %WM_PAINT message, the program displays the DIB by calling SetDIBitsToDevice.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "showdib1.res"
%IDM_FILE_OPEN = 40001
%IDM_FILE_SAVE = 40002
' ========================================================================================
' Loads a DIB in memory and returns a pointer to it.
' ========================================================================================
FUNCTION DibLoadImage (BYVAL strFileName AS STRING) AS DWORD
LOCAL bSuccess AS LONG
LOCAL dwFileSize AS DWORD
LOCAL dwHighSize AS DWORD
LOCAL dwBytesRead AS DWORD
LOCAL hFile AS DWORD
LOCAL pbmfh AS BITMAPFILEHEADER PTR
hFile = CreateFile(BYCOPY strFileName, %GENERIC_READ, %FILE_SHARE_READ, _
BYVAL %NULL, %OPEN_EXISTING, %FILE_FLAG_SEQUENTIAL_SCAN, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
dwFileSize = GetFileSize(hFile, dwHighSize)
IF dwHighSize THEN
CloseHandle hFile
EXIT FUNCTION
END IF
' Read the contents of the file. Notice that pmfh has been cast as
' BITMAPFILEHEADER PTR to be able to read the header.
pbmfh = CoTaskMemAlloc(dwFileSize)
bSuccess = ReadFile (hFile, BYVAL pbmfh, dwFileSize, dwBytesRead, BYVAL %NULL)
' Check for "BM" (&H4D42, i.e. &H42 = "B", &H4D = "M", they are in reverse order)
IF ISFALSE bSuccess OR dwBytesRead <> dwFileSize OR @pbmfh.bfType <> &H4D42 THEN
CoTaskMemFree pbmfh
CloseHandle hFile
EXIT FUNCTION
END IF
' Close the file handle and return a pointer to the data read
CloseHandle hFile
FUNCTION = pbmfh
END FUNCTION
' ========================================================================================
' ========================================================================================
' Saves the image
' ========================================================================================
FUNCTION DibSaveImage (BYVAL strFileName AS STRING, BYVAL pbmfh AS BITMAPFILEHEADER PTR) AS LONG
LOCAL bSuccess AS LONG
LOCAL dwBytesWritten AS DWORD
LOCAL hFile AS DWORD
IF pbmfh = %NULL THEN EXIT FUNCTION
hFile = CreateFile(BYCOPY strFileName, %GENERIC_WRITE, 0, BYVAL %NULL, _
%CREATE_ALWAYS, %FILE_ATTRIBUTE_NORMAL, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
bSuccess = WriteFile(hFile, BYVAL pbmfh, BYVAL @pbmfh.bfSize, dwBytesWritten, BYVAL %NULL)
CloseHandle hFile
IF ISFALSE bSuccess OR dwBytesWritten <> @pbmfh.bfSize THEN
DeleteFile BYCOPY strFileName
EXIT FUNCTION
END IF
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "ShowDib1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Show DIB #1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC pbmfh AS BITMAPFILEHEADER PTR
STATIC pbmi AS BITMAPINFO PTR
STATIC pbits AS BYTE PTR
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxDib AS LONG
STATIC cyDib AS LONG
STATIC szFileName AS ASCIIZ * %MAX_PATH
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
STATIC strPath AS STRING
STATIC fOptions AS STRING
STATIC dwStyle AS DWORD
STATIC strFileSpec AS STRING
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize variables to default values
strPath = CURDIR$
fOptions = "Bitmap Files (*.BMP)|*.bmp|"
fOptions = fOptions & "All Files (*.*)|*.*"
strFileSpec = "*.BMP"
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_OPEN
' Call the OpenFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST
IF ISFALSE OpenFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "BMP", dwStyle) THEN EXIT FUNCTION
' If there is an existing DIB, free the memory
IF pbmfh THEN
CoTaskMemFree pbmfh
pbmfh = %NULL
END IF
' Load the entire DIB in memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
pbmfh = DibLoadImage(strFileSpec)
' Invalidate the client area for later update
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
InvalidateRect hwnd, BYVAL %NULL, %TRUE
IF pbmfh = %NULL THEN
MessageBox hwnd, "Cannot load DIB file", "ShowDib1", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
' Get pointers to the info structure & the bits
pbmi = pbmfh + SIZEOF(@pbmfh)
pbits = pbmfh + @pbmfh.bfOffBits
' Get the DIB width and height
cxDib = @pbmi.bmiHeader.biWidth
cyDib = ABS(@pbmi.bmiHeader.biHeight)
CASE %IDM_FILE_SAVE
' Call the SaveFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT
IF ISFALSE(SaveFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "BMP", dwStyle)) THEN EXIT FUNCTION
' Save the DIB to memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = DibSaveImage(strFileSpec, pbmfh)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Cannot load DIB file", "ShowDib1", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
' Store the width and height of the client area
cxClient = LOWRD (lParam)
cyClient = HIWRD (lParam)
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
' Enable or disable the Save menu option
IF pbmfh <> %NULL THEN
EnableMenuItem wParam, %IDM_FILE_SAVE, %MF_ENABLED
ELSE
EnableMenuItem wParam, %IDM_FILE_SAVE, %MF_GRAYED
END IF
EXIT FUNCTION
CASE %WM_PAINT
' Draw the bitmap
hdc = BeginPaint(hwnd, ps)
bSuccess = SetDIBitsToDevice(hdc, 0, 0, cxDib, cyDib, 0, 0, 0, _
cyDib, BYVAL pbits, BYVAL pbmi, %DIB_RGB_COLORS)
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
' Free the allocated memory and end the program
IF pbmfh THEN CoTaskMemFree pbmfh
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of SHOWDIB2.C -- Shows a DIB in the client area © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming Windows, 5th Edition.
Displays DIBs in actual size and stretched to the size of its client window, prints DIBs, and transfers DIBs to the clipboard.
' ========================================================================================
' SHOWDIB2.BAS
' This program is a translation/adaptation of SHOWDIB2.C -- Shows a DIB in the client area
' © Charles Petzold, 1998, described and analysed in Chapter 15 of the book Programming
' Windows, 5th Edition.
' Displays DIBs in actual size and stretched to the size of its client window, prints
' DIBs, and transfers DIBs to the clipboard.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#INCLUDE ONCE "objbase.inc"
#RESOURCE RES, "showdib2.res"
%IDM_FILE_OPEN = 40001
%IDM_SHOW_NORMAL = 40002
%IDM_SHOW_CENTER = 40003
%IDM_SHOW_STRETCH = 40004
%IDM_SHOW_ISOSTRETCH = 40005
%IDM_FILE_PRINT = 40006
%IDM_EDIT_COPY = 40007
%IDM_EDIT_CUT = 40008
%IDM_EDIT_DELETE = 40009
%IDM_FILE_SAVE = 40010
' ========================================================================================
' Loads a DIB in memory and returns a pointer to it.
' ========================================================================================
FUNCTION DibLoadImage (BYVAL strFileName AS STRING) AS DWORD
LOCAL bSuccess AS LONG
LOCAL dwFileSize AS DWORD
LOCAL dwHighSize AS DWORD
LOCAL dwBytesRead AS DWORD
LOCAL hFile AS DWORD
LOCAL pbmfh AS BITMAPFILEHEADER PTR
hFile = CreateFile(BYCOPY strFileName, %GENERIC_READ, %FILE_SHARE_READ, _
BYVAL %NULL, %OPEN_EXISTING, %FILE_FLAG_SEQUENTIAL_SCAN, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
dwFileSize = GetFileSize(hFile, dwHighSize)
IF dwHighSize THEN
CloseHandle hFile
EXIT FUNCTION
END IF
' Read the contents of the file. Notice that pmfh has been cast as
' BITMAPFILEHEADER PTR to be able to read the header.
pbmfh = CoTaskMemAlloc(dwFileSize)
bSuccess = ReadFile (hFile, BYVAL pbmfh, dwFileSize, dwBytesRead, BYVAL %NULL)
' Check for "BM" (&H4D42, i.e. &H42 = "B", &H4D = "M", they are in reverse order)
IF ISFALSE bSuccess OR dwBytesRead <> dwFileSize OR @pbmfh.bfType <> &H4D42 THEN
CoTaskMemFree pbmfh
CloseHandle hFile
EXIT FUNCTION
END IF
' Close the file handle and return a pointer to the data read
CloseHandle hFile
FUNCTION = pbmfh
END FUNCTION
' ========================================================================================
' ========================================================================================
' Saves the image
' ========================================================================================
FUNCTION DibSaveImage (BYVAL strFileName AS STRING, BYVAL pbmfh AS BITMAPFILEHEADER PTR) AS LONG
LOCAL bSuccess AS LONG
LOCAL dwBytesWritten AS DWORD
LOCAL hFile AS DWORD
IF pbmfh = %NULL THEN EXIT FUNCTION
hFile = CreateFile(BYCOPY strFileName, %GENERIC_WRITE, 0, BYVAL %NULL, _
%CREATE_ALWAYS, %FILE_ATTRIBUTE_NORMAL, %NULL)
IF hFile = %INVALID_HANDLE_VALUE THEN EXIT FUNCTION
bSuccess = WriteFile(hFile, BYVAL pbmfh, BYVAL @pbmfh.bfSize, dwBytesWritten, BYVAL %NULL)
CloseHandle hFile
IF ISFALSE bSuccess OR dwBytesWritten <> @pbmfh.bfSize THEN
DeleteFile BYCOPY strFileName
EXIT FUNCTION
END IF
FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL hAccel AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL szCaption AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "ShowDib2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Show DIB #2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
hAccel = LoadAccelerators(hInstance, szAppName)
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
IF ISFALSE TranslateAccelerator(hwnd, hAccel, uMsg) THEN
TranslateMessage uMsg
DispatchMessage uMsg
END IF
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Shows the DIB
' ========================================================================================
FUNCTION ShowDib (BYVAL hdc AS DWORD, BYVAL pbmi AS BITMAPINFO PTR, BYVAL pbits AS BYTE PTR, _
BYVAL cxDib AS LONG, BYVAL cyDib AS LONG, BYVAL cxClient AS LONG, BYVAL cyClient AS LONG, _
BYVAL wShow AS WORD) AS LONG
SELECT CASE wShow
CASE %IDM_SHOW_NORMAL
FUNCTION = SetDIBitsToDevice(hdc, 0, 0, cxDib, cyDib, 0, 0, _
0, cyDib, BYVAL pbits, BYVAL pbmi, %DIB_RGB_COLORS)
CASE %IDM_SHOW_CENTER
FUNCTION = SetDIBitsToDevice(hdc, (cxClient - cxDib) / 2, _
(cyClient - cyDib) / 2, cxDib, cyDib, 0, 0, _
0, cyDib, BYVAL pbits, BYVAL pbmi, %DIB_RGB_COLORS)
CASE %IDM_SHOW_STRETCH
SetStretchBltMode hdc, %COLORONCOLOR
FUNCTION = StretchDIBits(hdc, 0, 0, cxClient, cyClient, 0, 0, _
cxDib, cyDib, BYVAL pbits, BYVAL pbmi, %DIB_RGB_COLORS, %SRCCOPY)
CASE %IDM_SHOW_ISOSTRETCH
SetStretchBltMode hdc, %COLORONCOLOR
SetMapMode hdc, %MM_ISOTROPIC
SetWindowExtEx hdc, cxDib, cyDib, BYVAL %NULL
SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
SetWindowOrgEx hdc, cxDib / 2, cyDib / 2, BYVAL %NULL
SetViewportOrgEx hdc, cxClient / 2, cyClient / 2, BYVAL %NULL
FUNCTION = StretchDIBits(hdc, 0, 0, cxDib, cyDib, 0, 0, _
cxDib, cyDib, BYVAL pbits, BYVAL pbmi, %DIB_RGB_COLORS, %SRCCOPY)
END SELECT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC pbmfh AS BITMAPFILEHEADER PTR
STATIC pbmi AS BITMAPINFO PTR
STATIC pbits AS BYTE PTR
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC cxDib AS LONG
STATIC cyDib AS LONG
STATIC szFileName AS ASCIIZ * %MAX_PATH
STATIC szTitleName AS ASCIIZ * %MAX_PATH
STATIC wShow AS WORD
LOCAL bSuccess AS LONG
LOCAL hdc AS DWORD
LOCAL hdcPrn AS DWORD
LOCAL hGlobal AS DWORD
LOCAL hMenu AS DWORD
LOCAL cxPage AS LONG
LOCAL cyPage AS LONG
LOCAL iEnable AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL pGlobal AS BYTE PTR
STATIC strPath AS STRING
STATIC fOptions AS STRING
STATIC dwStyle AS DWORD
STATIC strFileSpec AS STRING
STATIC dinfo AS DOCINFO
LOCAL szDocName AS ASCIIZ * 256
LOCAL Flags AS DWORD
LOCAL nCopies AS WORD
LOCAL nFromPage AS WORD
LOCAL nToPage AS WORD
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize variables to default values
wShow = %IDM_SHOW_NORMAL
strPath = CURDIR$
fOptions = "Bitmap Files (*.BMP)|*.bmp|"
fOptions = fOptions & "All Files (*.*)|*.*"
strFileSpec = "*.BMP"
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FILE_OPEN
' Call the OpenFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST
IF ISFALSE OpenFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "BMP", dwStyle) THEN EXIT FUNCTION
' If there is an existing DIB, free the memory
IF pbmfh THEN
CoTaskMemFree pbmfh
pbmfh = %NULL
END IF
' Load the entire DIB in memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
pbmfh = DibLoadImage(strFileSpec)
' Invalidate the client area for later update
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
InvalidateRect hwnd, BYVAL %NULL, %TRUE
IF pbmfh = %NULL THEN
MessageBox hwnd, "Cannot load DIB file", "ShowDib2", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
' Get pointers to the info structure & the bits
pbmi = pbmfh + SIZEOF(@pbmfh)
pbits = pbmfh + @pbmfh.bfOffBits
' Get the DIB width and height
cxDib = @pbmi.bmiHeader.biWidth
cyDib = ABS(@pbmi.bmiHeader.biHeight)
CASE %IDM_FILE_SAVE
' Call the SaveFileDialog wrapper function (included in COMDLG32.INC)
dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT
IF ISFALSE(SaveFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "BMP", dwStyle)) THEN EXIT FUNCTION
' Save the DIB to memory
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
bSuccess = DibSaveImage(strFileSpec, pbmfh)
IF ISFALSE bSuccess THEN
MessageBox hwnd, "Cannot load DIB file", "ShowDib2", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
EXIT FUNCTION
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
CASE %IDM_FILE_PRINT
IF pbmfh = %NULL THEN EXIT FUNCTION
Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
nCopies = 1 : nFromPage = 1 : nToPage = 1
IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
IF hdcPrn = %NULL THEN
MessageBox hwnd, "Cannot obtain Printer DC", "ShowDib2", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Check whether the printer can print bitmaps
IF GetDeviceCaps(hDC, %RASTERCAPS) AND %RC_BITBLT <> %RC_BITBLT THEN
MessageBox hwnd, "Printer cannot print bitmaps", "ShowDib2", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
ELSE
' Get size of printable area of page
cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
bSuccess = %FALSE
' Send the DIB to the printer
SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
ShowCursor %TRUE
szDocName = "ShowDib2: Printing"
dinfo.cbSize = SIZEOF(DOCINFO)
dinfo.lpszDocName = VARPTR(szDocName)
IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
ShowDib hdcPrn, pbmi, pbits, cxDib, cyDib, cxPage, cyPage, wShow
IF EndPage(hdcPrn) > 0 THEN
bSuccess = %TRUE
EndDoc hdcPrn
END IF
END IF
ShowCursor %FALSE
SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
END IF
DeleteDC hdcPrn
IF bSuccess = %FALSE THEN
MessageBox hwnd, "Could not print bitmap", "ShowDib2", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
END IF
END IF
END IF
CASE %IDM_EDIT_COPY, %IDM_EDIT_CUT
IF pbmfh = %NULL THEN EXIT FUNCTION
' Make a copy of the packed DIB
hGlobal = GlobalAlloc(%GHND OR %GMEM_SHARE, @pbmfh.bfSize - SIZEOF(BITMAPFILEHEADER))
pGlobal = GlobalLock (hGlobal)
CopyMemory pGlobal, pbmfh + SIZEOF(BITMAPFILEHEADER), _
@pbmfh.bfSize - SIZEOF(BITMAPFILEHEADER)
GlobalUnlock hGlobal
' Transfer it to the clipboard
OpenClipboard hwnd
EmptyClipboard
SetClipboardData %CF_DIB, hGlobal
CloseClipboard
IF LO(WORD, wParam) = %IDM_EDIT_CUT THEN
CoTaskMemFree pbmfh
pbmfh = %NULL
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_EDIT_DELETE
IF pbmfh THEN
CoTaskMemFree pbmfh
pbmfh = %NULL
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
CASE %IDM_SHOW_NORMAL, %IDM_SHOW_CENTER, %IDM_SHOW_STRETCH, %IDM_SHOW_ISOSTRETCH
hMenu = GetMenu(hwnd)
CheckMenuItem hMenu, wShow, %MF_UNCHECKED
wShow = LO(WORD, wParam)
CheckMenuItem hMenu, wShow, %MF_CHECKED
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END SELECT
EXIT FUNCTION
CASE %WM_SIZE
' Store the width and height of the client area
cxClient = LOWRD (lParam)
cyClient = HIWRD (lParam)
EXIT FUNCTION
CASE %WM_INITMENUPOPUP
' Enable or disable menu options
hMenu = GetMenu(hwnd)
IF pbmfh <> %NULL THEN
iEnable = %MF_ENABLED
ELSE
iEnable = %MF_GRAYED
END IF
EnableMenuItem hMenu, %IDM_FILE_SAVE, iEnable
EnableMenuItem hMenu, %IDM_FILE_PRINT, iEnable
EnableMenuItem hMenu, %IDM_EDIT_CUT, iEnable
EnableMenuItem hMenu, %IDM_EDIT_COPY, iEnable
EnableMenuItem hMenu, %IDM_EDIT_DELETE, iEnable
EXIT FUNCTION
CASE %WM_PAINT
' Draw the bitmap
hdc = BeginPaint(hwnd, ps)
IF pbmfh THEN ShowDib hdc, pbmi, pbits, cxDib, cyDib, cxClient, cyClient, wShow
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
' Free the allocated memory and end the program
IF pbmfh THEN CoTaskMemFree pbmfh
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the SINEWAVE.C-Sine Wave Using Polyline Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Draws a sine wave using the Polyline function, which draws a series of line segments by connecting the points in the specified array.
' ========================================================================================
' SINEWAVE.BAS
' This program is a translation/adaptation of the SINEWAVE.C-Sine Wave Using Polyline
' Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Draws a sine wave using the Polyline function, which draws a series of line segments by
' connecting the points in the specified array.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SineWave"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Sine Wave Using Polyline"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL ps AS PAINTSTRUCT
DIM apt(999) AS POINT
SELECT CASE uMsg
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
MoveToEx hdc, 0, cyClient / 2, BYVAL %NULL
LineTo hdc, cxClient, cyClient / 2
FOR i = LBOUND(apt) TO UBOUND(apt)
apt(i).x = i * cxClient / UBOUND(apt)
apt(i).y = (cyClient / 2 * (1 - SIN((2 * 3.14159) * i / UBOUND(apt))))
NEXT
Polyline hdc, apt(0), UBOUND(apt)
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of SKETCH.C -- Shadow Bitmap Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.
The technique of drawing on a memory device context (and hence a bitmap) is the key to implementing a "shadow bitmap." This is a bitmap that contains everything displayed in the window's client area. %WM_PAINT message processing thus reduces to a simple BitBlt. Shadow bitmaps are most useful in paint programs. The SKETCH program is not exactly the most sophisticated paint program around, but it's a start.
' ========================================================================================
' SKETCH.BAS
' This program is a translation/adaptation of SKETCH.C -- Shadow Bitmap Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The technique of drawing on a memory device context (and hence a bitmap) is the key to
' implementing a "shadow bitmap." This is a bitmap that contains everything displayed in
' the window's client area. %WM_PAINT message processing thus reduces to a simple BitBlt.
' Shadow bitmaps are most useful in paint programs. The SKETCH program is not exactly the
' most sophisticated paint program around, but it's a start.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "Sketch"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Sketch"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
SUB GetLargestDisplayMode (BYREF pcxBitmap AS LONG, BYREF pcyBitmap AS LONG)
LOCAL dvmode AS DEVMODE
LOCAL iModeNum AS LONG
LOCAL hr AS LONG
pcxBitmap = 0
pcyBitmap = 0
dvmode.dmSize = SIZEOF(DEVMODE)
DO
hr = EnumDisplaySettings(BYVAL %NULL, iModeNum, dvMode)
IF hr = 0 THEN EXIT DO
pcxBitmap = MAX&(pcxBitmap, dvmode.dmPelsWidth)
pcyBitmap = MAX&(pcyBitmap, dvmode.dmPelsHeight)
iModeNum = iModeNum + 1
LOOP
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC fLeftButtonDown AS LONG
STATIC fRightButtonDown AS LONG
STATIC hBitmap AS DWORD
STATIC hdcMem AS DWORD
STATIC cxBitmap AS LONG
STATIC cyBitmap AS LONG
STATIC cxClient AS LONG
STATIC cyClient AS LONG
STATIC xMouse AS LONG
STATIC yMouse AS LONG
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
SELECT CASE uMsg
CASE %WM_CREATE
GetLargestDisplayMode cxBitmap, cyBitmap
hdc = GetDC(hwnd)
hBitmap = CreateCompatibleBitmap(hdc, cxBitmap, cyBitmap)
hdcMem = CreateCompatibleDC(hdc)
ReleaseDC hwnd, hdc
IF ISFALSE hBitmap THEN ' No memory for bitmap
DeleteDC hdcMem
FUNCTION = -1
EXIT FUNCTION
END IF
SelectObject hdcMem, hBitmap
PatBlt hdcMem, 0, 0, cxBitmap, cyBitmap, %WHITENESS
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_LBUTTONDOWN
IF ISFALSE fRightButtonDown THEN SetCapture hwnd
xMouse = LO(WORD, lParam)
yMouse = HI(WORD, lParam)
fLeftButtonDown = %TRUE
EXIT FUNCTION
CASE %WM_LBUTTONUP
IF fLeftButtonDown THEN SetCapture %NULL
fLeftButtonDown = %FALSE
EXIT FUNCTION
CASE %WM_RBUTTONDOWN
IF ISFALSE fLeftButtonDown THEN SetCapture hwnd
xMouse = LO(WORD, lParam)
yMouse = HI(WORD, lParam)
fRightButtonDown = %TRUE
EXIT FUNCTION
CASE %WM_RBUTTONUP
IF fRightButtonDown THEN SetCapture %NULL
fRightButtonDown = %FALSE
EXIT FUNCTION
CASE %WM_MOUSEMOVE
IF ISFALSE fLeftButtonDown AND ISFALSE fRightButtonDown THEN EXIT FUNCTION
hdc = GetDC(hwnd)
SelectObject (hdc, GetStockObject(IIF&(fLeftButtonDown = %TRUE, %BLACK_PEN, %WHITE_PEN)))
SelectObject (hdcMem, GetStockObject(IIF&(fLeftButtonDown = %TRUE, %BLACK_PEN, %WHITE_PEN)))
MoveToEx hdc, xMouse, yMouse, BYVAL %NULL
MoveToEx hdcMem, xMouse, yMouse, BYVAL %NULL
xMouse = LO(WORD, lParam)
yMouse = HI(WORD, lParam)
LineTo hdc, xMouse, yMouse
LineTo hdcMem, xMouse, yMouse
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
BitBlt hdc, 0, 0, cxClient, cyClient, hdcMem, 0, 0, %SRCCOPY
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
DeleteDC hdcMem
DeleteObject hBitmap
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the STOKFONT.C-Stock Font Objects program © Charles Petzold, 1998, described and analysed in Chapter 6 of the book Programming Windows, 5th Edition.
Displays Windows stock fonts.
' ========================================================================================
' STOCKFONT.BAS
' This program is a translation/adaptation of the STOKFONT.C-Stock Font Objects program
' © Charles Petzold, 1998, described and analysed in Chapter 6 of the book Programming
' Windows, 5th Edition.
' Displays Windows stock fonts.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
TYPE STOCKFONT_STRUCT
idStockFont AS LONG
szStockFont AS ASCIIZ * 256
END TYPE
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "StokFont"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Stock Fonts"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC iFont AS LONG
STATIC cFonts AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL cxGrid AS LONG
LOCAL cyGrid AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL szFaceName AS ASCIIZ * %LF_FACESIZE
LOCAL szBuffer AS ASCIIZ * %LF_FACESIZE + 64
LOCAL tm AS TEXTMETRIC
DIM stockFont(6) AS STATIC STOCKFONT_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
stockFont(0).idStockFont = %OEM_FIXED_FONT : stockFont(0).szStockFont = "OEM_FIXED_FONT"
stockFont(1).idStockFont = %ANSI_FIXED_FONT : stockFont(1).szStockFont = "ANSI_FIXED_FONT"
stockFont(2).idStockFont = %ANSI_VAR_FONT : stockFont(2).szStockFont = "ANSI_VAR_FONT"
stockFont(3).idStockFont = %SYSTEM_FONT : stockFont(3).szStockFont = "SYSTEM_FONT"
stockFont(4).idStockFont = %DEVICE_DEFAULT_FONT : stockFont(4).szStockFont = "DEVICE_DEFAULT_FONT"
stockFont(5).idStockFont = %SYSTEM_FIXED_FONT : stockFont(5).szStockFont = "SYSTEM_FIXED_FONT"
stockFont(6).idStockFont = %DEFAULT_GUI_FONT : stockFont(6).szStockFont = "DEFAULT_GUI_FONT"
cFonts = 7
SetScrollRange hwnd, %SB_VERT, 0, cFonts - 1, %TRUE
EXIT FUNCTION
CASE %WM_DISPLAYCHANGE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_VSCROLL
SELECT CASE LO(WORD, wParam)
CASE %SB_TOP
iFont = 0
CASE %SB_BOTTOM
iFont = cFonts - 1
CASE %SB_LINEUP, %SB_PAGEUP
iFont = iFont - 1
CASE %SB_LINEDOWN, %SB_PAGEDOWN
iFont = iFont + 1
CASE %SB_THUMBPOSITION
iFont = HI(WORD, wParam)
END SELECT
iFont = MAX&(0, MIN&(cFonts - 1, iFont))
SetScrollPos hwnd, %SB_VERT, iFont, %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE wParam
CASE %VK_HOME
SendMessage hwnd, %WM_VSCROLL, %SB_TOP, 0
CASE %VK_END
SendMessage hwnd, %WM_VSCROLL, %SB_BOTTOM, 0
CASE %VK_PRIOR, %VK_LEFT, %VK_UP
SendMessage hwnd, %WM_VSCROLL, %SB_LINEUP, 0
CASE %VK_NEXT, %VK_RIGHT, %VK_DOWN
SendMessage hwnd, %WM_VSCROLL, %SB_PAGEDOWN, 0
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(stockfont(iFont).idStockFont)
GetTextFace hdc, %LF_FACESIZE, szFaceName
GetTextMetrics hdc, tm
cxGrid = MAX&(3 * tm.tmAveCharWidth, 2 * tm.tmMaxCharWidth)
cyGrid = tm.tmHeight + 3
szBuffer = stockFont(iFont).szStockFont & ": Face Name = " & szFaceName & ", Charset = " & FORMAT$(tm.tmCharSet)
TextOut hdc, 0, 0, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_TOP OR %TA_CENTER
' vertical and horizontal lines
FOR i = 0 TO 16
MoveToEx hdc, (i + 2) * cxGrid, 2 * cyGrid, BYVAL %NULL
LineTo hdc, (i + 2) * cxGrid, 19 * cyGrid
MoveToEx hdc, cxGrid, (i + 3) * cyGrid, BYVAL %NULL
LineTo hdc, 18 * cxGrid, (i + 3) * cyGrid
NEXT
' vertical and horizontal headings
FOR i = 0 TO 15
szBuffer = HEX$(i) & "-"
TextOut hdc, (2 * i + 5) * cxGrid / 2, 2 *cyGrid + 2, szBuffer, LEN(szBuffer)
szBuffer = "-" & HEX$(i)
TextOut hdc, 3 * cxGrid / 2, (i + 3) * cyGrid + 2, szBuffer, LEN(szBuffer)
NEXT
' characters
FOR y = 0 TO 15
FOR x = 0 TO 15
szBuffer = CHR$(16 * x + y)
TextOut hdc, (2 * x + 5) * cxGrid / 2, (y + 3) * cyGrid + 2, szBuffer, LEN(szBuffer)
NEXT
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation/adaptation from C of SYSMETS.C -- Final System Metrics Display Program described and analysed in Chapter 7 of Charles Petzold's book, Programming Windows 98.
Adds mouse wheel logic to SYSMETS4.
' ========================================================================================
' SYSMETS.BAS
' This program is a translation/adaptation from C of SYSMETS.C -- Final System Metrics
' Display Program described and analysed in Chapter 7 of Charles Petzold's book,
' Programming Windows 98. Adds mouse wheel logic to SYSMETS4.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' SYSMETRICS_STRUCT
' ========================================================================================
TYPE SYSMETRICS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 21
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SysMets"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Get System Metrics"
hwnd = CreateWindowEx(0, szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
STATIC cyClient AS LONG
STATIC cxClient AS LONG
STATIC iMaxWidth AS LONG
STATIC iDeltaPerLine AS LONG ' for mouse wheel logic
STATIC iAccumDelta AS LONG ' for mouse wheel logic
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL iVertPos AS LONG
LOCAL iHorzPos AS LONG
LOCAL iPaintBeg AS LONG
LOCAL iPaintEnd AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL si AS SCROLLINFO
LOCAL szBuffer AS ASCIIZ * 10
LOCAL tm AS TEXTMETRIC
LOCAL ulScrollLines AS DWORD ' for mouse wheel logic
DIM sysmetrics(44) AS STATIC SYSMETRICS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
sysmetrics( 0).iIndex = %SM_CXSCREEN : sysmetrics( 0).szLabel = "SM_CXSCREEN" : sysmetrics( 0).szDesc = "Screen width in pixels"
sysmetrics( 1).iIndex = %SM_CYSCREEN : sysmetrics( 1).szLabel = "SM_CYSCREEN" : sysmetrics( 1).szDesc = "Screen height in pixels"
sysmetrics( 2).iIndex = %SM_CXVSCROLL : sysmetrics( 2).szLabel = "SM_CXVSCROLL" : sysmetrics( 2).szDesc = "Vertical scroll arrow width"
sysmetrics( 3).iIndex = %SM_CYHSCROLL : sysmetrics( 3).szLabel = "SM_CYHSCROLL" : sysmetrics( 3).szDesc = "Horizontal scroll arrow height"
sysmetrics( 4).iIndex = %SM_CYCAPTION : sysmetrics( 4).szLabel = "SM_CYCAPTION" : sysmetrics( 4).szDesc = "Caption bar height"
sysmetrics( 5).iIndex = %SM_CXBORDER : sysmetrics( 5).szLabel = "SM_CXBORDER" : sysmetrics( 5).szDesc = "Window border width"
sysmetrics( 6).iIndex = %SM_CYBORDER : sysmetrics( 6).szLabel = "SM_CYBORDER" : sysmetrics( 6).szDesc = "Window border height"
sysmetrics( 7).iIndex = %SM_CXDLGFRAME : sysmetrics( 7).szLabel = "SM_CXDLGFRAME" : sysmetrics( 7).szDesc = "Dialog window frame width"
sysmetrics( 8).iIndex = %SM_CYDLGFRAME : sysmetrics( 8).szLabel = "SM_CYDLGFRAME" : sysmetrics( 8).szDesc = "Dialog window frame height"
sysmetrics( 9).iIndex = %SM_CYVTHUMB : sysmetrics( 9).szLabel = "SM_CYVTHUMB" : sysmetrics( 9).szDesc = "Vertical scroll thumb height"
sysmetrics(10).iIndex = %SM_CXHTHUMB : sysmetrics(10).szLabel = "SM_CXHTHUMB" : sysmetrics(10).szDesc = "Horizontal scroll thumb width"
sysmetrics(11).iIndex = %SM_CXICON : sysmetrics(11).szLabel = "SM_CXICON" : sysmetrics(11).szDesc = "Icon width"
sysmetrics(12).iIndex = %SM_CYICON : sysmetrics(12).szLabel = "SM_CYICON" : sysmetrics(12).szDesc = "Icon height"
sysmetrics(13).iIndex = %SM_CXCURSOR : sysmetrics(13).szLabel = "SM_CXCURSOR" : sysmetrics(13).szDesc = "Cursor width"
sysmetrics(14).iIndex = %SM_CYCURSOR : sysmetrics(14).szLabel = "SM_CYCURSOR" : sysmetrics(14).szDesc = "Cursor height"
sysmetrics(15).iIndex = %SM_CYMENU : sysmetrics(15).szLabel = "SM_CYMENU" : sysmetrics(15).szDesc = "Menu bar height"
sysmetrics(16).iIndex = %SM_CXFULLSCREEN : sysmetrics(16).szLabel = "SM_CXFULLSCREEN" : sysmetrics(16).szDesc = "Full screen client area width"
sysmetrics(17).iIndex = %SM_CYFULLSCREEN : sysmetrics(17).szLabel = "SM_CYFULLSCREEN" : sysmetrics(17).szDesc = "Full screen client area height"
sysmetrics(18).iIndex = %SM_CYKANJIWINDOW : sysmetrics(18).szLabel = "SM_CYKANJIWINDOW" : sysmetrics(18).szDesc = "Kanji window height"
sysmetrics(19).iIndex = %SM_MOUSEPRESENT : sysmetrics(19).szLabel = "SM_MOUSEPRESENT" : sysmetrics(19).szDesc = "Mouse present flag"
sysmetrics(20).iIndex = %SM_CYVSCROLL : sysmetrics(20).szLabel = "SM_CYVSCROLL" : sysmetrics(20).szDesc = "Vertical scroll arrow height"
sysmetrics(21).iIndex = %SM_CXHSCROLL : sysmetrics(21).szLabel = "SM_CXHSCROLL" : sysmetrics(21).szDesc = "Horizontal scroll arrow width"
sysmetrics(22).iIndex = %SM_DEBUG : sysmetrics(22).szLabel = "SM_DEBUG" : sysmetrics(22).szDesc = "Debug version flag"
sysmetrics(23).iIndex = %SM_SWAPBUTTON : sysmetrics(23).szLabel = "SM_SWAPBUTTON" : sysmetrics(23).szDesc = "Mouse buttons swapped flag"
sysmetrics(24).iIndex = %SM_RESERVED1 : sysmetrics(24).szLabel = "SM_RESERVED1" : sysmetrics(24).szDesc = "Reserved"
sysmetrics(25).iIndex = %SM_RESERVED2 : sysmetrics(25).szLabel = "SM_RESERVED2" : sysmetrics(25).szDesc = "Reserved"
sysmetrics(26).iIndex = %SM_RESERVED3 : sysmetrics(26).szLabel = "SM_RESERVED3" : sysmetrics(26).szDesc = "Reserved"
sysmetrics(27).iIndex = %SM_RESERVED4 : sysmetrics(27).szLabel = "SM_RESERVED4" : sysmetrics(27).szDesc = "Reserved"
sysmetrics(28).iIndex = %SM_CXMIN : sysmetrics(28).szLabel = "SM_CXMIN" : sysmetrics(28).szDesc = "Minimum window width"
sysmetrics(29).iIndex = %SM_CYMIN : sysmetrics(29).szLabel = "SM_CYMIN" : sysmetrics(29).szDesc = "Minimum window height"
sysmetrics(30).iIndex = %SM_CXSIZE : sysmetrics(30).szLabel = "SM_CXSIZE" : sysmetrics(30).szDesc = "Minimize/Maximize icon width"
sysmetrics(31).iIndex = %SM_CYSIZE : sysmetrics(31).szLabel = "SM_CYSIZE" : sysmetrics(31).szDesc = "Minimize/Maximize icon height"
sysmetrics(32).iIndex = %SM_CXFRAME : sysmetrics(32).szLabel = "SM_CXFRAME" : sysmetrics(32).szDesc = "Window frame width"
sysmetrics(33).iIndex = %SM_CYFRAME : sysmetrics(33).szLabel = "SM_CYFRAME" : sysmetrics(33).szDesc = "Window frame height"
sysmetrics(34).iIndex = %SM_CXMINTRACK : sysmetrics(34).szLabel = "SM_CXMINTRACK" : sysmetrics(34).szDesc = "Minimum window tracking width"
sysmetrics(35).iIndex = %SM_CYMINTRACK : sysmetrics(35).szLabel = "SM_CYMINTRACK" : sysmetrics(35).szDesc = "Minimum window tracking height"
sysmetrics(36).iIndex = %SM_CXDOUBLECLK : sysmetrics(36).szLabel = "SM_CXDOUBLECLK" : sysmetrics(36).szDesc = "Double click x tolerance"
sysmetrics(37).iIndex = %SM_CYDOUBLECLK : sysmetrics(37).szLabel = "SM_CYDOUBLECLK" : sysmetrics(37).szDesc = "Double click y tolerance"
sysmetrics(38).iIndex = %SM_CXICONSPACING : sysmetrics(38).szLabel = "SM_CXICONSPACING" : sysmetrics(38).szDesc = "Horizontal icon spacing"
sysmetrics(39).iIndex = %SM_CYICONSPACING : sysmetrics(39).szLabel = "SM_CYICONSPACING" : sysmetrics(39).szDesc = "Vertical icon spacing"
sysmetrics(40).iIndex = %SM_MENUDROPALIGNMENT : sysmetrics(40).szLabel = "SM_MENUDROPALIGNMENT" : sysmetrics(40).szDesc = "Left or right menu drop"
sysmetrics(41).iIndex = %SM_PENWINDOWS : sysmetrics(41).szLabel = "SM_PENWINDOWS" : sysmetrics(41).szDesc = "Pen extensions installed"
sysmetrics(42).iIndex = %SM_DBCSENABLED : sysmetrics(42).szLabel = "SM_DBCSENABLED" : sysmetrics(42).szDesc = "Double-Byte Char Set enabled"
sysmetrics(43).iIndex = %SM_CMOUSEBUTTONS : sysmetrics(43).szLabel = "SM_CMOUSEBUTTONS" : sysmetrics(43).szDesc = "Number of mouse buttons"
sysmetrics(44).iIndex = %SM_SHOWSOUNDS : sysmetrics(44).szLabel = "SM_SHOWSOUNDS" : sysmetrics(44).szDesc = "Present sounds visually"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 \ 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
' Save the width of the three columns
iMaxWidth = 40 * cxChar + 22 * cxCaps
' For mouse wheel information
SendMessage hwnd, %WM_SETTINGCHANGE, 0, 0
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SETTINGCHANGE
SystemParametersInfo %SPI_GETWHEELSCROLLLINES, 0, ulScrollLines, 0
' ulScrollLines usually equals 3 or 0 (for no scrolling)
' WHEEL_DELTA equals 120, so iDeltaPerLine will be 40
IF ulScrollLines THEN
iDeltaPerLine = %WHEEL_DELTA \ ulScrollLines
ELSE
iDeltaPerLine = 0
END IF
EXIT FUNCTION
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
' Set vertical scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = UBOUND(sysmetrics)
si.nPage = cyClient \ cyChar
SetScrollInfo (hwnd, %SB_VERT, si, %TRUE)
' Set horizontal scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = 2 + iMaxWidth \ cxChar
si.nPage = cxClient \ cxChar
SetScrollInfo (hwnd, %SB_HORZ, si, %TRUE)
EXIT FUNCTION
CASE %WM_VSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
GetScrollInfo hwnd, %SB_VERT, si
' Save the position for comparison later on
iVertPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_TOP
si.nPos = si.nMin
CASE %SB_BOTTOM
si.nPos = si.nMax
CASE %SB_LINEUP
si.nPos = si.nPos - 1
CASE %SB_LINEDOWN
si.nPos = si.nPos + 1
CASE %SB_PAGEUP
si.nPos = si.nPos - si.nPage
CASE %SB_PAGEDOWN
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_VERT, si, %TRUE
GetScrollInfo hwnd, %SB_VERT, si
' If the position has changed, scroll the window and update it
IF si.nPos <> iVertPos THEN
ScrollWindow hwnd, 0, cyChar * (iVertPos - si.nPos), BYVAL %NULL, BYVAL %NULL
UpdateWindow hwnd
END IF
EXIT FUNCTION
CASE %WM_HSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
' Save the position for comparison later on
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_LINELEFT
si.nPos = si.nPos - 1
CASE %SB_LINERIGHT
si.nPos = si.nPos + 1
CASE %SB_PAGELEFT
si.nPos = si.nPos - si.nPage
CASE %SB_PAGERIGHT
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION:
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_HORZ, si, %TRUE
GetScrollInfo hwnd, %SB_HORZ, si
' If the position has changed, scroll the window
IF si.nPos <> iHorzPos THEN
ScrollWindow hwnd, cxChar * (iHorzPos - si.nPos), 0, BYVAL %NULL, BYVAL %NULL
END IF
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE wParam
CASE %VK_HOME
SendMessage hwnd, %WM_VSCROLL, %SB_TOP, 0
CASE %VK_END
SendMessage hwnd, %WM_VSCROLL, %SB_BOTTOM, 0
CASE %VK_PRIOR
SendMessage hwnd, %WM_VSCROLL, %SB_PAGEUP, 0
CASE %VK_NEXT
SendMessage hwnd, %WM_VSCROLL, %SB_PAGEDOWN, 0
CASE %VK_UP
SendMessage hwnd, %WM_VSCROLL, %SB_LINEUP, 0
CASE %VK_DOWN
SendMessage hwnd, %WM_VSCROLL, %SB_LINEDOWN, 0
CASE %VK_LEFT
SendMessage hwnd, %WM_HSCROLL, %SB_PAGEUP, 0
CASE %VK_RIGHT
SendMessage hwnd, %WM_HSCROLL, %SB_PAGEDOWN, 0
END SELECT
EXIT FUNCTION
CASE %WM_MOUSEWHEEL
IF iDeltaPerLine = 0 THEN EXIT FUNCTION
iAccumDelta = iAccumDelta + CINT(HI(WORD, wParam)) ' 120 or -120
WHILE iAccumDelta >= iDeltaPerLine
SendMessage hwnd, %WM_VSCROLL, %SB_LINEUP, 0
iAccumDelta = iAccumDelta - iDeltaPerLine
WEND
WHILE (iAccumDelta <= -iDeltaPerLine)
SendMessage hwnd, %WM_VSCROLL, %SB_LINEDOWN, 0
iAccumDelta = iAccumDelta + iDeltaPerLine
WEND
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Get vertical scroll bar position
si.cbSize = SIZEOF(si)
si.fMask = %SIF_POS
GetScrollInfo hwnd, %SB_VERT, si
iVertPos = si.nPos
' Get horizontal scroll bar position
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
' Find painting limits
iPaintBeg = MAX&(0, iVertPos + ps.rcPaint.nTop \ cyChar)
iPaintEnd = MIN&(UBOUND(sysmetrics), iVertPos + ps.rcPaint.nBottom \ cyChar)
FOR i = iPaintBeg TO iPaintEnd
x = cxChar * (1 - iHorzPos)
y = cyChar * (i - iVertPos)
TextOut hdc, x, y, sysmetrics(i).szLabel, LEN(sysmetrics(i).szLabel)
TextOut hdc, x + 22 * cxCaps, y, sysmetrics(i).szDesc, LEN(sysmetrics(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetSystemMetrics(sysmetrics(i).iIndex))
TextOut hdc, x + 22 * cxCaps + 40 * cxChar, y, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the SYSMETS1.C-System Metrics Display Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 4 of the book Programming Windows, 5th Edition.
Displays some of the information available from the GetSystemMetrics calls in a simple one-line-per-item format.
' ========================================================================================
' SYSMETS1.BAS
' This program is a translation/adaptation of the SYSMETS1.C-System Metrics Display
' Program No. 1 © Charles Petzold, 1998, described and analysed in Chapter 4 of the book
' Programming Windows, 5th Edition.
' Displays some of the information available from the GetSystemMetrics calls in a simple
' one-line-per-item format.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' SYSMETRICS_STRUCT
' ========================================================================================
TYPE SYSMETRICS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 21
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SysMets1"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Get System Metrics No. 1"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL szBuffer AS ASCIIZ * 10
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
DIM sysmetrics(44) AS STATIC SYSMETRICS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
sysmetrics( 0).iIndex = %SM_CXSCREEN : sysmetrics( 0).szLabel = "SM_CXSCREEN" : sysmetrics( 0).szDesc = "Screen width in pixels"
sysmetrics( 1).iIndex = %SM_CYSCREEN : sysmetrics( 1).szLabel = "SM_CYSCREEN" : sysmetrics( 1).szDesc = "Screen height in pixels"
sysmetrics( 2).iIndex = %SM_CXVSCROLL : sysmetrics( 2).szLabel = "SM_CXVSCROLL" : sysmetrics( 2).szDesc = "Vertical scroll arrow width"
sysmetrics( 3).iIndex = %SM_CYHSCROLL : sysmetrics( 3).szLabel = "SM_CYHSCROLL" : sysmetrics( 3).szDesc = "Horizontal scroll arrow height"
sysmetrics( 4).iIndex = %SM_CYCAPTION : sysmetrics( 4).szLabel = "SM_CYCAPTION" : sysmetrics( 4).szDesc = "Caption bar height"
sysmetrics( 5).iIndex = %SM_CXBORDER : sysmetrics( 5).szLabel = "SM_CXBORDER" : sysmetrics( 5).szDesc = "Window border width"
sysmetrics( 6).iIndex = %SM_CYBORDER : sysmetrics( 6).szLabel = "SM_CYBORDER" : sysmetrics( 6).szDesc = "Window border height"
sysmetrics( 7).iIndex = %SM_CXDLGFRAME : sysmetrics( 7).szLabel = "SM_CXDLGFRAME" : sysmetrics( 7).szDesc = "Dialog window frame width"
sysmetrics( 8).iIndex = %SM_CYDLGFRAME : sysmetrics( 8).szLabel = "SM_CYDLGFRAME" : sysmetrics( 8).szDesc = "Dialog window frame height"
sysmetrics( 9).iIndex = %SM_CYVTHUMB : sysmetrics( 9).szLabel = "SM_CYVTHUMB" : sysmetrics( 9).szDesc = "Vertical scroll thumb height"
sysmetrics(10).iIndex = %SM_CXHTHUMB : sysmetrics(10).szLabel = "SM_CXHTHUMB" : sysmetrics(10).szDesc = "Horizontal scroll thumb width"
sysmetrics(11).iIndex = %SM_CXICON : sysmetrics(11).szLabel = "SM_CXICON" : sysmetrics(11).szDesc = "Icon width"
sysmetrics(12).iIndex = %SM_CYICON : sysmetrics(12).szLabel = "SM_CYICON" : sysmetrics(12).szDesc = "Icon height"
sysmetrics(13).iIndex = %SM_CXCURSOR : sysmetrics(13).szLabel = "SM_CXCURSOR" : sysmetrics(13).szDesc = "Cursor width"
sysmetrics(14).iIndex = %SM_CYCURSOR : sysmetrics(14).szLabel = "SM_CYCURSOR" : sysmetrics(14).szDesc = "Cursor height"
sysmetrics(15).iIndex = %SM_CYMENU : sysmetrics(15).szLabel = "SM_CYMENU" : sysmetrics(15).szDesc = "Menu bar height"
sysmetrics(16).iIndex = %SM_CXFULLSCREEN : sysmetrics(16).szLabel = "SM_CXFULLSCREEN" : sysmetrics(16).szDesc = "Full screen client area width"
sysmetrics(17).iIndex = %SM_CYFULLSCREEN : sysmetrics(17).szLabel = "SM_CYFULLSCREEN" : sysmetrics(17).szDesc = "Full screen client area height"
sysmetrics(18).iIndex = %SM_CYKANJIWINDOW : sysmetrics(18).szLabel = "SM_CYKANJIWINDOW" : sysmetrics(18).szDesc = "Kanji window height"
sysmetrics(19).iIndex = %SM_MOUSEPRESENT : sysmetrics(19).szLabel = "SM_MOUSEPRESENT" : sysmetrics(19).szDesc = "Mouse present flag"
sysmetrics(20).iIndex = %SM_CYVSCROLL : sysmetrics(20).szLabel = "SM_CYVSCROLL" : sysmetrics(20).szDesc = "Vertical scroll arrow height"
sysmetrics(21).iIndex = %SM_CXHSCROLL : sysmetrics(21).szLabel = "SM_CXHSCROLL" : sysmetrics(21).szDesc = "Horizontal scroll arrow width"
sysmetrics(22).iIndex = %SM_DEBUG : sysmetrics(22).szLabel = "SM_DEBUG" : sysmetrics(22).szDesc = "Debug version flag"
sysmetrics(23).iIndex = %SM_SWAPBUTTON : sysmetrics(23).szLabel = "SM_SWAPBUTTON" : sysmetrics(23).szDesc = "Mouse buttons swapped flag"
sysmetrics(24).iIndex = %SM_RESERVED1 : sysmetrics(24).szLabel = "SM_RESERVED1" : sysmetrics(24).szDesc = "Reserved"
sysmetrics(25).iIndex = %SM_RESERVED2 : sysmetrics(25).szLabel = "SM_RESERVED2" : sysmetrics(25).szDesc = "Reserved"
sysmetrics(26).iIndex = %SM_RESERVED3 : sysmetrics(26).szLabel = "SM_RESERVED3" : sysmetrics(26).szDesc = "Reserved"
sysmetrics(27).iIndex = %SM_RESERVED4 : sysmetrics(27).szLabel = "SM_RESERVED4" : sysmetrics(27).szDesc = "Reserved"
sysmetrics(28).iIndex = %SM_CXMIN : sysmetrics(28).szLabel = "SM_CXMIN" : sysmetrics(28).szDesc = "Minimum window width"
sysmetrics(29).iIndex = %SM_CYMIN : sysmetrics(29).szLabel = "SM_CYMIN" : sysmetrics(29).szDesc = "Minimum window height"
sysmetrics(30).iIndex = %SM_CXSIZE : sysmetrics(30).szLabel = "SM_CXSIZE" : sysmetrics(30).szDesc = "Minimize/Maximize icon width"
sysmetrics(31).iIndex = %SM_CYSIZE : sysmetrics(31).szLabel = "SM_CYSIZE" : sysmetrics(31).szDesc = "Minimize/Maximize icon height"
sysmetrics(32).iIndex = %SM_CXFRAME : sysmetrics(32).szLabel = "SM_CXFRAME" : sysmetrics(32).szDesc = "Window frame width"
sysmetrics(33).iIndex = %SM_CYFRAME : sysmetrics(33).szLabel = "SM_CYFRAME" : sysmetrics(33).szDesc = "Window frame height"
sysmetrics(34).iIndex = %SM_CXMINTRACK : sysmetrics(34).szLabel = "SM_CXMINTRACK" : sysmetrics(34).szDesc = "Minimum window tracking width"
sysmetrics(35).iIndex = %SM_CYMINTRACK : sysmetrics(35).szLabel = "SM_CYMINTRACK" : sysmetrics(35).szDesc = "Minimum window tracking height"
sysmetrics(36).iIndex = %SM_CXDOUBLECLK : sysmetrics(36).szLabel = "SM_CXDOUBLECLK" : sysmetrics(36).szDesc = "Double click x tolerance"
sysmetrics(37).iIndex = %SM_CYDOUBLECLK : sysmetrics(37).szLabel = "SM_CYDOUBLECLK" : sysmetrics(37).szDesc = "Double click y tolerance"
sysmetrics(38).iIndex = %SM_CXICONSPACING : sysmetrics(38).szLabel = "SM_CXICONSPACING" : sysmetrics(38).szDesc = "Horizontal icon spacing"
sysmetrics(39).iIndex = %SM_CYICONSPACING : sysmetrics(39).szLabel = "SM_CYICONSPACING" : sysmetrics(39).szDesc = "Vertical icon spacing"
sysmetrics(40).iIndex = %SM_MENUDROPALIGNMENT : sysmetrics(40).szLabel = "SM_MENUDROPALIGNMENT" : sysmetrics(40).szDesc = "Left or right menu drop"
sysmetrics(41).iIndex = %SM_PENWINDOWS : sysmetrics(41).szLabel = "SM_PENWINDOWS" : sysmetrics(41).szDesc = "Pen extensions installed"
sysmetrics(42).iIndex = %SM_DBCSENABLED : sysmetrics(42).szLabel = "SM_DBCSENABLED" : sysmetrics(42).szDesc = "Double-Byte Char Set enabled"
sysmetrics(43).iIndex = %SM_CMOUSEBUTTONS : sysmetrics(43).szLabel = "SM_CMOUSEBUTTONS" : sysmetrics(43).szDesc = "Number of mouse buttons"
sysmetrics(44).iIndex = %SM_SHOWSOUNDS : sysmetrics(44).szLabel = "SM_SHOWSOUNDS" : sysmetrics(44).szDesc = "Present sounds visually"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 / 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR i = LBOUND(sysmetrics) TO UBOUND(sysmetrics)
TextOut hdc, 0, cyChar * i, sysmetrics(i).szLabel, LEN(sysmetrics(i).szLabel)
TextOut hdc, 22 * cxCaps, cyChar * i, sysmetrics(i).szDesc, LEN(sysmetrics(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetSystemMetrics(sysmetrics(i).iIndex))
TextOut hdc, 22 * cxCaps + 40 * cxChar, cyChar * i, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the SYSMETS2.C-System Metrics Display Program No. 2 © Charles Petzold, 1998, described and analysed in Chapter 4 of the book Programming Windows, 5th Edition.
Displays some of the information available from the GetSystemMetrics calls in a simple one-line-per-item format. Like SysMets1 but with vertical scrolling.
' ========================================================================================
' SYSMETS2.BAS
' This program is a translation/adaptation from C of the program SYSMETS2.C described and
' analysed in Chapter 4 of Charles Petzold's book, Programming Windows 98.
' Displays some of the information available from the GetSystemMetrics calls in a simple
' one-line-per-item format. Like SysMets1 but with vertical scrolling.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' SYSMETRICS_STRUCT
' ========================================================================================
TYPE SYSMETRICS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 21
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SysMets2"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Get System Metrics No. 2"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
STATIC cyClient AS LONG
STATIC iVScrollPos AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL y AS LONG
LOCAL szBuffer AS ASCIIZ * 10
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
DIM sysmetrics(44) AS STATIC SYSMETRICS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
sysmetrics( 0).iIndex = %SM_CXSCREEN : sysmetrics( 0).szLabel = "SM_CXSCREEN" : sysmetrics( 0).szDesc = "Screen width in pixels"
sysmetrics( 1).iIndex = %SM_CYSCREEN : sysmetrics( 1).szLabel = "SM_CYSCREEN" : sysmetrics( 1).szDesc = "Screen height in pixels"
sysmetrics( 2).iIndex = %SM_CXVSCROLL : sysmetrics( 2).szLabel = "SM_CXVSCROLL" : sysmetrics( 2).szDesc = "Vertical scroll arrow width"
sysmetrics( 3).iIndex = %SM_CYHSCROLL : sysmetrics( 3).szLabel = "SM_CYHSCROLL" : sysmetrics( 3).szDesc = "Horizontal scroll arrow height"
sysmetrics( 4).iIndex = %SM_CYCAPTION : sysmetrics( 4).szLabel = "SM_CYCAPTION" : sysmetrics( 4).szDesc = "Caption bar height"
sysmetrics( 5).iIndex = %SM_CXBORDER : sysmetrics( 5).szLabel = "SM_CXBORDER" : sysmetrics( 5).szDesc = "Window border width"
sysmetrics( 6).iIndex = %SM_CYBORDER : sysmetrics( 6).szLabel = "SM_CYBORDER" : sysmetrics( 6).szDesc = "Window border height"
sysmetrics( 7).iIndex = %SM_CXDLGFRAME : sysmetrics( 7).szLabel = "SM_CXDLGFRAME" : sysmetrics( 7).szDesc = "Dialog window frame width"
sysmetrics( 8).iIndex = %SM_CYDLGFRAME : sysmetrics( 8).szLabel = "SM_CYDLGFRAME" : sysmetrics( 8).szDesc = "Dialog window frame height"
sysmetrics( 9).iIndex = %SM_CYVTHUMB : sysmetrics( 9).szLabel = "SM_CYVTHUMB" : sysmetrics( 9).szDesc = "Vertical scroll thumb height"
sysmetrics(10).iIndex = %SM_CXHTHUMB : sysmetrics(10).szLabel = "SM_CXHTHUMB" : sysmetrics(10).szDesc = "Horizontal scroll thumb width"
sysmetrics(11).iIndex = %SM_CXICON : sysmetrics(11).szLabel = "SM_CXICON" : sysmetrics(11).szDesc = "Icon width"
sysmetrics(12).iIndex = %SM_CYICON : sysmetrics(12).szLabel = "SM_CYICON" : sysmetrics(12).szDesc = "Icon height"
sysmetrics(13).iIndex = %SM_CXCURSOR : sysmetrics(13).szLabel = "SM_CXCURSOR" : sysmetrics(13).szDesc = "Cursor width"
sysmetrics(14).iIndex = %SM_CYCURSOR : sysmetrics(14).szLabel = "SM_CYCURSOR" : sysmetrics(14).szDesc = "Cursor height"
sysmetrics(15).iIndex = %SM_CYMENU : sysmetrics(15).szLabel = "SM_CYMENU" : sysmetrics(15).szDesc = "Menu bar height"
sysmetrics(16).iIndex = %SM_CXFULLSCREEN : sysmetrics(16).szLabel = "SM_CXFULLSCREEN" : sysmetrics(16).szDesc = "Full screen client area width"
sysmetrics(17).iIndex = %SM_CYFULLSCREEN : sysmetrics(17).szLabel = "SM_CYFULLSCREEN" : sysmetrics(17).szDesc = "Full screen client area height"
sysmetrics(18).iIndex = %SM_CYKANJIWINDOW : sysmetrics(18).szLabel = "SM_CYKANJIWINDOW" : sysmetrics(18).szDesc = "Kanji window height"
sysmetrics(19).iIndex = %SM_MOUSEPRESENT : sysmetrics(19).szLabel = "SM_MOUSEPRESENT" : sysmetrics(19).szDesc = "Mouse present flag"
sysmetrics(20).iIndex = %SM_CYVSCROLL : sysmetrics(20).szLabel = "SM_CYVSCROLL" : sysmetrics(20).szDesc = "Vertical scroll arrow height"
sysmetrics(21).iIndex = %SM_CXHSCROLL : sysmetrics(21).szLabel = "SM_CXHSCROLL" : sysmetrics(21).szDesc = "Horizontal scroll arrow width"
sysmetrics(22).iIndex = %SM_DEBUG : sysmetrics(22).szLabel = "SM_DEBUG" : sysmetrics(22).szDesc = "Debug version flag"
sysmetrics(23).iIndex = %SM_SWAPBUTTON : sysmetrics(23).szLabel = "SM_SWAPBUTTON" : sysmetrics(23).szDesc = "Mouse buttons swapped flag"
sysmetrics(24).iIndex = %SM_RESERVED1 : sysmetrics(24).szLabel = "SM_RESERVED1" : sysmetrics(24).szDesc = "Reserved"
sysmetrics(25).iIndex = %SM_RESERVED2 : sysmetrics(25).szLabel = "SM_RESERVED2" : sysmetrics(25).szDesc = "Reserved"
sysmetrics(26).iIndex = %SM_RESERVED3 : sysmetrics(26).szLabel = "SM_RESERVED3" : sysmetrics(26).szDesc = "Reserved"
sysmetrics(27).iIndex = %SM_RESERVED4 : sysmetrics(27).szLabel = "SM_RESERVED4" : sysmetrics(27).szDesc = "Reserved"
sysmetrics(28).iIndex = %SM_CXMIN : sysmetrics(28).szLabel = "SM_CXMIN" : sysmetrics(28).szDesc = "Minimum window width"
sysmetrics(29).iIndex = %SM_CYMIN : sysmetrics(29).szLabel = "SM_CYMIN" : sysmetrics(29).szDesc = "Minimum window height"
sysmetrics(30).iIndex = %SM_CXSIZE : sysmetrics(30).szLabel = "SM_CXSIZE" : sysmetrics(30).szDesc = "Minimize/Maximize icon width"
sysmetrics(31).iIndex = %SM_CYSIZE : sysmetrics(31).szLabel = "SM_CYSIZE" : sysmetrics(31).szDesc = "Minimize/Maximize icon height"
sysmetrics(32).iIndex = %SM_CXFRAME : sysmetrics(32).szLabel = "SM_CXFRAME" : sysmetrics(32).szDesc = "Window frame width"
sysmetrics(33).iIndex = %SM_CYFRAME : sysmetrics(33).szLabel = "SM_CYFRAME" : sysmetrics(33).szDesc = "Window frame height"
sysmetrics(34).iIndex = %SM_CXMINTRACK : sysmetrics(34).szLabel = "SM_CXMINTRACK" : sysmetrics(34).szDesc = "Minimum window tracking width"
sysmetrics(35).iIndex = %SM_CYMINTRACK : sysmetrics(35).szLabel = "SM_CYMINTRACK" : sysmetrics(35).szDesc = "Minimum window tracking height"
sysmetrics(36).iIndex = %SM_CXDOUBLECLK : sysmetrics(36).szLabel = "SM_CXDOUBLECLK" : sysmetrics(36).szDesc = "Double click x tolerance"
sysmetrics(37).iIndex = %SM_CYDOUBLECLK : sysmetrics(37).szLabel = "SM_CYDOUBLECLK" : sysmetrics(37).szDesc = "Double click y tolerance"
sysmetrics(38).iIndex = %SM_CXICONSPACING : sysmetrics(38).szLabel = "SM_CXICONSPACING" : sysmetrics(38).szDesc = "Horizontal icon spacing"
sysmetrics(39).iIndex = %SM_CYICONSPACING : sysmetrics(39).szLabel = "SM_CYICONSPACING" : sysmetrics(39).szDesc = "Vertical icon spacing"
sysmetrics(40).iIndex = %SM_MENUDROPALIGNMENT : sysmetrics(40).szLabel = "SM_MENUDROPALIGNMENT" : sysmetrics(40).szDesc = "Left or right menu drop"
sysmetrics(41).iIndex = %SM_PENWINDOWS : sysmetrics(41).szLabel = "SM_PENWINDOWS" : sysmetrics(41).szDesc = "Pen extensions installed"
sysmetrics(42).iIndex = %SM_DBCSENABLED : sysmetrics(42).szLabel = "SM_DBCSENABLED" : sysmetrics(42).szDesc = "Double-Byte Char Set enabled"
sysmetrics(43).iIndex = %SM_CMOUSEBUTTONS : sysmetrics(43).szLabel = "SM_CMOUSEBUTTONS" : sysmetrics(43).szDesc = "Number of mouse buttons"
sysmetrics(44).iIndex = %SM_SHOWSOUNDS : sysmetrics(44).szLabel = "SM_SHOWSOUNDS" : sysmetrics(44).szDesc = "Present sounds visually"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 / 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
SetScrollRange hwnd, %SB_VERT, 0, UBOUND(sysmetrics), %FALSE
SetScrollPos hwnd, %SB_VERT, iVscrollPos, %TRUE
EXIT FUNCTION
CASE %WM_SIZE
cyClient = HI(WORD, lParam)
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_VSCROLL
SELECT CASE LO(WORD, wParam)
CASE %SB_LINEUP
iVscrollPos = iVscrollPos - 1
CASE %SB_LINEDOWN
iVscrollPos = iVscrollPos + 1
CASE %SB_PAGEUP
iVscrollPos = iVscrollPos - cyClient / cyChar
CASE %SB_PAGEDOWN
iVscrollPos = iVscrollPos + cyClient / cyChar
CASE %SB_THUMBPOSITION
iVscrollPos = HI(WORD, wParam)
END SELECT
iVscrollPos = MAX&(0, MIN&(iVscrollPos, UBOUND(sysmetrics)))
IF iVscrollPos <> GetScrollPos(hwnd, %SB_VERT) THEN
SetScrollPos hwnd, %SB_VERT, iVscrollPos, %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
FOR i = LBOUND(sysmetrics) TO UBOUND(sysmetrics)
y = cyChar * (i - iVScrollPos)
TextOut hdc, 0, y, sysmetrics(i).szLabel, LEN(sysmetrics(i).szLabel)
TextOut hdc, 22 * cxCaps, y, sysmetrics(i).szDesc, LEN(sysmetrics(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetSystemMetrics(sysmetrics(i).iIndex))
TextOut hdc, 22 * cxCaps + 40 * cxChar, y, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the SYSMETS3.C-System Metrics Display Program No. 3 © Charles Petzold, 1998, described and analysed in Chapter 4 of the book Programming Windows, 5th Edition.
Displays some of the information available from the GetSystemMetrics calls in a simple one-line-per-item format. This version uses the SetScrollInfo and GetScrollInfo functions, adds a horizontal scroll bar for left and right scrolling, and repaints the client area more efficiently.
' ========================================================================================
' SYSMETS3.BAS
' This program is a translation/adaptation from C of the program SYSMETS3.C described and
' analysed in Chapter 4 of Charles Petzold's book, Programming Windows 98.
' Displays some of the information available from the GetSystemMetrics calls in a simple
' one-line-per-item format. This version uses the SetScrollInfo and GetScrollInfo
' functions, adds a horizontal scroll bar for left and right scrolling, and repaints the
' client area more efficiently.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' SYSMETRICS_STRUCT
' ========================================================================================
TYPE SYSMETRICS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 21
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SysMets3"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Get System Metrics No. 3"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
STATIC cyClient AS LONG
STATIC cxClient AS LONG
STATIC iMaxWidth AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL iVertPos AS LONG
LOCAL iHorzPos AS LONG
LOCAL iPaintBeg AS LONG
LOCAL iPaintEnd AS LONG
LOCAL si AS SCROLLINFO
LOCAL szBuffer AS ASCIIZ * 10
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
DIM sysmetrics(44) AS STATIC SYSMETRICS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
sysmetrics( 0).iIndex = %SM_CXSCREEN : sysmetrics( 0).szLabel = "SM_CXSCREEN" : sysmetrics( 0).szDesc = "Screen width in pixels"
sysmetrics( 1).iIndex = %SM_CYSCREEN : sysmetrics( 1).szLabel = "SM_CYSCREEN" : sysmetrics( 1).szDesc = "Screen height in pixels"
sysmetrics( 2).iIndex = %SM_CXVSCROLL : sysmetrics( 2).szLabel = "SM_CXVSCROLL" : sysmetrics( 2).szDesc = "Vertical scroll arrow width"
sysmetrics( 3).iIndex = %SM_CYHSCROLL : sysmetrics( 3).szLabel = "SM_CYHSCROLL" : sysmetrics( 3).szDesc = "Horizontal scroll arrow height"
sysmetrics( 4).iIndex = %SM_CYCAPTION : sysmetrics( 4).szLabel = "SM_CYCAPTION" : sysmetrics( 4).szDesc = "Caption bar height"
sysmetrics( 5).iIndex = %SM_CXBORDER : sysmetrics( 5).szLabel = "SM_CXBORDER" : sysmetrics( 5).szDesc = "Window border width"
sysmetrics( 6).iIndex = %SM_CYBORDER : sysmetrics( 6).szLabel = "SM_CYBORDER" : sysmetrics( 6).szDesc = "Window border height"
sysmetrics( 7).iIndex = %SM_CXDLGFRAME : sysmetrics( 7).szLabel = "SM_CXDLGFRAME" : sysmetrics( 7).szDesc = "Dialog window frame width"
sysmetrics( 8).iIndex = %SM_CYDLGFRAME : sysmetrics( 8).szLabel = "SM_CYDLGFRAME" : sysmetrics( 8).szDesc = "Dialog window frame height"
sysmetrics( 9).iIndex = %SM_CYVTHUMB : sysmetrics( 9).szLabel = "SM_CYVTHUMB" : sysmetrics( 9).szDesc = "Vertical scroll thumb height"
sysmetrics(10).iIndex = %SM_CXHTHUMB : sysmetrics(10).szLabel = "SM_CXHTHUMB" : sysmetrics(10).szDesc = "Horizontal scroll thumb width"
sysmetrics(11).iIndex = %SM_CXICON : sysmetrics(11).szLabel = "SM_CXICON" : sysmetrics(11).szDesc = "Icon width"
sysmetrics(12).iIndex = %SM_CYICON : sysmetrics(12).szLabel = "SM_CYICON" : sysmetrics(12).szDesc = "Icon height"
sysmetrics(13).iIndex = %SM_CXCURSOR : sysmetrics(13).szLabel = "SM_CXCURSOR" : sysmetrics(13).szDesc = "Cursor width"
sysmetrics(14).iIndex = %SM_CYCURSOR : sysmetrics(14).szLabel = "SM_CYCURSOR" : sysmetrics(14).szDesc = "Cursor height"
sysmetrics(15).iIndex = %SM_CYMENU : sysmetrics(15).szLabel = "SM_CYMENU" : sysmetrics(15).szDesc = "Menu bar height"
sysmetrics(16).iIndex = %SM_CXFULLSCREEN : sysmetrics(16).szLabel = "SM_CXFULLSCREEN" : sysmetrics(16).szDesc = "Full screen client area width"
sysmetrics(17).iIndex = %SM_CYFULLSCREEN : sysmetrics(17).szLabel = "SM_CYFULLSCREEN" : sysmetrics(17).szDesc = "Full screen client area height"
sysmetrics(18).iIndex = %SM_CYKANJIWINDOW : sysmetrics(18).szLabel = "SM_CYKANJIWINDOW" : sysmetrics(18).szDesc = "Kanji window height"
sysmetrics(19).iIndex = %SM_MOUSEPRESENT : sysmetrics(19).szLabel = "SM_MOUSEPRESENT" : sysmetrics(19).szDesc = "Mouse present flag"
sysmetrics(20).iIndex = %SM_CYVSCROLL : sysmetrics(20).szLabel = "SM_CYVSCROLL" : sysmetrics(20).szDesc = "Vertical scroll arrow height"
sysmetrics(21).iIndex = %SM_CXHSCROLL : sysmetrics(21).szLabel = "SM_CXHSCROLL" : sysmetrics(21).szDesc = "Horizontal scroll arrow width"
sysmetrics(22).iIndex = %SM_DEBUG : sysmetrics(22).szLabel = "SM_DEBUG" : sysmetrics(22).szDesc = "Debug version flag"
sysmetrics(23).iIndex = %SM_SWAPBUTTON : sysmetrics(23).szLabel = "SM_SWAPBUTTON" : sysmetrics(23).szDesc = "Mouse buttons swapped flag"
sysmetrics(24).iIndex = %SM_RESERVED1 : sysmetrics(24).szLabel = "SM_RESERVED1" : sysmetrics(24).szDesc = "Reserved"
sysmetrics(25).iIndex = %SM_RESERVED2 : sysmetrics(25).szLabel = "SM_RESERVED2" : sysmetrics(25).szDesc = "Reserved"
sysmetrics(26).iIndex = %SM_RESERVED3 : sysmetrics(26).szLabel = "SM_RESERVED3" : sysmetrics(26).szDesc = "Reserved"
sysmetrics(27).iIndex = %SM_RESERVED4 : sysmetrics(27).szLabel = "SM_RESERVED4" : sysmetrics(27).szDesc = "Reserved"
sysmetrics(28).iIndex = %SM_CXMIN : sysmetrics(28).szLabel = "SM_CXMIN" : sysmetrics(28).szDesc = "Minimum window width"
sysmetrics(29).iIndex = %SM_CYMIN : sysmetrics(29).szLabel = "SM_CYMIN" : sysmetrics(29).szDesc = "Minimum window height"
sysmetrics(30).iIndex = %SM_CXSIZE : sysmetrics(30).szLabel = "SM_CXSIZE" : sysmetrics(30).szDesc = "Minimize/Maximize icon width"
sysmetrics(31).iIndex = %SM_CYSIZE : sysmetrics(31).szLabel = "SM_CYSIZE" : sysmetrics(31).szDesc = "Minimize/Maximize icon height"
sysmetrics(32).iIndex = %SM_CXFRAME : sysmetrics(32).szLabel = "SM_CXFRAME" : sysmetrics(32).szDesc = "Window frame width"
sysmetrics(33).iIndex = %SM_CYFRAME : sysmetrics(33).szLabel = "SM_CYFRAME" : sysmetrics(33).szDesc = "Window frame height"
sysmetrics(34).iIndex = %SM_CXMINTRACK : sysmetrics(34).szLabel = "SM_CXMINTRACK" : sysmetrics(34).szDesc = "Minimum window tracking width"
sysmetrics(35).iIndex = %SM_CYMINTRACK : sysmetrics(35).szLabel = "SM_CYMINTRACK" : sysmetrics(35).szDesc = "Minimum window tracking height"
sysmetrics(36).iIndex = %SM_CXDOUBLECLK : sysmetrics(36).szLabel = "SM_CXDOUBLECLK" : sysmetrics(36).szDesc = "Double click x tolerance"
sysmetrics(37).iIndex = %SM_CYDOUBLECLK : sysmetrics(37).szLabel = "SM_CYDOUBLECLK" : sysmetrics(37).szDesc = "Double click y tolerance"
sysmetrics(38).iIndex = %SM_CXICONSPACING : sysmetrics(38).szLabel = "SM_CXICONSPACING" : sysmetrics(38).szDesc = "Horizontal icon spacing"
sysmetrics(39).iIndex = %SM_CYICONSPACING : sysmetrics(39).szLabel = "SM_CYICONSPACING" : sysmetrics(39).szDesc = "Vertical icon spacing"
sysmetrics(40).iIndex = %SM_MENUDROPALIGNMENT : sysmetrics(40).szLabel = "SM_MENUDROPALIGNMENT" : sysmetrics(40).szDesc = "Left or right menu drop"
sysmetrics(41).iIndex = %SM_PENWINDOWS : sysmetrics(41).szLabel = "SM_PENWINDOWS" : sysmetrics(41).szDesc = "Pen extensions installed"
sysmetrics(42).iIndex = %SM_DBCSENABLED : sysmetrics(42).szLabel = "SM_DBCSENABLED" : sysmetrics(42).szDesc = "Double-Byte Char Set enabled"
sysmetrics(43).iIndex = %SM_CMOUSEBUTTONS : sysmetrics(43).szLabel = "SM_CMOUSEBUTTONS" : sysmetrics(43).szDesc = "Number of mouse buttons"
sysmetrics(44).iIndex = %SM_SHOWSOUNDS : sysmetrics(44).szLabel = "SM_SHOWSOUNDS" : sysmetrics(44).szDesc = "Present sounds visually"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 / 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
' Save the width of the three columns
iMaxWidth = 40 * cxChar + 22 * cxCaps
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
' Set vertical scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = UBOUND(sysmetrics)
si.nPage = cyClient / cyChar
SetScrollInfo (hwnd, %SB_VERT, si, %TRUE)
' Set horizontal scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = 2 + iMaxWidth / cxChar
si.nPage = cxClient / cxChar
SetScrollInfo (hwnd, %SB_HORZ, si, %TRUE)
EXIT FUNCTION
CASE %WM_VSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
GetScrollInfo hwnd, %SB_VERT, si
' Save the position for comparison later on
iVertPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_TOP
si.nPos = si.nMin
CASE %SB_BOTTOM
si.nPos = si.nMax
CASE %SB_LINEUP
si.nPos = si.nPos - 1
CASE %SB_LINEDOWN
si.nPos = si.nPos + 1
CASE %SB_PAGEUP
si.nPos = si.nPos - si.nPage
CASE %SB_PAGEDOWN
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_VERT, si, %TRUE
GetScrollInfo hwnd, %SB_VERT, si
' If the position has changed, scroll the window and update it
IF si.nPos <> iVertPos THEN
ScrollWindow hwnd, 0, cyChar * (iVertPos - si.nPos), BYVAL %NULL, BYVAL %NULL
UpdateWindow hwnd
END IF
EXIT FUNCTION
CASE %WM_HSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
' Save the position for comparison later on
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_LINELEFT
si.nPos = si.nPos - 1
CASE %SB_LINERIGHT
si.nPos = si.nPos + 1
CASE %SB_PAGELEFT
si.nPos = si.nPos - si.nPage
CASE %SB_PAGERIGHT
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION:
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_HORZ, si, %TRUE
GetScrollInfo hwnd, %SB_HORZ, si
' If the position has changed, scroll the window
IF si.nPos <> iHorzPos THEN
ScrollWindow hwnd, cxChar * (iHorzPos - si.nPos), 0, BYVAL %NULL, BYVAL %NULL
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Get vertical scroll bar position
si.cbSize = SIZEOF(si)
si.fMask = %SIF_POS
GetScrollInfo hwnd, %SB_VERT, si
iVertPos = si.nPos
' Get horizontal scroll bar position
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
' Find painting limits
iPaintBeg = MAX&(0, iVertPos + ps.rcPaint.nTop / cyChar)
iPaintEnd = MIN&(UBOUND(sysmetrics), iVertPos + ps.rcPaint.nBottom / cyChar)
FOR i = iPaintBeg TO iPaintEnd
x = cxChar * (1 - iHorzPos)
y = cyChar * (i - iVertPos)
TextOut hdc, x, y, sysmetrics(i).szLabel, LEN(sysmetrics(i).szLabel)
TextOut hdc, x + 22 * cxCaps, y, sysmetrics(i).szDesc, LEN(sysmetrics(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetSystemMetrics(sysmetrics(i).iIndex))
TextOut hdc, x + 22 * cxCaps + 40 * cxChar, y, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation from C of the program SYSMETS4.C described and analysed in Chapter 6 of Charles Petzold's book, Programming Windows 98.
Displays some of the information available from the GetSystemMetrics calls in a simple one-line-per-item format. This version adds a keyboard interface to the scrollbars.
' ========================================================================================
' SYSMETS4.BAS
' This program is a translation/adaptation from C of the program SYSMETS4.C described and
' analysed in Chapter 6 of Charles Petzold's book, Programming Windows 98.
' Displays some of the information available from the GetSystemMetrics calls in a simple
' one-line-per-item format. This version adds a keyboard interface to the scrollbars.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' SYSMETRICS_STRUCT
' ========================================================================================
TYPE SYSMETRICS_STRUCT
iIndex AS LONG
szLabel AS ASCIIZ * 21
szDesc AS ASCIIZ * 31
END TYPE
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "SysMets4"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Get System Metrics No. 4"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cxChar AS LONG
STATIC cxCaps AS LONG
STATIC cyChar AS LONG
STATIC cyClient AS LONG
STATIC cxClient AS LONG
STATIC iMaxWidth AS LONG
LOCAL hdc AS DWORD
LOCAL i AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL iVertPos AS LONG
LOCAL iHorzPos AS LONG
LOCAL iPaintBeg AS LONG
LOCAL iPaintEnd AS LONG
LOCAL si AS SCROLLINFO
LOCAL szBuffer AS ASCIIZ * 10
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
DIM sysmetrics(44) AS STATIC SYSMETRICS_STRUCT
SELECT CASE uMsg
CASE %WM_CREATE
' Initialize array
sysmetrics( 0).iIndex = %SM_CXSCREEN : sysmetrics( 0).szLabel = "SM_CXSCREEN" : sysmetrics( 0).szDesc = "Screen width in pixels"
sysmetrics( 1).iIndex = %SM_CYSCREEN : sysmetrics( 1).szLabel = "SM_CYSCREEN" : sysmetrics( 1).szDesc = "Screen height in pixels"
sysmetrics( 2).iIndex = %SM_CXVSCROLL : sysmetrics( 2).szLabel = "SM_CXVSCROLL" : sysmetrics( 2).szDesc = "Vertical scroll arrow width"
sysmetrics( 3).iIndex = %SM_CYHSCROLL : sysmetrics( 3).szLabel = "SM_CYHSCROLL" : sysmetrics( 3).szDesc = "Horizontal scroll arrow height"
sysmetrics( 4).iIndex = %SM_CYCAPTION : sysmetrics( 4).szLabel = "SM_CYCAPTION" : sysmetrics( 4).szDesc = "Caption bar height"
sysmetrics( 5).iIndex = %SM_CXBORDER : sysmetrics( 5).szLabel = "SM_CXBORDER" : sysmetrics( 5).szDesc = "Window border width"
sysmetrics( 6).iIndex = %SM_CYBORDER : sysmetrics( 6).szLabel = "SM_CYBORDER" : sysmetrics( 6).szDesc = "Window border height"
sysmetrics( 7).iIndex = %SM_CXDLGFRAME : sysmetrics( 7).szLabel = "SM_CXDLGFRAME" : sysmetrics( 7).szDesc = "Dialog window frame width"
sysmetrics( 8).iIndex = %SM_CYDLGFRAME : sysmetrics( 8).szLabel = "SM_CYDLGFRAME" : sysmetrics( 8).szDesc = "Dialog window frame height"
sysmetrics( 9).iIndex = %SM_CYVTHUMB : sysmetrics( 9).szLabel = "SM_CYVTHUMB" : sysmetrics( 9).szDesc = "Vertical scroll thumb height"
sysmetrics(10).iIndex = %SM_CXHTHUMB : sysmetrics(10).szLabel = "SM_CXHTHUMB" : sysmetrics(10).szDesc = "Horizontal scroll thumb width"
sysmetrics(11).iIndex = %SM_CXICON : sysmetrics(11).szLabel = "SM_CXICON" : sysmetrics(11).szDesc = "Icon width"
sysmetrics(12).iIndex = %SM_CYICON : sysmetrics(12).szLabel = "SM_CYICON" : sysmetrics(12).szDesc = "Icon height"
sysmetrics(13).iIndex = %SM_CXCURSOR : sysmetrics(13).szLabel = "SM_CXCURSOR" : sysmetrics(13).szDesc = "Cursor width"
sysmetrics(14).iIndex = %SM_CYCURSOR : sysmetrics(14).szLabel = "SM_CYCURSOR" : sysmetrics(14).szDesc = "Cursor height"
sysmetrics(15).iIndex = %SM_CYMENU : sysmetrics(15).szLabel = "SM_CYMENU" : sysmetrics(15).szDesc = "Menu bar height"
sysmetrics(16).iIndex = %SM_CXFULLSCREEN : sysmetrics(16).szLabel = "SM_CXFULLSCREEN" : sysmetrics(16).szDesc = "Full screen client area width"
sysmetrics(17).iIndex = %SM_CYFULLSCREEN : sysmetrics(17).szLabel = "SM_CYFULLSCREEN" : sysmetrics(17).szDesc = "Full screen client area height"
sysmetrics(18).iIndex = %SM_CYKANJIWINDOW : sysmetrics(18).szLabel = "SM_CYKANJIWINDOW" : sysmetrics(18).szDesc = "Kanji window height"
sysmetrics(19).iIndex = %SM_MOUSEPRESENT : sysmetrics(19).szLabel = "SM_MOUSEPRESENT" : sysmetrics(19).szDesc = "Mouse present flag"
sysmetrics(20).iIndex = %SM_CYVSCROLL : sysmetrics(20).szLabel = "SM_CYVSCROLL" : sysmetrics(20).szDesc = "Vertical scroll arrow height"
sysmetrics(21).iIndex = %SM_CXHSCROLL : sysmetrics(21).szLabel = "SM_CXHSCROLL" : sysmetrics(21).szDesc = "Horizontal scroll arrow width"
sysmetrics(22).iIndex = %SM_DEBUG : sysmetrics(22).szLabel = "SM_DEBUG" : sysmetrics(22).szDesc = "Debug version flag"
sysmetrics(23).iIndex = %SM_SWAPBUTTON : sysmetrics(23).szLabel = "SM_SWAPBUTTON" : sysmetrics(23).szDesc = "Mouse buttons swapped flag"
sysmetrics(24).iIndex = %SM_RESERVED1 : sysmetrics(24).szLabel = "SM_RESERVED1" : sysmetrics(24).szDesc = "Reserved"
sysmetrics(25).iIndex = %SM_RESERVED2 : sysmetrics(25).szLabel = "SM_RESERVED2" : sysmetrics(25).szDesc = "Reserved"
sysmetrics(26).iIndex = %SM_RESERVED3 : sysmetrics(26).szLabel = "SM_RESERVED3" : sysmetrics(26).szDesc = "Reserved"
sysmetrics(27).iIndex = %SM_RESERVED4 : sysmetrics(27).szLabel = "SM_RESERVED4" : sysmetrics(27).szDesc = "Reserved"
sysmetrics(28).iIndex = %SM_CXMIN : sysmetrics(28).szLabel = "SM_CXMIN" : sysmetrics(28).szDesc = "Minimum window width"
sysmetrics(29).iIndex = %SM_CYMIN : sysmetrics(29).szLabel = "SM_CYMIN" : sysmetrics(29).szDesc = "Minimum window height"
sysmetrics(30).iIndex = %SM_CXSIZE : sysmetrics(30).szLabel = "SM_CXSIZE" : sysmetrics(30).szDesc = "Minimize/Maximize icon width"
sysmetrics(31).iIndex = %SM_CYSIZE : sysmetrics(31).szLabel = "SM_CYSIZE" : sysmetrics(31).szDesc = "Minimize/Maximize icon height"
sysmetrics(32).iIndex = %SM_CXFRAME : sysmetrics(32).szLabel = "SM_CXFRAME" : sysmetrics(32).szDesc = "Window frame width"
sysmetrics(33).iIndex = %SM_CYFRAME : sysmetrics(33).szLabel = "SM_CYFRAME" : sysmetrics(33).szDesc = "Window frame height"
sysmetrics(34).iIndex = %SM_CXMINTRACK : sysmetrics(34).szLabel = "SM_CXMINTRACK" : sysmetrics(34).szDesc = "Minimum window tracking width"
sysmetrics(35).iIndex = %SM_CYMINTRACK : sysmetrics(35).szLabel = "SM_CYMINTRACK" : sysmetrics(35).szDesc = "Minimum window tracking height"
sysmetrics(36).iIndex = %SM_CXDOUBLECLK : sysmetrics(36).szLabel = "SM_CXDOUBLECLK" : sysmetrics(36).szDesc = "Double click x tolerance"
sysmetrics(37).iIndex = %SM_CYDOUBLECLK : sysmetrics(37).szLabel = "SM_CYDOUBLECLK" : sysmetrics(37).szDesc = "Double click y tolerance"
sysmetrics(38).iIndex = %SM_CXICONSPACING : sysmetrics(38).szLabel = "SM_CXICONSPACING" : sysmetrics(38).szDesc = "Horizontal icon spacing"
sysmetrics(39).iIndex = %SM_CYICONSPACING : sysmetrics(39).szLabel = "SM_CYICONSPACING" : sysmetrics(39).szDesc = "Vertical icon spacing"
sysmetrics(40).iIndex = %SM_MENUDROPALIGNMENT : sysmetrics(40).szLabel = "SM_MENUDROPALIGNMENT" : sysmetrics(40).szDesc = "Left or right menu drop"
sysmetrics(41).iIndex = %SM_PENWINDOWS : sysmetrics(41).szLabel = "SM_PENWINDOWS" : sysmetrics(41).szDesc = "Pen extensions installed"
sysmetrics(42).iIndex = %SM_DBCSENABLED : sysmetrics(42).szLabel = "SM_DBCSENABLED" : sysmetrics(42).szDesc = "Double-Byte Char Set enabled"
sysmetrics(43).iIndex = %SM_CMOUSEBUTTONS : sysmetrics(43).szLabel = "SM_CMOUSEBUTTONS" : sysmetrics(43).szDesc = "Number of mouse buttons"
sysmetrics(44).iIndex = %SM_SHOWSOUNDS : sysmetrics(44).szLabel = "SM_SHOWSOUNDS" : sysmetrics(44).szDesc = "Present sounds visually"
hdc = GetDC (hwnd)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cxCaps = IIF&((tm.tmPitchAndFamily AND 1), cxChar * 3 / 2, cxChar)
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
' Save the width of the three columns
iMaxWidth = 40 * cxChar + 22 * cxCaps
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_SIZE
cxClient = LO(WORD, lParam)
cyClient = HI(WORD, lParam)
' Set vertical scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = UBOUND(sysmetrics)
si.nPage = cyClient / cyChar
SetScrollInfo (hwnd, %SB_VERT, si, %TRUE)
' Set horizontal scroll bar range and page size
si.cbSize = SIZEOF(si)
si.fMask = %SIF_RANGE OR %SIF_PAGE
si.nMin = 0
si.nMax = 2 + iMaxWidth / cxChar
si.nPage = cxClient / cxChar
SetScrollInfo (hwnd, %SB_HORZ, si, %TRUE)
EXIT FUNCTION
CASE %WM_VSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
GetScrollInfo hwnd, %SB_VERT, si
' Save the position for comparison later on
iVertPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_TOP
si.nPos = si.nMin
CASE %SB_BOTTOM
si.nPos = si.nMax
CASE %SB_LINEUP
si.nPos = si.nPos - 1
CASE %SB_LINEDOWN
si.nPos = si.nPos + 1
CASE %SB_PAGEUP
si.nPos = si.nPos - si.nPage
CASE %SB_PAGEDOWN
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_VERT, si, %TRUE
GetScrollInfo hwnd, %SB_VERT, si
' If the position has changed, scroll the window and update it
IF si.nPos <> iVertPos THEN
ScrollWindow hwnd, 0, cyChar * (iVertPos - si.nPos), BYVAL %NULL, BYVAL %NULL
UpdateWindow hwnd
END IF
EXIT FUNCTION
CASE %WM_HSCROLL
' Get all the vertical scroll bar information
si.cbSize = SIZEOF(si)
si.fMask = %SIF_ALL
' Save the position for comparison later on
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
SELECT CASE LO(WORD, wParam)
CASE %SB_LINELEFT
si.nPos = si.nPos - 1
CASE %SB_LINERIGHT
si.nPos = si.nPos + 1
CASE %SB_PAGELEFT
si.nPos = si.nPos - si.nPage
CASE %SB_PAGERIGHT
si.nPos = si.nPos + si.nPage
CASE %SB_THUMBPOSITION:
si.nPos = si.nTrackPos
END SELECT
' Set the position and then retrieve it. Due to adjustments
' by Windows it may not be the same as the value set.
si.fMask = %SIF_POS
SetScrollInfo hwnd, %SB_HORZ, si, %TRUE
GetScrollInfo hwnd, %SB_HORZ, si
' If the position has changed, scroll the window
IF si.nPos <> iHorzPos THEN
ScrollWindow hwnd, cxChar * (iHorzPos - si.nPos), 0, BYVAL %NULL, BYVAL %NULL
END IF
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE wParam
CASE %VK_HOME
SendMessage hwnd, %WM_VSCROLL, %SB_TOP, 0
CASE %VK_END
SendMessage hwnd, %WM_VSCROLL, %SB_BOTTOM, 0
CASE %VK_PRIOR
SendMessage hwnd, %WM_VSCROLL, %SB_PAGEUP, 0
CASE %VK_NEXT
SendMessage hwnd, %WM_VSCROLL, %SB_PAGEDOWN, 0
CASE %VK_UP
SendMessage hwnd, %WM_VSCROLL, %SB_LINEUP, 0
CASE %VK_DOWN
SendMessage hwnd, %WM_VSCROLL, %SB_LINEDOWN, 0
CASE %VK_LEFT
SendMessage hwnd, %WM_HSCROLL, %SB_PAGEUP, 0
CASE %VK_RIGHT
SendMessage hwnd, %WM_HSCROLL, %SB_PAGEDOWN, 0
END SELECT
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
' Get vertical scroll bar position
si.cbSize = SIZEOF(si)
si.fMask = %SIF_POS
GetScrollInfo hwnd, %SB_VERT, si
iVertPos = si.nPos
' Get horizontal scroll bar position
GetScrollInfo hwnd, %SB_HORZ, si
iHorzPos = si.nPos
' Find painting limits
iPaintBeg = MAX&(0, iVertPos + ps.rcPaint.nTop / cyChar)
iPaintEnd = MIN&(UBOUND(sysmetrics), iVertPos + ps.rcPaint.nBottom / cyChar)
FOR i = iPaintBeg TO iPaintEnd
x = cxChar * (1 - iHorzPos)
y = cyChar * (i - iVertPos)
TextOut hdc, x, y, sysmetrics(i).szLabel, LEN(sysmetrics(i).szLabel)
TextOut hdc, x + 22 * cxCaps, y, sysmetrics(i).szDesc, LEN(sysmetrics(i).szDesc)
SetTextAlign hdc, %TA_RIGHT OR %TA_TOP
szBuffer = FORMAT$(GetSystemMetrics(sysmetrics(i).iIndex))
TextOut hdc, x + 22 * cxCaps + 40 * cxChar, y, szBuffer, LEN(szBuffer)
SetTextAlign hdc, %TA_LEFT OR %TA_TOP
NEXT
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of TESTMCI.C -- MCI Command String Tester © Charles Petzold, 1998, described and analysed in Chapter 22 of the book Programming Windows, 5th Edition.
Back in the early days of Windows multimedia, the software development kit included a C program called MCITEST that allowed programmers to interactively type in MCI commands and learn how they worked. This program, at least in its C version, has apparently disappeared. So, I've recreated it as the TESTMCI. The user interface is based on the old MCITEST program but not the actual code, although I can't believe it was much different. (Petzold).
' ========================================================================================
' TESTMCI.BAS
' This program is a translation/adaptation of TESTMCI.C -- MCI Command String Tester
' © Charles Petzold, 1998, described and analysed in Chapter 22 of the book Programming
' Windows, 5th Edition.
' Back in the early days of Windows multimedia, the software development kit included a C
' program called MCITEST that allowed programmers to interactively type in MCI commands
' and learn how they worked. This program, at least in its C version, has apparently
' disappeared. So, I've recreated it as the TESTMCI. The user interface is based on the
' old MCITEST program but not the actual code, although I can't believe it was much
' different. (Petzold).
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "testmci.res"
%ID_TIMER = 1
%IDC_MAIN_EDIT = 1000
%IDC_NOTIFY_MESSAGE = 1005
%IDC_NOTIFY_ID = 1006
%IDC_NOTIFY_SUCCESSFUL = 1007
%IDC_NOTIFY_SUPERSEDED = 1008
%IDC_NOTIFY_ABORTED = 1009
%IDC_NOTIFY_FAILURE = 1010
%IDC_SIGNAL_MESSAGE = 1011
%IDC_SIGNAL_ID = 1012
%IDC_SIGNAL_PARAM = 1013
%IDC_RETURN_STRING = 1014
%IDC_ERROR_STRING = 1015
%IDC_DEVICES = 1016
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL szAppName AS ASCIIZ * 256
szAppName = "TestMci"
IF DialogBox(hInstance, szAppName, %NULL, CODEPTR(DlgProc)) = -1 THEN
MessageBox %NULL, "DialogBox failed", szAppName, %MB_ICONERROR
END IF
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION DlgProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC hwndEdit AS DWORD
LOCAL iCharBeg AS LONG
LOCAL iCharEnd AS LONG
LOCAL iLineBeg AS LONG
LOCAL iLineEnd AS LONG
LOCAL iChar AS LONG
LOCAL iLine AS LONG
LOCAL iLength AS LONG
LOCAL mcierror AS LONG
LOCAL rc AS RECT
LOCAL szCommand AS ASCIIZ * 1024
LOCAL szReturn AS ASCIIZ * 1024
LOCAL szError AS ASCIIZ * 1024
LOCAL szBuffer AS ASCIIZ * 32
SELECT CASE uMsg
CASE %WM_INITDIALOG
' Center the window on screen
GetWindowRect hwnd, rc
SetWindowPos hwnd, %NULL, _
(GetSystemMetrics(%SM_CXSCREEN) - rc.nRight + rc.nLeft) / 2, _
(GetSystemMetrics(%SM_CYSCREEN) - rc.nBottom + rc.nTop) / 2, _
0, 0, %SWP_NOZORDER OR %SWP_NOSIZE
hwndEdit = GetDlgItem(hwnd, %IDC_MAIN_EDIT)
SetFocus hwndEdit
FUNCTION = %FALSE
EXIT FUNCTION
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDOK
' Find the line numbers corresponding to the selection
SendMessage hwndEdit, %EM_GETSEL, VARPTR(iCharBeg), VARPTR(iCharEnd)
iLineBeg = SendMessage(hwndEdit, %EM_LINEFROMCHAR, iCharBeg, 0)
iLineEnd = SendMessage(hwndEdit, %EM_LINEFROMCHAR, iCharEnd, 0)
' Loop through all the lines
FOR iLine = iLineBeg TO iLineEnd
' Get the line and terminate it; ignore if blank
szCommand = SPACE$(SIZEOF(szCommand))
iLength = SendMessage(hwndEdit, %EM_GETLINE, iLine, VARPTR(szCommand))
IF iLength = 0 THEN ITERATE FOR
szCommand = LEFT$(szCommand, iLength)
' Send the MCI command
mcierror = mciSendString (szCommand, szReturn, SIZEOF(szReturn), hwnd)
' Set the Return String field
SetDlgItemText hwnd, %IDC_RETURN_STRING, szReturn
' Set the Error String field (even if no error)
mciGetErrorString mcierror, szError, SIZEOF(szError)
SetDlgItemText hwnd, %IDC_ERROR_STRING, szError
NEXT
' Send the caret to the end of the last selected line
iChar = SendMessage(hwndEdit, %EM_LINEINDEX, iLineEnd, 0)
iChar = iChar + SendMessage(hwndEdit, %EM_LINELENGTH, iCharEnd, 0)
SendMessage hwndEdit, %EM_SETSEL, iChar, iChar
' Insert a carriage return/line feed combination
szBuffer = $CRLF
SendMessage hwndEdit, %EM_REPLACESEL, %FALSE, VARPTR(szBuffer)
SetFocus hwndEdit
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDCANCEL
EndDialog hwnd, 0
FUNCTION = %TRUE
EXIT FUNCTION
CASE %IDC_MAIN_EDIT
IF HI(WORD, wParam) = %EN_ERRSPACE THEN
MessageBox hwnd, "Error control out of space.", _
"TestMci", %MB_OK OR %MB_ICONINFORMATION
FUNCTION = %TRUE
EXIT FUNCTION
END IF
END SELECT
CASE %MM_MCINOTIFY
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_MESSAGE), %TRUE
wsprintf szBuffer, "Device ID = %i", BYVAL lParam
SetDlgItemText hwnd, %IDC_NOTIFY_ID, szBuffer
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_ID), %TRUE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_SUCCESSFUL), wParam AND %MCI_NOTIFY_SUCCESSFUL
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_SUPERSEDED), wParam AND %MCI_NOTIFY_SUPERSEDED
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_ABORTED), wParam AND %MCI_NOTIFY_ABORTED
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_FAILURE), wParam AND %MCI_NOTIFY_FAILURE
SetTimer hwnd, %ID_TIMER, 5000, %NULL
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_TIMER
KillTimer hwnd, %ID_TIMER
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_MESSAGE), %FALSE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_ID), %FALSE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_SUCCESSFUL), %FALSE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_SUPERSEDED), %FALSE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_ABORTED), %FALSE
EnableWindow GetDlgItem(hwnd, %IDC_NOTIFY_FAILURE), %FALSE
FUNCTION = %TRUE
EXIT FUNCTION
CASE %WM_SYSCOMMAND
SELECT CASE LO(WORD, wParam)
CASE %SC_CLOSE
EndDialog hWnd, 0
FUNCTION = %TRUE
EXIT FUNCTION
END SELECT
END SELECT
END FUNCTION
' ========================================================================================
TESTMCI.RC
#define WS_MINIMIZEBOX 0x00020000L
#define WS_VISIBLE 0x10000000L
#define WS_CAPTION 0x00C00000L /* WS_BORDER | WS_DLGFRAME */
#define WS_SYSMENU 0x00080000L
#define ES_MULTILINE 0x0004L
#define ES_AUTOHSCROLL 0x0080L
#define WS_VSCROLL 0x00200000L
#define ES_AUTOVSCROLL 0x0040L
#define ES_READONLY 0x0800L
#define WS_TABSTOP 0x00010000L
#define WS_GROUP 0x00020000L
#define WS_DISABLED 0x08000000L
#define IDOK 1
#define IDCANCEL 2
#define IDC_MAIN_EDIT 1000
#define IDC_NOTIFY_MESSAGE 1005
#define IDC_NOTIFY_ID 1006
#define IDC_NOTIFY_SUCCESSFUL 1007
#define IDC_NOTIFY_SUPERSEDED 1008
#define IDC_NOTIFY_ABORTED 1009
#define IDC_NOTIFY_FAILURE 1010
#define IDC_SIGNAL_MESSAGE 1011
#define IDC_SIGNAL_ID 1012
#define IDC_SIGNAL_PARAM 1013
#define IDC_RETURN_STRING 1014
#define IDC_ERROR_STRING 1015
#define IDC_DEVICES 1016
#define IDC_STATIC -1
/////////////////////////////////////////////////////////////////////////////
// Dialog
TESTMCI DIALOG DISCARDABLE 0, 0, 270, 276
STYLE WS_MINIMIZEBOX | WS_VISIBLE | WS_CAPTION | WS_SYSMENU
CAPTION "MCI Tester"
FONT 8, "MS Sans Serif"
BEGIN
EDITTEXT IDC_MAIN_EDIT,8,8,254,100,ES_MULTILINE | ES_AUTOHSCROLL |
WS_VSCROLL
LTEXT "Return String:",IDC_STATIC,8,114,60,8
EDITTEXT IDC_RETURN_STRING,8,126,120,50,ES_MULTILINE |
ES_AUTOVSCROLL | ES_READONLY | WS_GROUP | NOT WS_TABSTOP
LTEXT "Error String:",IDC_STATIC,142,114,60,8
EDITTEXT IDC_ERROR_STRING,142,126,120,50,ES_MULTILINE |
ES_AUTOVSCROLL | ES_READONLY | NOT WS_TABSTOP
GROUPBOX "MM_MCINOTIFY Message",IDC_STATIC,9,186,254,58
LTEXT "",IDC_NOTIFY_ID,26,198,100,8
LTEXT "MCI_NOTIFY_SUCCESSFUL",IDC_NOTIFY_SUCCESSFUL,26,212,100,
8,WS_DISABLED
LTEXT "MCI_NOTIFY_SUPERSEDED",IDC_NOTIFY_SUPERSEDED,26,226,100,
8,WS_DISABLED
LTEXT "MCI_NOTIFY_ABORTED",IDC_NOTIFY_ABORTED,144,212,100,8,
WS_DISABLED
LTEXT "MCI_NOTIFY_FAILURE",IDC_NOTIFY_FAILURE,144,226,100,8,
WS_DISABLED
DEFPUSHBUTTON "OK",IDOK,57,255,50,14
PUSHBUTTON "Close",IDCANCEL,162,255,50,14
END
This program is a translation of UNICHARS.C -- Displays 16-bit character codes © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.
This program lets you view all the characters of a font and is particularly useful for studying the Lucida Sans Unicode font, which it uses by default for display, or the Bitstream CyberBit font. UNICHARS always uses the TextOutW function for displaying the font characters, so you can run it under Windows NT or Windows 98.
' ========================================================================================
' UNICHARS.BAS
' This program is a translation/adaptation of UNICHARS.C -- Displays 16-bit character codes
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' This program lets you view all the characters of a font and is particularly useful for
' studying the Lucida Sans Unicode font, which it uses by default for display, or the
' Bitstream CyberBit font. UNICHARS always uses the TextOutW function for displaying the
' font characters, so you can run it under Windows NT or Windows 98.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "unichars.res"
%IDM_FONT = 40001
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "UniChars"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "Unicode Characters"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cf AS CHOOSEFONTAPI
STATIC iPage AS LONG
STATIC lf AS LOGFONT
LOCAL hdc AS DWORD
LOCAL cxChar AS LONG
LOCAL cyChar AS LONG
LOCAL x AS LONG
LOCAL y AS LONG
LOCAL i AS LONG
LOCAL cxLabels AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL tsize AS APISIZE
LOCAL szBuffer AS ASCIIZ * 8
LOCAL tm AS TEXTMETRIC
LOCAL dwch AS DWORD
SELECT CASE uMsg
CASE %WM_CREATE
hdc = GetDC(hwnd)
lf.lfHeight = - GetDeviceCaps(hdc, %LOGPIXELSY) \ 6 ' 12 points
lf.lfFaceName = "Lucida Sans Unicode"
ReleaseDC hwnd, hdc
cf.lStructSize = SIZEOF(CHOOSEFONTAPI)
cf.hwndOwner = hwnd
cf.lpLogFont = VARPTR(lf)
cf.Flags = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS
SetScrollRange hwnd, %SB_VERT, 0, 255, %FALSE
SetScrollPos hwnd, %SB_VERT, iPage, %TRUE
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDM_FONT
IF ChooseFont(cf) THEN
InvalidateRect hwnd, BYVAL %NULL, %TRUE
END IF
END SELECT
EXIT FUNCTION
CASE %WM_VSCROLL
SELECT CASE LO(WORD, wParam)
CASE %SB_LINEUP: iPage = iPage - 1
CASE %SB_LINEDOWN: iPage = iPage + 1
CASE %SB_PAGEUP: iPage = iPage - 16
CASE %SB_PAGEDOWN: iPage = iPage + 16
CASE %SB_THUMBPOSITION: iPage = HI(WORD, wParam)
CASE ELSE
EXIT FUNCTION
END SELECT
iPage = MAX&(0, MIN&(iPage, 255))
SetScrollPos hwnd, %SB_VERT, iPage, %TRUE
InvalidateRect hwnd, BYVAL %NULL, %TRUE
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, CreateFontIndirect(lf)
GetTextMetrics hdc, tm
cxChar = tm.tmMaxCharWidth
cyChar = tm.tmHeight + tm.tmExternalLeading
cxLabels = 0
FOR i = 0 TO 15
wsprintf szBuffer, " 000%1X: ", BYVAL i
GetTextExtentPoint hdc, szBuffer, 7, tsize
cxLabels = MAX&(cxLabels, tsize.cx)
NEXT
FOR y = 0 TO 15
wsprintf szBuffer, " %03X_: ", BYVAL 16 * iPage + y
TextOut hdc, 0, y * cyChar, szBuffer, 7
FOR x = 0 TO 15
dwch = 256 * iPage + 16 * y + x
TextOutW hdc, x * cxChar + cxLabels, y * cyChar, BYVAL VARPTR(dwch), 1
NEXT
NEXT
DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of WHATCLR.C -- Displays Color Under Cursor © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming Windows, 5th Edition.
WHATCLR displays the RGB color of the pixel currently under the hot point of the mouse cursor.
' ========================================================================================
' WHATCLR.BAS
' This program is a translation/adaptation of WHATCLR.C -- Displays Color Under Cursor
' © Charles Petzold, 1998, described and analysed in Chapter 8 of the book Programming
' Windows, 5th Edition.
' WHATCLR displays the RGB color of the pixel currently under the hot point of the mouse
' cursor.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
%ID_TIMER = 1
' ========================================================================================
SUB FindWindowSize (BYREF pcxWindow AS LONG, BYREF pcyWindow AS LONG)
LOCAL hdcScreen AS DWORD
LOCAL tm AS TEXTMETRIC
hdcScreen = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
GetTextMetrics hdcScreen, tm
DeleteDC hdcScreen
pcxWindow = 2 * GetSystemMetrics (%SM_CXBORDER) + 12 * tm.tmAveCharWidth
pcyWindow = 2 * GetSystemMetrics(%SM_CYBORDER) + GetSystemMetrics(%SM_CYCAPTION) + 2 * tm.tmHeight
END SUB
' ========================================================================================
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL cxWindow AS LONG
LOCAL cyWindow AS LONG
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
szAppName = "WhatClr"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
FindWindowSize cxWindow, cyWindow
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
"What Color", _ ' window caption
%WS_OVERLAPPED OR _
%WS_CAPTION OR _
%WS_SYSMENU OR _
%WS_BORDER, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
cxWindow, _ ' initial x size
cyWindow, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC cr AS DWORD
STATIC crLast AS DWORD
STATIC hdcScreen AS DWORD
LOCAL hdc AS DWORD
LOCAL ps AS PAINTSTRUCT
LOCAL pt AS POINTAPI
LOCAL rc AS RECT
LOCAL szBuffer AS ASCIIZ * 14
SELECT CASE uMsg
CASE %WM_CREATE
hdcScreen = CreateDC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
SetTimer hwnd, %ID_TIMER, 100, %NULL
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_DISPLAYCHANGE
DeleteDC hdcScreen
hdcScreen = CreateDC ("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
EXIT FUNCTION
CASE %WM_TIMER
GetCursorPos pt
cr = GetPixel(hdcScreen, pt.x, pt.y)
IF cr <> crLast THEN
crLast = cr
InvalidateRect hwnd, BYVAL %NULL, %FALSE
END IF
EXIT FUNCTION
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
GetClientRect hwnd, rc
wsprintf szBuffer, " %02X %02X %02X ", _
BYVAL GetRValue(cr), BYVAL GetGValue (cr), BYVAL GetBValue (cr)
DrawText hdc, szBuffer, -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
EndPaint(hwnd, ps)
EXIT FUNCTION
CASE %WM_DESTROY
DeleteDC hdcScreen
KillTimer hwnd, %ID_TIMER
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
This program is a translation of the WHATSIZE.C-What Size is the Window? program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.
Shows the dimensions of the window's client area in terms of the five metric mapping modes.
' ========================================================================================
' WHATSIZE.BAS
' This program is a translation/adaptation of the WHATSIZE.C-What Size is the Window?
' program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Shows the dimensions of the window's client area in terms of the five metric mapping modes.
' ========================================================================================
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG
LOCAL hwnd AS DWORD
LOCAL szAppName AS ASCIIZ * 256
LOCAL wcex AS WNDCLASSEX
LOCAL szCaption AS ASCIIZ * 256
szAppName = "WhatSize"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hIcon = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
wcex.hCursor = LoadCursor(%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
wcex.lpszMenuName = VARPTR(szAppName)
wcex.lpszClassName = VARPTR(szAppName)
IF ISFALSE RegisterClassEx(wcex) THEN
FUNCTION = %TRUE
EXIT FUNCTION
END IF
szCaption = "What Size is the Window?"
hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szAppName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW, _ ' window style
%CW_USEDEFAULT, _ ' initial x position
%CW_USEDEFAULT, _ ' initial y position
%CW_USEDEFAULT, _ ' initial x size
%CW_USEDEFAULT, _ ' initial y size
%NULL, _ ' parent window handle
%NULL, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
ShowWindow hwnd, iCmdShow
UpdateWindow hwnd
LOCAL uMsg AS tagMsg
WHILE GetMessage(uMsg, %NULL, 0, 0)
TranslateMessage uMsg
DispatchMessage uMsg
WEND
FUNCTION = uMsg.wParam
END FUNCTION
' ========================================================================================
' ========================================================================================
' Shows the data
' ========================================================================================
SUB ShowData (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL xText AS LONG, _
BYVAL yText AS LONG, BYVAL iMapMode AS LONG, BYREF szMapMode AS ASCIIZ)
LOCAL rc AS RECT
LOCAL strMapping AS STRING * 21
LOCAL strLeft AS STRING * 7
LOCAL strRight AS STRING * 8
LOCAL strTop AS STRING * 8
LOCAL strBottom AS STRING * 8
LOCAL szBuffer AS ASCIIZ * 256
SaveDC hdc
SetMapMode hdc, iMapMode
GetClientRect hwnd, rc
DPToLP hdc, BYVAL VARPTR(rc), 2
RestoreDC (hdc, -1)
strMapping = szMapMode
RSET strLeft = FORMAT$(rc.nLeft)
RSET strRight = FORMAT$(rc.nRight)
RSET strTop = FORMAT$(rc.nTop)
RSET strBottom = FORMAT$(rc.nBottom)
szBuffer = strMapping & strLeft & strRight & strTop & strBottom
TextOut hdc, xText, yText, szBuffer, LEN(szBuffer)
END SUB
' ========================================================================================
' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
STATIC szHeading AS ASCIIZ * 256
STATIC szUndLine AS ASCIIZ * 256
STATIC cxChar AS LONG
STATIC cyChar AS LONG
LOCAL hdc AS LONG
LOCAL ps AS PAINTSTRUCT
LOCAL tm AS TEXTMETRIC
SELECT CASE uMsg
CASE %WM_CREATE
szHeading = "Mapping Mode Left Right Top Bottom"
szUndLine = "------------ ---- ----- --- ------"
hdc = GetDC(hwnd)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
GetTextMetrics hdc, tm
cxChar = tm.tmAveCharWidth
cyChar = tm.tmHeight + tm.tmExternalLeading
ReleaseDC hwnd, hdc
EXIT FUNCTION
CASE %WM_KEYDOWN
SELECT CASE LO(WORD, wParam)
CASE %VK_ESCAPE
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END SELECT
CASE %WM_PAINT
hdc = BeginPaint(hwnd, ps)
SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
SetMapMode hdc, %MM_ANISOTROPIC
SetWindowExtEx hdc, 1, 1, BYVAL %NULL
SetViewportExtEx hdc, cxChar, cyChar, BYVAL %NULL
TextOut hdc, 1, 1, szHeading, LEN(szHeading)
TextOut hdc, 1, 2, szUndLine, LEN(szUndLine)
ShowData hwnd, hdc, 1, 3, %MM_TEXT, "TEXT (pixels)"
ShowData hwnd, hdc, 1, 4, %MM_LOMETRIC, "LOMETRIC (.1 mm)"
ShowData hwnd, hdc, 1, 5, %MM_HIMETRIC, "HIMETRIC (.01 mm)"
ShowData hwnd, hdc, 1, 6, %MM_LOENGLISH, "LOENGLISH (.01 in)"
ShowData hwnd, hdc, 1, 7, %MM_HIENGLISH, "HIENGLISH (.001 in)"
ShowData hwnd, hdc, 1, 8, %MM_TWIPS, "TWIPS (1/1440 in)"
EndPaint hwnd, ps
EXIT FUNCTION
CASE %WM_DESTROY
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================