Charles Petzold's Examples

[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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

Code: [Select]

#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


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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

Code: [Select]

#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


[José Roca]

 
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 (\).

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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

Code: [Select]

#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


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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

Code: [Select]

#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


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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

Code: [Select]

/////////////////////////////////////////////////////////////////////////////
// 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"


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================


[José Roca]

 
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.

Code: [Select]

' ========================================================================================
' 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
' ========================================================================================