Charles Petzold's Examples

[José Roca]

 
This program is a translation of GRAYS2.C -- Gray Shades Using Palette Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.

Demonstrates the most important Palette Manager functions and messages with little extraneous code.

Code: [Select]

' ========================================================================================
' GRAYS2.BAS
' This program is a translation/adaptatiopn of GRAYS2.C -- Gray Shades Using Palette
' Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book
' Programming Windows, 5th Edition.
' Demonstrates the most important Palette Manager functions and messages with little
' extraneous code.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName        = "Grays2"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Shades of Gray #2"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hPalette AS DWORD
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  hBrush   AS DWORD
   LOCAL  hdc      AS DWORD
   LOCAL  i        AS LONG
   LOCAL  plp      AS LOGPALETTE PTR
   LOCAL  ps       AS PAINTSTRUCT
   LOCAL  rc       AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE
         ' Set up a LOGPALETTE structure and create a palette
         plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + 64 * SIZEOF(PALETTEENTRY))
         @plp.palVersion    = &H0300
         @plp.palNumEntries = 65
         FOR i = 0 TO 64
            @plp.palPalEntry(i).peRed   = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peGreen = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peBlue  = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peFlags = 0
         NEXT
         hPalette = CreatePalette(BYVAL plp)
         CoTaskMemFree plp
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         ' Select and realize the palette in the device context
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         ' Draw the fountain of grays
         FOR i = 0 TO 64
            rc.nLeft   = i * cxClient / 64
            rc.nTop    = 0
            rc.nRight  = (i + 1) * cxClient / 64
            rc.nBottom = cyClient
            hBrush = CreateSolidBrush(PALETTERGB (MIN&(255, 4 * i), _
                                                  MIN&(255, 4 * i), _
                                                  MIN&(255, 4 * i)))
            FillRect hdc, rc, hBrush
            DeleteObject hBrush
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_QUERYNEWPALETTE
         IF ISFALSE hPalette THEN EXIT FUNCTION
         hdc = GetDC(hwnd)
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         InvalidateRect hwnd, BYVAL %NULL, %TRUE
         ReleaseDC hwnd, hdc
         FUNCTION = %TRUE
         EXIT FUNCTION

      CASE %WM_PALETTECHANGED
         IF ISFALSE hPalette OR wParam = hwnd THEN EXIT FUNCTION
         hdc = GetDC(hwnd)
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         UpdateColors hdc
         ReleaseDC hwnd, hdc
         EXIT FUNCTION

     CASE %WM_DESTROY
         DeleteObject hPalette
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of GRAYS3.C -- Gray Shades Using Palette Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.

Same as GRAYS2 but using a macro called PALETTEINDEX instead of PALETTERGB during %WM_PAINT processing.

Code: [Select]

' ========================================================================================
' GRAYS3.BAS
' This program is a translation/adaptation of GRAYS3.C -- Gray Shades Using Palette
' Manager © Charles Petzold, 1998, described and analysed in Chapter 16 of the book
' Programming Windows, 5th Edition.
' Same as GRAYS2 but using a macro called PALETTEINDEX instead of PALETTERGB during
' %WM_PAINT processing.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "objbase.inc"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "Grays3"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Shades of Gray #3"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hPalette AS DWORD
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  hBrush   AS DWORD
   LOCAL  hdc      AS DWORD
   LOCAL  i        AS LONG
   LOCAL  plp      AS LOGPALETTE PTR
   LOCAL  ps       AS PAINTSTRUCT
   LOCAL  rc       AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE
         ' Set up a LOGPALETTE structure and create a palette
         plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + 64 * SIZEOF(PALETTEENTRY))
         @plp.palVersion    = &H0300
         @plp.palNumEntries = 65
         FOR i = 0 TO 64
            @plp.palPalEntry(i).peRed   = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peGreen = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peBlue  = MIN&(255, 4 * i)
            @plp.palPalEntry(i).peFlags = 0
         NEXT
         hPalette = CreatePalette(BYVAL plp)
         CoTaskMemFree plp
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         ' Select and realize the palette in the device context
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         ' Draw the fountain of grays
         FOR i = 0 TO 64
            rc.nLeft   = i * cxClient / 64
            rc.nTop    = 0
            rc.nRight  = (i + 1) * cxClient / 64
            rc.nBottom = cyClient
            hBrush = CreateSolidBrush(PALETTEINDEX(i))
            FillRect hdc, rc, hBrush
            DeleteObject hBrush
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_QUERYNEWPALETTE
         IF ISFALSE hPalette THEN EXIT FUNCTION
         hdc = GetDC(hwnd)
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         ReleaseDC hwnd, hdc
         FUNCTION = %TRUE
         EXIT FUNCTION

      CASE %WM_PALETTECHANGED
         IF ISFALSE hPalette OR wParam = hwnd THEN EXIT FUNCTION
         hdc = GetDC(hwnd)
         SelectPalette hdc, hPalette, %FALSE
         RealizePalette hdc
         UpdateColors hdc
         ReleaseDC hwnd, hdc
         EXIT FUNCTION

     CASE %WM_DESTROY
         DeleteObject hPalette
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of HEAD.C -- Displays beginning (head) of file © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.

A well-known UNIX utility named head displays the beginning lines of a file. Let's use a  list box to write a similar program for Windows. HEAD lists all files and child subdirectories in the list box. It allows you to choose a file to display by double-clicking on the filename with the mouse or by pressing the Enter key when the filename is selected. You can also change the subdirectory using either of these methods. The program displays up to 8 KB of the beginning of the file in the right side of the client area of HEAD's window.

Code: [Select]

' ========================================================================================
' HEAD.BAS
' This program is a translation/adaptation of HEAD.C -- Displays beginning (head) of file
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' A well-known UNIX utility named head displays the beginning lines of a file. Let's use a
' list box to write a similar program for Windows. HEAD lists all files and child
' subdirectories in the list box. It allows you to choose a file to display by
' double-clicking on the filename with the mouse or by pressing the Enter key when the
' filename is selected. You can also change the subdirectory using either of these
' methods. The program displays up to 8 KB of the beginning of the file in the right side
' of the client area of HEAD's window.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

%ID_LIST = 1
%ID_TEXT = 2

%MAXREAD = 8192
%DIRATTR = %DDL_READWRITE OR %DDL_READONLY OR %DDL_HIDDEN OR %DDL_SYSTEM OR _
           %DDL_DIRECTORY OR %DDL_ARCHIVE OR %DDL_DRIVES
%DTFLAGS = %DT_WORDBREAK OR %DT_EXPANDTABS OR %DT_NOCLIP OR %DT_NOPREFIX

GLOBAL OldList AS DWORD

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName        = "head"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "head"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC bValidFile AS LONG
   STATIC buffer     AS ASCIIZ * %MAXREAD
   STATIC hwndList   AS DWORD
   STATIC hwndText   AS DWORD
   STATIC rc         AS RECT
   STATIC szFile     AS ASCIIZ * %MAX_PATH + 1
   LOCAL  hFile      AS DWORD
   LOCAL  hdc        AS DWORD
   LOCAL  i          AS LONG
   LOCAL  cxChar     AS LONG
   LOCAL  cyChar     AS LONG
   LOCAL  ps         AS PAINTSTRUCT
   LOCAL  szBuffer   AS ASCIIZ * %MAX_PATH + 1
   LOCAL  szMask     AS ASCIIZ * 4

   SELECT CASE uMsg

      CASE %WM_CREATE
         cxChar = LO(WORD, GetDialogBaseUnits())
         cyChar = HI(WORD, GetDialogBaseUnits())
         rc.nLeft = 20 * cxChar
         rc.nTop  =  3 * cyChar
         hwndList = CreateWindowEx(0, "Listbox", BYVAL %NULL, _
                           %WS_CHILDWINDOW OR %WS_VISIBLE OR %LBS_STANDARD, _
                           cxChar, cyChar * 3, _
                           cxChar * 13 + GetSystemMetrics(%SM_CXVSCROLL), _
                           cyChar * 10, _
                           hwnd, %ID_LIST, _
                           GetWindowLong(hwnd, %GWL_HINSTANCE), _
                           BYVAL %NULL)
         GetCurrentDirectory %MAX_PATH + 1, szBuffer
         hwndText = CreateWindowEx(0, "Static", szBuffer, _
                           %WS_CHILDWINDOW OR %WS_VISIBLE OR %SS_LEFT, _
                           cxChar, cyChar, cxChar * %MAX_PATH, cyChar, _
                           hwnd, %ID_TEXT, _
                           GetWindowLong(hwnd, %GWL_HINSTANCE), _
                           BYVAL %NULL)
         OldList = SetWindowLong(hwndList, %GWL_WNDPROC, CODEPTR(ListProc))
         szMask = "*.*"
         SendMessage hwndList, %LB_DIR, %DIRATTR, VARPTR(szMask)
         EXIT FUNCTION

      CASE %WM_SIZE
         rc.nRight  = LO(WORD, lParam)
         rc.nBottom = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_SETFOCUS
         SetFocus hwndList
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND

         IF LO(WORD, wParam) = %ID_LIST AND HI(WORD, wParam) = %LBN_DBLCLK THEN
            i = SendMessage(hwndList, %LB_GETCURSEL, 0, 0)
            IF i = %LB_ERR THEN EXIT FUNCTION
            SendMessage hwndList, %LB_GETTEXT, i, VARPTR(szBuffer)
            hFile = CreateFile(szBuffer, %GENERIC_READ, %FILE_SHARE_READ, _
                    BYVAL %NULL, %OPEN_EXISTING, 0, %NULL)
            IF hFile <> %INVALID_HANDLE_VALUE THEN
               CloseHandle hFile
               bValidFile = %TRUE
               szFile = szBuffer
               GetCurrentDirectory %MAX_PATH + 1, szBuffer
               IF RIGHT$(szBuffer, 1) <> "\" THEN szBuffer = szBuffer + "\"
               SetWindowText hwndText, szBuffer & szFile
            ELSE
               bValidFile = %FALSE
               '  If setting the directory doesn't work, maybe it's
               ' a drive change, so try that.
               IF LEFT$(szBuffer, 2) ="[-" THEN szBuffer = MID$(szBuffer, 3)
               IF RIGHT$(szBuffer, 2) ="-]" THEN szBuffer = LEFT$(szBuffer, LEN(szBuffer) - 2)
               IF LEFT$(szBuffer, 1) ="[" THEN szBuffer = MID$(szBuffer, 2)
               IF RIGHT$(szBuffer, 1) ="]" THEN szBuffer = LEFT$(szBuffer, LEN(szBuffer) - 1)
               IF ISFALSE SetCurrentDirectory(szBuffer) THEN
                  szBuffer = szBuffer & ":\"
                  SetCurrentDirectory szBuffer
               END IF
               ' Get the new directory name and fill the list box.
               GetCurrentDirectory %MAX_PATH + 1, szBuffer
               SetWindowText hwndText, szBuffer
               SendMessage hwndList, %LB_RESETCONTENT, 0, 0
               szMask = "*.*"
               SendMessage hwndList, %LB_DIR, %DIRATTR, VARPTR(szMask)
            END IF
            InvalidateRect hwnd, BYVAL %NULL, %TRUE
         END IF
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
         SetTextColor hdc, GetSysColor(%COLOR_BTNTEXT)
         SetBkColor   hdc, GetSysColor(%COLOR_BTNFACE)
         IF bValidFile THEN
            hFile = CreateFile(szFile, %GENERIC_READ, %FILE_SHARE_READ, _
                    BYVAL %NULL, %OPEN_EXISTING, 0, %NULL)
            IF hFile = %INVALID_HANDLE_VALUE THEN
               bValidFile = %FALSE
               EXIT FUNCTION
            END IF
            ReadFile hFile, buffer, %MAXREAD, i, BYVAL %NULL
            CloseHandle hFile
            ' i now equals the number of bytes in buffer.
            ' Commence getting a device context for displaying text.
            ' Assume the file is ASCII
            DrawText hdc, buffer, i, rc, %DTFLAGS
         END IF
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         SetWindowLong hwndList, %GWL_WNDPROC, OldList
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
' ListgBox callback function
' ========================================================================================
FUNCTION ListProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   IF uMsg = %WM_KEYDOWN AND wParam = %VK_RETURN THEN
      SendMessage GetParent(hwnd), %WM_COMMAND, MAKLNG(1, %LBN_DBLCLK), hwnd
   END IF

   FUNCTION = CallWindowProc(OldList, hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of HELLOBIT.C -- Bitmap Demonstration © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming Windows, 5th Edition.

The program displays the text string "Hello, world!" on a small bitmap and then does a BitBlt or a StretchBlt (based on a menu selection) from the bitmap to the program's client area.

Code: [Select]

' ========================================================================================
' HELLOBIT.BAS
' This program is a translation/adaptation of HELLOBIT.C -- Bitmap Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' The program displays the text string "Hello, world!" on a small bitmap and then does a
' BitBlt or a StretchBlt (based on a menu selection) from the bitmap to the program's
' client area.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "hellobit.res"

%IDM_BIG   = 40001
%IDM_SMALL = 40002

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "HelloBit"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = VARPTR(szAppName)
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "HelloBit"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hBitmap  AS DWORD
   STATIC hdcMem   AS DWORD
   STATIC cxBitmap AS LONG
   STATIC cyBitmap AS LONG
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   STATIC iSize    AS LONG
   STATIC szText   AS ASCIIZ * 256
   LOCAL hdc       AS DWORD
   LOCAL hMenu     AS DWORD
   LOCAL x         AS LONG
   LOCAL y         AS LONG
   LOCAL ps        AS PAINTSTRUCT
   LOCAL tsize     AS SIZE

   SELECT CASE uMsg

     CASE %WM_CREATE
         szText = "Hello, world!"
         iSize = %IDM_BIG
         hdc = GetDC(hwnd)
         hdcMem = CreateCompatibleDC(hdc)
         GetTextExtentPoint32 hdc, szText, LEN(szText), tsize
         cxBitmap = tsize.cx
         cyBitmap = tsize.cy
         hBitmap = CreateCompatibleBitmap(hdc, cxBitmap, cyBitmap)
         ReleaseDC hwnd, hdc
         SelectObject hdcMem, hBitmap
         TextOut hdcMem, 0, 0, szText, LEN(szText)
         EXIT FUNCTION

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDM_BIG, %IDM_SMALL
               hMenu = GetMenu(hwnd)
               CheckMenuItem hMenu, iSize, %MF_UNCHECKED
               iSize = LOWRD(wParam)
               CheckMEnuItem hMenu, iSize, %MF_CHECKED
               InvalidateRect hwnd, BYVAL %NULL, %TRUE
         END SELECT
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         SELECT CASE iSize
            CASE %IDM_BIG
               StretchBlt hdc, 0, 0, cxClient, cyClient, _
                          hdcMem, 0, 0, cxBitmap, cyBitmap, %SRCCOPY
            CASE %IDM_SMALL
               FOR y = 0 TO cyClient - 1 STEP cyBitmap
                  FOR x = 0 TO cxClient - 1 STEP cxBitmap
                    BitBlt hdc, x, y, cxBitmap, cyBitmap, hdcMem, 0, 0, %SRCCOPY
                  NEXT
               NEXT
         END SELECT
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         DeleteDC hdcMem
         DeleteObject hBitmap
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of the HELLOWIN.C program © Charles Petzold, 1998, described and analysed in Chapter 3 of the book Programming Windows, 5th Edition.

Creating a window first requires registering a window class, and that requires a window procedure to process messages to the window. This involves a bit of overhead that appears in almost every Windows program. The HELLOWIN program is a simple program showing mostly that overhead.

Code: [Select]

' ========================================================================================
' HELLOWIN.BAS
' This program is a translation/adaptation of the HELLOWIN.C program © Charles Petzold, 1998,
' described and analysed in Chapter 3 of the book Programming Windows, 5th Edition.
' Creating a window first requires registering a window class, and that requires a window
' procedure to process messages to the window. This involves a bit of overhead that
' appears in almost every Windows program. The HELLOWIN program is a simple program
' showing mostly that overhead.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX

   szAppName          = "HelloWin"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         "The Hello Program", _    ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   LOCAL hdc AS DWORD
   LOCAL ps  AS PAINTSTRUCT
   LOCAL rc  AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE
         PlaySound "hellowin.wav", %NULL, %SND_FILENAME OR %SND_ASYNC
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
         END SELECT
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         GetClientRect hwnd, rc
         DrawText hdc, "Hello, Windows!", -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
         EndPaint(hwnd, ps)
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of HEXCALC.C -- Hexadecimal Calculator © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming Windows, 5th Edition.

Perhaps the epitome of lazy programming is the HEXCALC program. This program doesn't call CreateWindow at all, never processes WM_PAINT messages, never obtains a device context, and never processes mouse messages. Yet it manages to incorporate a 10-function hexadecimal calculator with a full keyboard and mouse interface in fewer than 150 lines of source code.

Code: [Select]

' ========================================================================================
' HEXCALC.BAS
' This program is a translation/adaptation of HEXCALC.C -- Hexadecimal Calculator
' © Charles Petzold, 1998, described and analysed in Chapter 11 of the book Programming
' Windows, 5th Edition.
' Perhaps the epitome of lazy programming is the HEXCALC program. This program doesn't
' call CreateWindow at all, never processes WM_PAINT messages, never obtains a device
' context, and never processes mouse messages. Yet it manages to incorporate a 10-function
' hexadecimal calculator with a full keyboard and mouse interface in fewer than 150 lines
' of source code.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "CRT.inc"
#RESOURCE RES, "hexcalc.res"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX

   szAppName          = "HexCalc"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = %DLGWINDOWEXTRA    ' // Note!
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = %COLOR_BTNFACE + 1
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   hwnd = CreateDialog(hInstance, szAppName, 0, %NULL)

   ShowWindow hwnd, iCmdShow

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
SUB ShowNumber (BYVAL hwnd AS DWORD, BYVAL iNumber AS DWORD)
'   LOCAL szBuffer AS ASCIIZ * 20
'   wsprintf szBuffer, "%X", BYVAL iNumber
'   SetDlgItemText hwnd, %VK_ESCAPE, szBuffer
   SetDlgItemText hwnd, %VK_ESCAPE, HEX$(iNumber)
END SUB
' ========================================================================================

' ========================================================================================
FUNCTION CalcIt (BYVAL iFirstNum AS DWORD, BYVAL iOperation AS LONG, BYVAL iNum AS DWORD) AS DWORD

   SELECT CASE CHR$(iOperation)
     CASE "=": FUNCTION = iNum
     CASE "+": FUNCTION = iFirstNum +  iNum
     CASE "-": FUNCTION = iFirstNum -  iNum
     CASE "*": FUNCTION = iFirstNum *  iNum
     CASE "&": FUNCTION = iFirstNum AND  iNum
     CASE "|": FUNCTION = iFirstNum OR  iNum
     CASE "^": FUNCTION = iFirstNum ^  iNum
     CASE "<": SHIFT LEFT iFirstNum, iNum : FUNCTION = iFirstNum
     CASE ">": SHIFT RIGHT iFirstNum, iNum : FUNCTION = iFirstNum
     CASE "/": FUNCTION = IIF&(iNum = 0, %MAXDWORD, iFirstNum \ iNum)
     CASE "%": FUNCTION = IIF&(iNum = 0, %MAXDWORD, iFirstNum MOD iNum)
     CASE ELSE : FUNCTION = 0
   END SELECT

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC bNewNumber AS LONG
   STATIC iOperation AS LONG
   STATIC iNumber    AS DWORD
   STATIC iFirstNum  AS DWORD
   LOCAL  hButton    AS DWORD
   LOCAL  dwTemp     AS DWORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         bNewNumber = %TRUE
         iOperation = ASC("=")
         EXIT FUNCTION

      CASE %WM_KEYDOWN                ' left arrow --> backspace
         IF wParam <> %VK_LEFT THEN EXIT FUNCTION
         SendMessage hwnd, %WM_CHAR, %VK_BACK, 0

      CASE %WM_CHAR
         wParam = ASC(UCASE$(CHR$(wParam)))
         IF wParam = %VK_RETURN THEN wParam = ASC("=")
         hButton = GetDlgItem(hwnd, wParam)
         IF hButton THEN
            SendMessage hButton, %BM_SETSTATE, 1, 0
            ApiSleep 100
            SendMessage hButton, %BM_SETSTATE, 0, 0
         ELSE
            MessageBeep 0
         END IF
         SendMessage hwnd, %WM_COMMAND, wParam, 0

      CASE %WM_COMMAND
         SetFocus hwnd
         IF LO(WORD, wParam) = %VK_BACK THEN          ' backspace
            iNumber = iNumber \ 16
            ShowNumber hwnd, iNumber
         ELSEIF LO(WORD, wParam) = %VK_ESCAPE THEN    ' escape
            iNumber = 0
            ShowNumber hwnd, iNumber
         ELSEIF isxdigit(LO(WORD, wParam)) THEN       ' hex digit
            IF bNewNumber THEN
               iFirstNum = iNumber
               iNumber = 0
            END IF
            bNewNumber = %FALSE
            dwTemp = %MAXDWORD
            SHIFT RIGHT dwTemp, 4
            IF iNumber <= dwTemp THEN
               iNumber = 16 * iNumber + wParam - IIF&(isdigit(wParam), ASC("0"), ASC("A") - 10)
               ShowNumber hwnd, iNumber
            ELSE
               MessageBeep 0
            END IF
         ELSE                                      ' operation
            IF ISFALSE bNewNumber THEN
               iNumber = CalcIt (iFirstNum, iOperation, iNumber)
               ShowNumber hwnd, iNumber
            END IF
            bNewNumber = %TRUE
            iOperation = LO(WORD, wParam)
         END IF

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


HEXCALC.RC

Code: [Select]

#define WS_OVERLAPPED       0x00000000L
#define WS_CAPTION          0x00C00000L     /* WS_BORDER | WS_DLGFRAME  */
#define WS_SYSMENU          0x00080000L
#define WS_MINIMIZEBOX      0x00020000L

/////////////////////////////////////////////////////////////////////////////
// Icon

HEXCALC                 ICON    DISCARDABLE     "HexCalc.ico"

/*---------------------------
   HEXCALC.DLG dialog script
  ---------------------------*/

HexCalc DIALOG -1, -1, 102, 122
STYLE WS_OVERLAPPED | WS_CAPTION | WS_SYSMENU | WS_MINIMIZEBOX
CLASS "HexCalc"
CAPTION "Hex Calculator"
{
     PUSHBUTTON "D",       68,  8,  24, 14, 14
     PUSHBUTTON "A",       65,  8,  40, 14, 14
     PUSHBUTTON "7",       55,  8,  56, 14, 14
     PUSHBUTTON "4",       52,  8,  72, 14, 14
     PUSHBUTTON "1",       49,  8,  88, 14, 14
     PUSHBUTTON "0",       48,  8, 104, 14, 14
     PUSHBUTTON "0",       27, 26,   4, 50, 14
     PUSHBUTTON "E",       69, 26,  24, 14, 14
     PUSHBUTTON "B",       66, 26,  40, 14, 14
     PUSHBUTTON "8",       56, 26,  56, 14, 14
     PUSHBUTTON "5",       53, 26,  72, 14, 14
     PUSHBUTTON "2",       50, 26,  88, 14, 14
     PUSHBUTTON "Back",     8, 26, 104, 32, 14
     PUSHBUTTON "C",       67, 44,  40, 14, 14
     PUSHBUTTON "F",       70, 44,  24, 14, 14
     PUSHBUTTON "9",       57, 44,  56, 14, 14
     PUSHBUTTON "6",       54, 44,  72, 14, 14
     PUSHBUTTON "3",       51, 44,  88, 14, 14
     PUSHBUTTON "+",       43, 62,  24, 14, 14
     PUSHBUTTON "-",       45, 62,  40, 14, 14
     PUSHBUTTON "*",       42, 62,  56, 14, 14
     PUSHBUTTON "/",       47, 62,  72, 14, 14
     PUSHBUTTON "%",       37, 62,  88, 14, 14
     PUSHBUTTON "Equals",  61, 62, 104, 32, 14
     PUSHBUTTON "&&",      38, 80,  24, 14, 14
     PUSHBUTTON "|",      124, 80,  40, 14, 14
     PUSHBUTTON "^",       94, 80,  56, 14, 14
     PUSHBUTTON "<",       60, 80,  72, 14, 14
     PUSHBUTTON ">",       62, 80,  88, 14, 14
}


[José Roca]

 
This program is a translation of ICONDEMO.C -- Icon Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.

Displays the icon in its client area, repeated horizontally and vertically.

Code: [Select]

' ========================================================================================
' ICONDEMO.BAS
' This program is a translation/adaptation of ICONDEMO.C -- Icon Demonstration Program
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' Displays the icon in its client area, repeated horizontally and vertically.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "icondemo.res"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "IconDemo"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Icon Demo"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hIcon     AS DWORD
   STATIC cxIcon    AS DWORD
   STATIC cyIcon    AS DWORD
   STATIC cxClient  AS LONG
   STATIC cyClient  AS LONG
   LOCAL  hdc       AS DWORD
   LOCAL  hInstance AS DWORD
   LOCAL  ps        AS PAINTSTRUCT
   LOCAL  x         AS LONG
   LOCAL  y         AS LONG
   LOCAL  lpc       AS CREATESTRUCT PTR

   SELECT CASE uMsg

      CASE %WM_CREATE
         lpc = lParam
         hInstance = @lpc.hInstance
         hIcon = LoadIcon (hInstance, "IDI_ICON")
         cxIcon = GetSystemMetrics(%SM_CXICON)
         cyIcon = GetSystemMetrics(%SM_CYICON)
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         FOR y = 0 TO cyClient - 1 STEP cyIcon
            FOR x = 0 TO cxClient - 1 STEP cxIcon
               DrawIcon hdc, x, y, hIcon
            NEXT
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of JUSTIFY1.C -- Justified Type Program #1 © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

Code: [Select]

' ========================================================================================
' JUSTIFY1.BAS
' This program is a translation/adaptation of JUSTIFY1.C -- Justified Type Program #1
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "justify1.res"

GLOBAL szAppName AS ASCIIZ * 256

%IDM_FILE_PRINT      = 40001
%IDM_FONT            = 40002
%IDM_ALIGN_LEFT      = 40003
%IDM_ALIGN_RIGHT     = 40004
%IDM_ALIGN_CENTER    = 40005
%IDM_ALIGN_JUSTIFIED = 40006

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "Justify1"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = VARPTR(szAppName)
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Justified Type #1"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, rc AS RECT)

   DIM iRuleSize(15) AS LONG
   ARRAY ASSIGN iRuleSize() = 360, 72, 144, 72, 216, 72, 144, 72, 288, 72, 144, 72, 216, 72, 144, 72

   LOCAL i AS LONG
   LOCAL j AS LONG
   LOCAL ptClient AS POINT

   SaveDC hdc

   ' Set Logical Twips mapping mode
   SetMapMode hdc, %MM_ANISOTROPIC
   SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
   SetViewportExtEx hdc, GetDeviceCaps(hdc, %LOGPIXELSX), _
                         GetDeviceCaps(hdc, %LOGPIXELSY), BYVAL %NULL

   ' Move the origin to a half inch from upper left
   SetWindowOrgEx hdc, -720, -720, BYVAL %NULL

   ' Find the right margin (quarter inch from right)
   ptClient.x = rc.nRight
   ptClient.y = rc.nBottom
   DPtoLP hdc, ptClient, 1
   ptClient.x = ptClient.x - 360

   ' Draw the rulers
   MoveToEx hdc, 0,          -360, BYVAL %NULL
   LineTo   hdc, ptClient.x, -360
   MoveToEx hdc, -360,          0, BYVAL %NULL
   LineTo   hdc, -360, ptClient.y

   FOR i = 0 TO ptClient.x STEP 1440 \ 16
      MoveToEx hdc, i, -360, BYVAL %NULL
      LineTo   hdc, i, -360 - iRuleSize (j MOD 16)
      INCR j
   NEXT

   j = 0

   FOR i = 0 TO ptClient.y STEP 1440 \ 16
      MoveToEx hdc, -360, i, BYVAL %NULL
      LineTo   hdc, -360 - iRuleSize (j MOD 16), i
      INCR j
   NEXT

   RestoreDC hdc, -1

END SUB
' ========================================================================================

' ========================================================================================
SUB Justify (BYVAL hdc AS DWORD, szText AS ASCIIZ, rc AS RECT, BYVAL iAlign AS LONG)

   LOCAL xStart      AS LONG
   LOCAL yStart      AS LONG
   LOCAL cSpaceChars AS LONG
   LOCAL pText       AS BYTE PTR
   LOCAL pBegin      AS BYTE PTR
   LOCAL pEnd        AS BYTE PTR
   LOCAL tsize       AS SIZE

   pText = VARPTR(szText)
   yStart = rc.nTop

   DO                                            ' for each text line

      cSpaceChars = 0                            ' initialize number of spaces in line
      WHILE @pText = 32                          ' skip over leading spaces
         INCR pText
      WEND
      pBegin = pText                             ' set pointer to char at beginning of

      DO                                         ' until the line is known
         pEnd = pText                            ' set pointer to char at end of line
         ' skip to next space
         WHILE @pText <> 0 AND @pText <> 32
            INCR pText
         WEND
         IF @pText = 0 THEN EXIT DO
         INCR pText
         ' after each space encountered, calculate extents
         INCR cSpaceChars
         GetTextExtentPoint32 hdc, BYVAL pBegin, pText - pBegin - 1, tsize
      LOOP WHILE tsize.cx < rc.nRight - rc.nLeft

      DECR cSpaceChars                           ' discount last space at end of line

      WHILE @pEnd - 1 = 32                       ' eliminate trailing spaces
         DECR pEnd
         DECR cSpaceChars
      WEND

      ' if end of text and no space characters, set pEnd to end
      IF @pText = 0 OR cSpaceChars <= 0 THEN pEnd = pText
      GetTextExtentPoint32 hdc, BYVAL pBegin, pEnd - pBegin, tsize

      SELECT CASE iAlign

         CASE %IDM_ALIGN_LEFT
            xStart = rc.nLeft

         CASE %IDM_ALIGN_RIGHT
            xStart = rc.nRight - tsize.cx

         CASE %IDM_ALIGN_CENTER
            xStart = (rc.nRight + rc.nLeft - tsize.cx) \ 2

         CASE %IDM_ALIGN_JUSTIFIED
            IF @pText <> 0  AND cSpaceChars > 0 THEN
               SetTextJustification hdc, rc.nRight - rc.nLeft - tsize.cx, cSpaceChars
               xStart = rc.nLeft
            END IF

      END SELECT

      ' display the text
      TextOut hdc, xStart, yStart, BYVAL pBegin, pEnd - pBegin

      ' prepare for next line
      IF @pText <> 0 THEN
         SetTextJustification hdc, 0, 0
         yStart = yStart + tsize.cy
         pText = pEnd
      END IF

   LOOP WHILE @pText <> 0 AND yStart < rc.nBottom - tsize.cy

END SUB
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC cf             AS CHOOSEFONTAPI
   STATIC dinfo          AS DOCINFO
   STATIC iAlign         AS LONG
   STATIC lf             AS LOGFONT
   STATIC pd             AS PRINTDLGAPI
   STATIC szText         AS ASCIIZ * 2048
   STATIC szDocName      AS ASCIIZ * 256
   LOCAL  fSuccess       AS LONG
   LOCAL  hdc            AS DWORD
   LOCAL  hdcPrn         AS DWORD
   LOCAL  hMenu          AS DWORD
   LOCAL  iSavePointSize AS LONG
   LOCAL  ps             AS PAINTSTRUCT
   LOCAL  rc             AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE

         szText = "You don't know about me, without you " & _
                  "have read a book by the name of " & $DQ & "The " & _
                  "Adventures of Tom Sawyer," & $DQ & " but that " & _
                  "ain't no matter. That book was made by " & _
                  "Mr. Mark Twain, and he told the truth, " & _
                  "mainly. There was things which he " & _
                  "stretched, but mainly he told the truth. " & _
                  "That is nothing. I never seen anybody " & _
                  "but lied, one time or another, without " & _
                  "it was Aunt Polly, or the widow, or " & _
                  "maybe Mary. Aunt Polly -- Tom's Aunt " & _
                  "Polly, she is -- and Mary, and the Widow " & _
                  "Douglas, is all told about in that book " & _
                  "-- which is mostly a true book; with " & _
                  "some stretchers, as I said before."

         iAlign = %IDM_ALIGN_LEFT
         szDocName = "Justify1: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dinfo.lpszDocName = VARPTR(szDocName)
         ' Initialize the CHOOSEFONT structure
         GetObject GetStockObject(%SYSTEM_FONT), SIZEOF(lf), lf
         cf.lStructSize    = SIZEOF(CHOOSEFONTAPI)
         cf.hwndOwner      = hwnd
         cf.hDC            = %NULL
         cf.lpLogFont      = VARPTR(lf)
         cf.iPointSize     = 0
         cf.Flags          = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS OR %CF_EFFECTS
         cf.rgbColors      = 0
         cf.lCustData      = 0
         cf.lpfnHook       = %NULL
         cf.lpTemplateName = %NULL
         cf.hInstance      = %NULL
         cf.lpszStyle      = %NULL
         cf.nFontType      = 0
         cf.nSizeMin       = 0
         cf.nSizeMax       = 0

         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND

         hMenu = GetMenu(hwnd)

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_PRINT

               ' Get printer DC
               pd.lStructSize = SIZEOF(PRINTDLGAPI)
               pd.hwndOwner   = hwnd
               pd.Flags       = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               IF ISFALSE PrintDlg(pd) THEN EXIT FUNCTION
               hdcPrn = pd.hDC
               IF hdcPrn = %NULL THEN
                  MessageBox hwnd, "Cannot obtain Printer DC", _
                             szAppName, %MB_ICONEXCLAMATION OR %MB_OK
                  EXIT FUNCTION
               END IF

               ' Set margins of 1 inch
               rc.nLeft   = GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
               rc.nTop    = GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
               rc.nRight  = GetDeviceCaps(hdcPrn, %PHYSICALWIDTH) - _
                            GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
               rc.nBottom = GetDeviceCaps(hdcPrn, %PHYSICALHEIGHT) - _
                            GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)

               ' Display text on printer
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               fSuccess = %FALSE
               IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                  ' Select font using adjusted lfHeight
                  iSavePointSize = lf.lfHeight
                  lf.lfHeight = -(GetDeviceCaps (hdcPrn, %LOGPIXELSY) * _
                                  cf.iPointSize) \ 720
                  SelectObject hdcPrn, CreateFontIndirect(lf)
                  lf.lfHeight = iSavePointSize
                  ' Set text color
                  SetTextColor hdcPrn, cf.rgbColors
                  ' Display text
                  Justify hdcPrn, szText, rc, iAlign
                  IF EndPage(hdcPrn) > 0 THEN
                     fSuccess = %TRUE
                     EndDoc hdcPrn
                  END IF
               END IF

               ShowCursor %FALSE
               SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
               DeleteDC hdcPrn

               IF ISFALSE fSuccess THEN
                  MessageBox hwnd, "Could not print text", _
                             szAppName, %MB_ICONEXCLAMATION OR %MB_OK
               END IF

            CASE %IDM_FONT
               IF ChooseFont(cf) THEN
                  InvalidateRect hwnd, BYVAL %NULL, %TRUE
               END IF

            CASE %IDM_ALIGN_LEFT, %IDM_ALIGN_RIGHT, %IDM_ALIGN_CENTER, %IDM_ALIGN_JUSTIFIED
               CheckMenuItem hMenu, iAlign, %MF_UNCHECKED
               iAlign = LO(WORD, wParam)
               CheckMenuItem hMenu, iAlign, %MF_CHECKED
               InvalidateRect hwnd, BYVAL %NULL, %TRUE

         END SELECT
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)

         GetClientRect hwnd, rc
         DrawRuler hdc, rc

         rc.nLeft  = rc.nLeft + GetDeviceCaps(hdc, %LOGPIXELSX) \ 2
         rc.nTop   = rc.nTop + GetDeviceCaps (hdc, %LOGPIXELSY) \ 2
         rc.nRight = rc.nRight - GetDeviceCaps(hdc, %LOGPIXELSX) \ 4

         SelectObject hdc, CreateFontIndirect(lf)
         SetTextColor hdc, cf.rgbColors

         Justify hdc, szText, rc, iAlign

         DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


JUSTIFY1.RC

Code: [Select]

#define IDM_FILE_PRINT                  40001
#define IDM_FONT                        40002
#define IDM_ALIGN_LEFT                  40003
#define IDM_ALIGN_RIGHT                 40004
#define IDM_ALIGN_CENTER                40005
#define IDM_ALIGN_JUSTIFIED             40006

/////////////////////////////////////////////////////////////////////////////
// Menu

JUSTIFY1 MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print",                      IDM_FILE_PRINT
    END
    POPUP "&Font"
    BEGIN
        MENUITEM "&Font...",                    IDM_FONT
    END
    POPUP "&Align"
    BEGIN
        MENUITEM "&Left",                       IDM_ALIGN_LEFT, CHECKED
        MENUITEM "&Right",                      IDM_ALIGN_RIGHT
        MENUITEM "&Centered",                   IDM_ALIGN_CENTER
        MENUITEM "&Justified",                  IDM_ALIGN_JUSTIFIED
    END
END


[José Roca]

 
This program is a translation of JUSTIFY2.C -- Justified Type Program #2 © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

The code in JUSTIFY2 is based on a program called TTJUST ("TrueType Justify") written by Microsoft's David Weise, which was in turn based on a version of the JUSTIFY1 program in an earlier edition of this book. To symbolize the increased complexity of this program, the Mark Twain excerpt has been replaced with the first paragraph from Herman Melville's Moby-Dick. JUSTIFY2 works with TrueType fonts only.

Code: [Select]

' ========================================================================================
' JUSTIFY2.BAS
' This program is a translation/adaptation of JUSTIFY2.C -- Justified Type Program #2
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The code in JUSTIFY2 is based on a program called TTJUST ("TrueType Justify") written by
' Microsoft's David Weise, which was in turn based on a version of the JUSTIFY1 program in
' an earlier edition of this book. To symbolize the increased complexity of this program,
' the Mark Twain excerpt has been replaced with the first paragraph from Herman Melville's
' Moby-Dick. JUSTIFY2 works with TrueType fonts only.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#INCLUDE ONCE "comdlg32.inc"
#RESOURCE RES, "justify2.res"

%OUTWIDTH = 6       ' Width of formatted output in inches
%LASTCHAR = 127     ' Last character code used in text

GLOBAL szAppName AS ASCIIZ * 256

%IDM_FILE_PRINT      = 40001
%IDM_FONT            = 40002
%IDM_ALIGN_LEFT      = 40003
%IDM_ALIGN_RIGHT     = 40004
%IDM_ALIGN_CENTER    = 40005
%IDM_ALIGN_JUSTIFIED = 40006

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "Justify2"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = VARPTR(szAppName)
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Justified Type #2"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, rc AS RECT)

   DIM iRuleSize(15) AS LONG
   ARRAY ASSIGN iRuleSize() = 360, 72, 144, 72, 216, 72, 144, 72, 288, 72, 144, 72, 216, 72, 144, 72

   LOCAL i AS LONG
   LOCAL j AS LONG
   LOCAL ptClient AS POINT

   SaveDC hdc

   ' Set Logical Twips mapping mode
   SetMapMode hdc, %MM_ANISOTROPIC
   SetWindowExtEx hdc, 1440, 1440, BYVAL %NULL
   SetViewportExtEx hdc, GetDeviceCaps(hdc, %LOGPIXELSX), _
                         GetDeviceCaps(hdc, %LOGPIXELSY), BYVAL %NULL

   ' Move the origin to a half inch from upper left
   SetWindowOrgEx hdc, -720, -720, BYVAL %NULL

   ' Find the right margin (quarter inch from right)
   ptClient.x = rc.nRight
   ptClient.y = rc.nBottom
   DPtoLP hdc, ptClient, 1
   ptClient.x = ptClient.x - 360

   ' Draw the rulers
   MoveToEx hdc, 0,          -360, BYVAL %NULL
   LineTo   hdc, %OUTWIDTH * 1440, -360
   MoveToEx hdc, -360,          0, BYVAL %NULL
   LineTo   hdc, -360, ptClient.y

   FOR i = 0 TO ptClient.x STEP 1440 \ 16
      IF i > %OUTWIDTH * 1440 THEN EXIT FOR
      MoveToEx hdc, i, -360, BYVAL %NULL
      LineTo   hdc, i, -360 - iRuleSize (j MOD 16)
      INCR j
   NEXT

   j = 0

   FOR i = 0 TO ptClient.y STEP 1440 \ 16
      MoveToEx hdc, -360, i, BYVAL %NULL
      LineTo   hdc, -360 - iRuleSize (j MOD 16), i
      INCR j
   NEXT

   RestoreDC hdc, -1

END SUB
' ========================================================================================

' ========================================================================================
' GetCharDesignWidths:  Gets character widths for font as large as the
'                       original design size
' ========================================================================================
FUNCTION GetCharDesignWidths (BYVAL hdc AS DWORD, BYVAL uFirst AS DWORD, BYVAL uLast AS DWORD, BYVAL piWidths AS LONG) AS DWORD

   LOCAL hFont       AS DWORD
   LOCAL hFontDesign AS DWORD
   LOCAL lf          AS LOGFONT
   LOCAL otm         AS OUTLINETEXTMETRIC

   hFont = GetCurrentObject(hdc, %OBJ_FONT)
   GetObject hFont, SIZEOF(LOGFONT), lf

   ' Get outline text metrics (we'll only be using a field that is
   '   independent of the DC the font is selected into)
   otm.otmSize = SIZEOF(OUTLINETEXTMETRIC)
   GetOutlineTextMetrics hdc, SIZEOF(OUTLINETEXTMETRIC), otm

   ' Create a new font based on the design size
   lf.lfHeight = - otm.otmEMSquare
   lf.lfWidth  = 0
   hFontDesign = CreateFontIndirect(lf)

   ' Select the font into the DC and get the character widths
   SaveDC hdc
   SetMapMode hdc, %MM_TEXT
   SelectObject hdc, hFontDesign

   GetCharWidth hdc, uFirst, uLast, BYVAL piWidths
   SelectObject hdc, hFont
   RestoreDC hdc, -1

   ' Clean up
   DeleteObject hFontDesign

   FUNCTION = otm.otmEMSquare

END FUNCTION
' ========================================================================================

' ========================================================================================
' GetScaledWidths:  Gets floating point character widths for selected
'                   font size
' ========================================================================================
SUB GetScaledWidths (BYVAL hdc AS DWORD, pdWidths() AS DOUBLE)

   LOCAL dScale AS DOUBLE
   LOCAL hFont AS DWORD
   DIM   aiDesignWidths(0 TO %LASTCHAR) AS LONG
   LOCAL i AS LONG
   LOCAL lf AS LOGFONT
   LOCAL uEMSquare AS DWORD

   ' Call function above
   uEMSquare = GetCharDesignWidths(hdc, 0, %LASTCHAR, VARPTR(aiDesignWidths(0)))

   ' Get LOGFONT for current font in device context
   hFont = GetCurrentObject(hdc, %OBJ_FONT)
   GetObject hFont, SIZEOF(LOGFONT), lf

   ' Scale the widths and store as floating point values
   dScale = -lf.lfHeight / uEMSquare

   FOR i = 0 TO %LASTCHAR
      pdWidths(i) = dScale * aiDesignWidths(i)
   NEXT

END SUB
' ========================================================================================

' ========================================================================================
' GetTextExtentFloat:  Calculates text width in floating point
' ========================================================================================
FUNCTION GetTextExtentFloat (pdWidths() AS DOUBLE, BYVAL psText AS BYTE PTR, BYVAL iCount AS LONG) AS DOUBLE

   LOCAL dWidth AS DOUBLE
   LOCAL i      AS LONG

   FOR i = 0 TO iCount - 1
      dWidth = dWidth + pdWidths(@psText[i])
   NEXT

   FUNCTION = dWidth

END FUNCTION
' ========================================================================================

' ========================================================================================
' Justify:  Based on design units for screen/printer compatibility
' ========================================================================================
SUB Justify (BYVAL hdc AS DWORD, szText AS ASCIIZ, rc AS RECT, BYVAL iAlign AS LONG)

   LOCAL dWidth      AS DOUBLE
   DIM   adWidths(0 TO %LASTCHAR) AS DOUBLE
   LOCAL xStart      AS LONG
   LOCAL yStart      AS LONG
   LOCAL cSpaceChars AS LONG
   LOCAL pText       AS BYTE PTR
   LOCAL pBegin      AS BYTE PTR
   LOCAL pEnd        AS BYTE PTR
   LOCAL tsize       AS SIZE

   ' Fill the adWidths array with floating point character widths
   GetScaledWidths hdc, adWidths()

   ' Call this function just once to get size.cy (font height)
   GetTextExtentPoint32 hdc, szText, 1, tsize

   pText = VARPTR(szText)
   yStart = rc.nTop

   DO                                            ' for each text line

      cSpaceChars = 0                            ' initialize number of spaces in line
      WHILE @pText = 32                          ' skip over leading spaces
         INCR pText
      WEND
      pBegin = pText                             ' set pointer to char at beginning of

      DO                                         ' until the line is known
         pEnd = pText                            ' set pointer to char at end of line
         ' skip to next space
         WHILE @pText <> 0 AND @pText <> 32
            INCR pText
         WEND
         IF @pText = 0 THEN EXIT DO
         INCR pText
         ' after each space encountered, calculate extents
         INCR cSpaceChars
         dWidth = GetTextExtentFloat(adWidths(), BYVAL pBegin, pText - pBegin - 1)
      LOOP WHILE dWidth < (rc.nRight - rc.nLeft)

      DECR cSpaceChars                           ' discount last space at end of line

      WHILE @pEnd - 1 = 32                       ' eliminate trailing spaces
         DECR pEnd
         DECR cSpaceChars
      WEND

      ' if end of text and no space characters, set pEnd to end
      IF @pText = 0 OR cSpaceChars <= 0 THEN pEnd = pText

      ' Now get integer extents
      GetTextExtentPoint32 hdc, BYVAL pBegin, pEnd - pBegin, tsize

      SELECT CASE iAlign

         CASE %IDM_ALIGN_LEFT
            xStart = rc.nLeft

         CASE %IDM_ALIGN_RIGHT
            xStart = rc.nRight - tsize.cx

         CASE %IDM_ALIGN_CENTER
            xStart = (rc.nRight + rc.nLeft - tsize.cx) \ 2

         CASE %IDM_ALIGN_JUSTIFIED
            IF @pText <> 0  AND cSpaceChars > 0 THEN
               SetTextJustification hdc, rc.nRight - rc.nLeft - tsize.cx, cSpaceChars
               xStart = rc.nLeft
            END IF

      END SELECT

      ' display the text
      TextOut hdc, xStart, yStart, BYVAL pBegin, pEnd - pBegin

      ' prepare for next line
      IF @pText <> 0 THEN
         SetTextJustification hdc, 0, 0
         yStart = yStart + tsize.cy
         pText = pEnd
      END IF

   LOOP WHILE @pText <> 0 AND yStart < (rc.nBottom - tsize.cy)

END SUB
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC cf             AS CHOOSEFONTAPI
   STATIC dinfo          AS DOCINFO
   STATIC iAlign         AS LONG
   STATIC lf             AS LOGFONT
   STATIC pd             AS PRINTDLGAPI
   STATIC szText         AS ASCIIZ * 2048
   STATIC szDocName      AS ASCIIZ * 256
   LOCAL  szFontName     AS ASCIIZ * 256
   LOCAL  fSuccess       AS LONG
   LOCAL  hdc            AS DWORD
   LOCAL  hdcPrn         AS DWORD
   LOCAL  hMenu          AS DWORD
   LOCAL  iSavePointSize AS LONG
   LOCAL  ps             AS PAINTSTRUCT
   LOCAL  rc             AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE

         szText = "Call me Ishmael. Some years ago -- never " & _
                  "mind how long precisely -- having little " & _
                  "or no money in my purse, and nothing " & _
                  "particular to interest me on shore, I " & _
                  "thought I would sail about a little and " & _
                  "see the watery part of the world. It is " & _
                  "a way I have of driving off the spleen, " & _
                  "and regulating the circulation. Whenever " & _
                  "I find myself growing grim about the " & _
                  "mouth; whenever it is a damp, drizzly " & _
                  "November in my soul; whenever I find " & _
                  "myself involuntarily pausing before " & _
                  "coffin warehouses, and bringing up the " & _
                  "rear of every funeral I meet; and " & _
                  "especially whenever my hypos get such an " & _
                  "upper hand of me, that it requires a " & _
                  "strong moral principle to prevent me " & _
                  "from deliberately stepping into the " & _
                  "street, and methodically knocking " & _
                  "people's hats off -- then, I account it " & _
                  "high time to get to sea as soon as I " & _
                  "can. This is my substitute for pistol " & _
                  "and ball. With a philosophical flourish " & _
                  "Cato throws himself upon his sword; I " & _
                  "quietly take to the ship. There is " & _
                  "nothing surprising in this. If they but " & _
                  "knew it, almost all men in their degree, " & _
                  "some time or other, cherish very nearly " & _
                  "the same feelings towards the ocean with " & _
                  "me."

         iAlign = %IDM_ALIGN_LEFT
         szDocName = "Justify2: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dinfo.lpszDocName = VARPTR(szDocName)

         ' Initialize the CHOOSEFONT structure
         hdc = GetDC(hwnd)
         lf.lfHeight = - GetDeviceCaps(hdc, %LOGPIXELSY) \ 6
         lf.lfFaceName = "Times New Roman"
         ReleaseDC hwnd, hdc

         cf.lStructSize    = SIZEOF(CHOOSEFONTAPI)
         cf.hwndOwner      = hwnd
         cf.hDC            = %NULL
         cf.lpLogFont      = VARPTR(lf)
         cf.iPointSize     = 0
         cf.Flags          = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS OR _
                             %CF_TTONLY OR %CF_EFFECTS
         cf.rgbColors      = 0
         cf.lCustData      = 0
         cf.lpfnHook       = %NULL
         cf.lpTemplateName = %NULL
         cf.hInstance      = %NULL
         cf.lpszStyle      = %NULL
         cf.nFontType      = 0
         cf.nSizeMin       = 0
         cf.nSizeMax       = 0

         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND

         hMenu = GetMenu(hwnd)

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_PRINT

               ' Get printer DC
               pd.lStructSize = SIZEOF(PRINTDLGAPI)
               pd.hwndOwner   = hwnd
               pd.Flags       = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               IF ISFALSE PrintDlg(pd) THEN EXIT FUNCTION
               hdcPrn = pd.hDC
               IF hdcPrn = %NULL THEN
                  MessageBox hwnd, "Cannot obtain Printer DC", _
                             szAppName, %MB_ICONEXCLAMATION OR %MB_OK
                  EXIT FUNCTION
               END IF

               ' Set margins of 1 inch
               rc.nLeft   = GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
               rc.nTop    = GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)
               rc.nRight  = GetDeviceCaps(hdcPrn, %PHYSICALWIDTH) - _
                            GetDeviceCaps(hdcPrn, %LOGPIXELSX) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETX)
               rc.nBottom = GetDeviceCaps(hdcPrn, %PHYSICALHEIGHT) - _
                            GetDeviceCaps(hdcPrn, %LOGPIXELSY) - _
                            GetDeviceCaps(hdcPrn, %PHYSICALOFFSETY)

               ' Display text on printer
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               fSuccess = %FALSE
               IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                  ' Select font using adjusted lfHeight
                  iSavePointSize = lf.lfHeight
                  lf.lfHeight = -(GetDeviceCaps (hdcPrn, %LOGPIXELSY) * _
                                  cf.iPointSize) \ 720
                  SelectObject hdcPrn, CreateFontIndirect(lf)
                  lf.lfHeight = iSavePointSize
                  ' Set text color
                  SetTextColor hdcPrn, cf.rgbColors
                  ' Display text
                  Justify hdcPrn, szText, rc, iAlign
                  IF EndPage(hdcPrn) > 0 THEN
                     fSuccess = %TRUE
                     EndDoc hdcPrn
                  END IF
               END IF

               ShowCursor %FALSE
               SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
               DeleteDC hdcPrn

               IF ISFALSE fSuccess THEN
                  MessageBox hwnd, "Could not print text", _
                             szAppName, %MB_ICONEXCLAMATION OR %MB_OK
               END IF

            CASE %IDM_FONT
               IF ChooseFont(cf) THEN
                  InvalidateRect hwnd, BYVAL %NULL, %TRUE
               END IF

            CASE %IDM_ALIGN_LEFT, %IDM_ALIGN_RIGHT, %IDM_ALIGN_CENTER, %IDM_ALIGN_JUSTIFIED
               CheckMenuItem hMenu, iAlign, %MF_UNCHECKED
               iAlign = LO(WORD, wParam)
               CheckMenuItem hMenu, iAlign, %MF_CHECKED
               InvalidateRect hwnd, BYVAL %NULL, %TRUE

         END SELECT
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         GetClientRect hwnd, rc
         DrawRuler hdc, rc
         rc.nLeft  = rc.nLeft + GetDeviceCaps(hdc, %LOGPIXELSX) \ 2
         rc.nTop   = rc.nTop + GetDeviceCaps (hdc, %LOGPIXELSY) \ 2
         rc.nRight = rc.nLeft + %OUTWIDTH * GetDeviceCaps(hdc, %LOGPIXELSX)
         SelectObject hdc, CreateFontIndirect(lf)
         SetTextColor hdc, cf.rgbColors
         Justify hdc, szText, rc, iAlign
         DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


JUSTIFY2.RC

Code: [Select]

#define IDM_FILE_PRINT                  40001
#define IDM_FONT                        40002
#define IDM_ALIGN_LEFT                  40003
#define IDM_ALIGN_RIGHT                 40004
#define IDM_ALIGN_CENTER                40005
#define IDM_ALIGN_JUSTIFIED             40006

/////////////////////////////////////////////////////////////////////////////
// Menu

JUSTIFY2 MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print",                      IDM_FILE_PRINT
    END
    POPUP "&Font"
    BEGIN
        MENUITEM "&Font...",                    IDM_FONT
    END
    POPUP "&Align"
    BEGIN
        MENUITEM "&Left",                       IDM_ALIGN_LEFT, CHECKED
        MENUITEM "&Right",                      IDM_ALIGN_RIGHT
        MENUITEM "&Centered",                   IDM_ALIGN_CENTER
        MENUITEM "&Justified",                  IDM_ALIGN_JUSTIFIED
    END
END


[José Roca]

 
This program is a translation of KEYVIEW1.C-Displays Keyboard and Character Messages © Charles Petzold, 1998, described and analysed in Chapter 6 of the book Programming Windows, 5th Edition.

Displays in its client area all the information that Windows sends the window procedure for the eight different keyboard messages.

Code: [Select]

' ========================================================================================
' KEYVIEW1.BAS
' This program is a translation/adaptation of KEYVIEW1.C-Displays Keyboard and Character
' Messages © Charles Petzold, 1998, described and analysed in Chapter 6 of the book
' Programming Windows, 5th Edition.
' Displays in its client area all the information that Windows sends the window procedure
' for the eight different keyboard messages.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

TYPE PMESSAGE
  hwnd AS DWORD
  message AS DWORD
  wParam AS LONG
  lParam AS LONG
END TYPE

$szTop = "Message        Key       Char        Repeat Scan Ext ALT Prev Tran"
$szUnd = "_______        ___       ____        ______ ____ ___ ___ ____ ____"
$szYes  = "Yes"
$szNo   = "No"
$szDown = "Down"
$szUp   = "Up"

GLOBAL szMessage() AS ASCIIZ * 15


' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   REDIM szMessage(7)
   szMessage (0) = "WM_KEYDOWN"
   szMessage (1) = "WM_KEYUP"
   szMessage (2) = "WM_CHAR"
   szMessage (3) = "WM_DEADCHAR"
   szMessage (4) = "WM_SYSKEYDOWN"
   szMessage (5) = "WM_SYSKEYUP"
   szMessage (6) = "WM_SYSCHAR"
   szMessage (7) = "WM_SYSDEADCHAR"

   szAppName        = "KeyView1"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Keyboard Message Viewer #1"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC cxClientMax AS LONG
   STATIC cyClientMax AS LONG
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   STATIC cxChar AS LONG
   STATIC cyChar AS LONG
   STATIC cLinesMax AS LONG
   STATIC cLines AS LONG
   STATIC rectScroll AS RECT
   LOCAL  hdc AS DWORD
   LOCAL  i AS LONG
   LOCAL  iType AS LONG
   LOCAL  ps  AS PAINTSTRUCT
   LOCAL  szBuffer AS ASCIIZ * 128
   LOCAL  szKeyName AS ASCIIZ * 128
   LOCAL  tm AS TEXTMETRIC
   DIM    pmsg(0) AS STATIC PMESSAGE

   LOCAL  strMessage AS STRING * 14
   LOCAL  strKey AS STRING * 21
   LOCAL  strRepeat AS STRING * 6
   LOCAL  strScan AS STRING * 4

   SELECT CASE uMsg

      CASE %WM_CREATE, %WM_DISPLAYCHANGE

         ' Get maximum size of client area
         cxClientMax = GetSystemMetrics(%SM_CXMAXIMIZED)
         cyClientMax = GetSystemMetrics(%SM_CYMAXIMIZED)
         ' Get character size for fixed-pitch font
         hdc = GetDC(hwnd)
         SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
         GetTextMetrics hdc, tm
         cxChar = tm.tmAveCharWidth
         cyChar = tm.tmHeight
         ReleaseDC hwnd, hdc
         ' Allocate memory for display lines
         cLinesMax = cyClientMax / cyChar
         REDIM pmsg(cLinesMax - 1)
         cLines = 0
         ' Fall though

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         rectScroll.nLeft = 0
         rectScroll.nRight = cxClient
         rectScroll.nTop = 3 * cyChar / 2
         rectScroll.nBottom = cyChar * (cyClient / cyChar)
         InvalidateRect hwnd, BYVAL %NULL, %TRUE
         EXIT FUNCTION

      CASE %WM_KEYDOWN, %WM_KEYUP, %WM_CHAR, %WM_DEADCHAR, _
           %WM_SYSKEYDOWN, %WM_SYSKEYUP, %WM_SYSCHAR, %WM_SYSDEADCHAR

         ' Rearrange storage array
         FOR i = cLinesMax - 1 TO 0 STEP -1
            pmsg(i) = pmsg(i - 1)
         NEXT

         ' Store new message
         pmsg(0).hwnd = hwnd
         pmsg(0).message = uMsg
         pmsg(0).wParam = wParam
         pmsg(0).lParam = lParam
         cLines = MIN&(cLines + 1, cLinesMax)

         ' Scroll up the display
         ScrollWindow hwnd, 0, -cyChar, rectScroll, rectScroll

         ' Fall through DefWindowProc so Sys messages work

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         SelectObject hdc, GetStockObject(%SYSTEM_FIXED_FONT)
         SetBkMode hdc, %TRANSPARENT
         TextOut hdc, 0, 0, BYCOPY $szTop, LEN($szTop)
         TextOut hdc, 0, 0, BYCOPY $szUnd, LEN($szUnd)
         FOR i = 0 TO MIN&(cLines, cyClient / cyChar - 1) - 1
            IF i <= UBOUND(pmsg) THEN
               IF pmsg(i).wParam THEN
                  GetKeyNameText pmsg(i).lParam, szKeyName, SIZEOF(szKeyName)
                  strMessage = szMessage(pmsg(i).message - %WM_KEYFIRST)
                     IF pmsg(i).message = %WM_CHAR OR _
                     pmsg(i).message = %WM_SYSCHAR OR _
                     pmsg(i).message = %WM_DEADCHAR OR _
                     pmsg(i).message = %WM_SYSDEADCHAR THEN
                     strKey = "          &H" & HEX$(pmsg(i).wParam, 4) & " " & CHR$(pmsg(i).wParam)
                  ELSE
                     strKey = FORMAT$(pmsg(i).wParam) & " " & szKeyName
                  END IF
                  RSET strRepeat = STR$(LO(WORD, pmsg(i).lParam))
                  RSET strScan = STR$(HI(WORD, pmsg(i).lParam) AND &HFF)
                  szBuffer = strMessage & " " & strKey & " " & strRepeat & " " & strScan & " "
                  IF (pmsg(i).lParam AND &H01000000) THEN
                     szBuffer = szBuffer & $szYes & " "
                  ELSE
                     szBuffer = szBuffer & " " & $szNo & " "
                  END IF
                  IF (pmsg(i).lParam AND &H20000000) THEN
                     szBuffer = szBuffer & $szYes & " "
                  ELSE
                     szBuffer = szBuffer & " " & $szNo & " "
                  END IF
                  IF (pmsg(i).lParam AND &H40000000) THEN
                     szBuffer = szBuffer & $szDown & " "
                  ELSE
                     szBuffer = szBuffer & "  " & $szUp & " "
                  END IF
                  IF (pmsg(i).lParam AND &H80000000) THEN
                     szBuffer = szBuffer & "  " & $szUp
                  ELSE
                     szBuffer = szBuffer & $szDown
                  END IF
                  TextOut hdc, 0, (cyClient / cyChar - 1 - i) * cyChar, szBuffer, LEN(szBuffer)
               END IF
            END IF
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of the LINEDEMO.C-Line-Drawing Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book Programming Windows, 5th Edition.

Draws a rectangle, an ellipse, a rectangle with rounded corners, and two lines, but not in that order. The program demonstrates that these functions that define closed areas do indeed fill them, because the lines are hidden behind the ellipse.

Code: [Select]

' ========================================================================================
' LINEDEMO.BAS
' This program is a translation/adaptation of the LINEDEMO.C-Line-Drawing Demonstration
' Program © Charles Petzold, 1998, described and analysed in Chapter 5 of the book
' Programming Windows, 5th Edition.
' Draws a rectangle, an ellipse, a rectangle with rounded corners, and two lines, but not
' in that order. The program demonstrates that these functions that define closed areas do
' indeed fill them, because the lines are hidden behind the ellipse.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName        = "LineDemo"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Line Demonstration"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  i AS LONG
   LOCAL  ps  AS PAINTSTRUCT

   SELECT CASE uMsg

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         Rectangle hdc, cxClient / 8, cyClient / 8, 7 * cxClient / 8, 7 * cyClient / 8
         MoveToEx hdc, 0, 0, BYVAL %NULL
         LineTo hdc, cxClient, cyClient
         MoveToEx hdc, 0, cyClient, BYVAL %NULL
         LineTo hdc, cxClient, 0
         Ellipse hdc, cxClient / 8, cyClient / 8, 7 * cxClient / 8, 7 * cyClient / 8
         RoundRect hdc, cxClient / 4, cyClient / 4, 3 * cxClient / 4, 3 * cyClient / 4, cxClient / 4, cyClient / 4
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of MDIDEMO.C -- Multiple-Document Interface Demonstration © Charles Petzold, 1998, described and analysed in Chapter 19 of the book Programming Windows, 5th Edition.

Demonstrates the basics of writing an MDI application.

MDIDEMO supports two types of extremely simple document windows: one displays "Hello, World!" in the center of its client area, and the other displays a series of random rectangles. (In the source code listings and identifier names, these are referred to as the Hello document and the Rect document.) Different menus are associated with these two types of document windows. The document window that displays "Hello, World!" has a menu that allows you to change the color of the text.

Code: [Select]

' ========================================================================================
' MDIDEMO.BAS
' This program is a translation/adaptation of MDIDEMO.C -- Multiple-Document Interface
' Demonstration © Charles Petzold, 1998, described and analysed in Chapter 19 of the book
' Programming Windows, 5th Edition.
' Demonstrates the basics of writing an MDI application.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "mdidemo.res"

%IDM_FILE_NEWHELLO   = 40001
%IDM_FILE_NEWRECT    = 40002
%IDM_APP_EXIT        = 40003
%IDM_FILE_CLOSE      = 40004
%IDM_COLOR_BLACK     = 40005
%IDM_COLOR_RED       = 40006
%IDM_COLOR_GREEN     = 40007
%IDM_COLOR_BLUE      = 40008
%IDM_COLOR_WHITE     = 40009
%IDM_WINDOW_CASCADE  = 40010
%IDM_WINDOW_TILE     = 40011
%IDM_WINDOW_ARRANGE  = 40012
%IDM_WINDOW_CLOSEALL = 40013

%INIT_MENU_POS   = 0
%HELLO_MENU_POS  = 2
%RECT_MENU_POS   = 1

%IDM_FIRSTCHILD  = 50000

' structure for storing data unique to each Hello child window
TYPE HELLODATA
   iColor  AS DWORD
   clrText AS DWORD
END TYPE

' structure for storing data unique to each Rect child window
TYPE RECTDATA
   cxClient  AS INTEGER
   cyClient  AS INTEGER
END TYPE

GLOBAL szAppName    AS ASCIIZ * 256
GLOBAL szFrameClass AS ASCIIZ * 256
GLOBAL szHelloClass AS ASCIIZ * 256
GLOBAL szRectClass  AS ASCIIZ * 256

GLOBAL hInst            AS DWORD
GLOBAL hMenuInit        AS DWORD
GLOBAL hMenuHello       AS DWORD
GLOBAL hMenuRect        AS DWORD
GLOBAL hMenuInitWindow  AS DWORD
GLOBAL hMenuHelloWindow AS DWORD
GLOBAL hMenuRectWindow  AS DWORD

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hAccel     AS DWORD
   LOCAL hwndFrame  AS DWORD
   LOCAL hwndClient AS DWORD
   LOCAL wcex       AS WNDCLASSEX
   LOCAL szCaption  AS ASCIIZ * 256

   szAppName    = "MDIDemo"
   szFrameClass = "MdiFrame"
   szHelloClass = "MdiHelloChild"
   szRectClass  = "MdiRectChild"

   ' Register the frame window class

   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(FrameWndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = %COLOR_APPWORKSPACE + 1
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szFrameClass)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   ' Register the Hello child window class
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(HelloWndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 4
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szHelloClass)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   ' Register the Rect child window class
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(RectWndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 4
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szRectClass)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   ' Obtain handles to three possible menus & submenus
   hMenuInit  = LoadMenu(hInstance, "MdiMenuInit")
   hMenuHello = LoadMenu(hInstance, "MdiMenuHello")
   hMenuRect  = LoadMenu(hInstance, "MdiMenuRect")

   hMenuInitWindow  = GetSubMenu(hMenuInit,   %INIT_MENU_POS)
   hMenuHelloWindow = GetSubMenu(hMenuHello, %HELLO_MENU_POS)
   hMenuRectWindow  = GetSubMenu(hMenuRect,   %RECT_MENU_POS)

   ' Load accelerator table
   hAccel = LoadAccelerators(hInstance, szAppName)

   ' Create the frame window
   szCaption = "MDI Demonstration"
   hWndFrame = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                              szFrameClass, _           ' window class name
                              szCaption, _              ' window caption
                              %WS_OVERLAPPEDWINDOW, _   ' window style
                              %CW_USEDEFAULT, _         ' initial x position
                              %CW_USEDEFAULT, _         ' initial y position
                              %CW_USEDEFAULT, _         ' initial x size
                              %CW_USEDEFAULT, _         ' initial y size
                              %NULL, _                  ' parent window handle
                              hMenuInit, _              ' window menu handle
                              hInstance, _              ' program instance handle
                              BYVAL %NULL)              ' creation parameters

   hwndClient = GetWindow(hwndFrame, %GW_CHILD)

   ShowWindow hwndFrame, iCmdShow
   UpdateWindow hwndFrame

   ' Enter the modified message loop
   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      IF ISFALSE TranslateMDISysAccel(hwndClient, uMsg) THEN
         IF ISFALSE TranslateAccelerator(hwndFrame, hAccel, uMsg) THEN
            TranslateMessage uMsg
            DispatchMessage uMsg
         END IF
      END IF
   WEND

   ' Clean up by deleting unattached menus
   DestroyMenu hMenuHello
   DestroyMenu hMenuRect

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Frame dialog callback.
' ========================================================================================
FUNCTION FrameWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hwndClient   AS DWORD
   LOCAL  clientcreate AS CLIENTCREATESTRUCT
   LOCAL  hwndChild    AS DWORD
   LOCAL  mdicreate    AS MDICREATESTRUCT
   LOCAL  szTitle      AS ASCIIZ * 256

   SELECT CASE uMsg

      CASE %WM_CREATE    ' Create the client window
         clientcreate.hWindowMenu  = hMenuInitWindow
         clientcreate.idFirstChild = %IDM_FIRSTCHILD
         hwndClient = CreateWindowEx(0, "MDICLIENT", BYVAL %NULL, _
                                     %WS_CHILD OR %WS_CLIPCHILDREN OR %WS_VISIBLE, _
                                     0, 0, 0, 0, hwnd, 1, hInst, _
                                     BYVAL VARPTR(clientcreate))
         EXIT FUNCTION

      CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_NEWHELLO       ' Create a Hello child window
               szTitle           = "Hello"
               mdicreate.szClass = VARPTR(szHelloClass)
               mdicreate.szTitle = VARPTR(szTitle)
               mdicreate.hOwner  = hInst
               mdicreate.x       = %CW_USEDEFAULT
               mdicreate.y       = %CW_USEDEFAULT
               mdicreate.cx      = %CW_USEDEFAULT
               mdicreate.cy      = %CW_USEDEFAULT
               mdicreate.style   = 0
               mdicreate.lParam  = 0
               hwndChild = SendMessage(hwndClient, %WM_MDICREATE, 0, VARPTR(mdicreate))
               EXIT FUNCTION

            CASE %IDM_FILE_NEWRECT       ' Create a Rect child window
               szTitle           = "Rectangles"
               mdicreate.szClass = VARPTR(szRectClass)
               mdicreate.szTitle = VARPTR(SzTitle)
               mdicreate.hOwner  = hInst
               mdicreate.x       = %CW_USEDEFAULT
               mdicreate.y       = %CW_USEDEFAULT
               mdicreate.cx      = %CW_USEDEFAULT
               mdicreate.cy      = %CW_USEDEFAULT
               mdicreate.style   = 0
               mdicreate.lParam  = 0
               hwndChild = SendMessage(hwndClient, %WM_MDICREATE, 0, VARPTR(mdicreate))
               EXIT FUNCTION

            CASE %IDM_FILE_CLOSE         ' Close the active window
               hwndChild = SendMessage(hwndClient, %WM_MDIGETACTIVE, 0, 0)
               IF SendMessage(hwndChild, %WM_QUERYENDSESSION, 0, 0) THEN
                  SendMessage hwndClient, %WM_MDIDESTROY, hwndChild, 0
               END IF
               EXIT FUNCTION

            CASE %IDM_APP_EXIT            ' Exit the program
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION

            ' // messages for arranging windows

            CASE %IDM_WINDOW_TILE
               SendMessage hwndClient, %WM_MDITILE, 0, 0
               EXIT FUNCTION

            CASE %IDM_WINDOW_CASCADE
               SendMessage hwndClient, %WM_MDICASCADE, 0, 0
               EXIT FUNCTION

            CASE %IDM_WINDOW_ARRANGE
               SendMessage hwndClient, %WM_MDIICONARRANGE, 0, 0
               EXIT FUNCTION

            CASE %IDM_WINDOW_CLOSEALL     ' Attempt to close all children
               EnumChildWindows hwndClient, CODEPTR(CloseEnumProc), 0
               EXIT FUNCTION

            CASE ELSE                     ' Pass to active child...
               hwndChild = SendMessage (hwndClient, %WM_MDIGETACTIVE, 0, 0)
               IF IsWindow(hwndChild) THEN
                    SendMessage hwndChild, %WM_COMMAND, wParam, lParam
               END IF
               ' ...and fall through DefFrameProc

         END SELECT

      CASE %WM_QUERYENDSESSION, %WM_CLOSE    ' Attempt to close all children
         SendMessage hwnd, %WM_COMMAND, %IDM_WINDOW_CLOSEALL, 0
         IF GetWindow(hwndClient, %GW_CHILD) <> %NULL THEN
            EXIT FUNCTION
         END IF
         ' Fall through DefFrameProc

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefFrameProc(hwnd, hwndClient, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
FUNCTION CloseEnumProc (BYVAL hwnd AS DWORD, BYVAL lParam AS LONG) AS LONG

   IF GetWindow(hwnd, %GW_OWNER) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   SendMessage GetParent(hwnd), %WM_MDIRESTORE, hwnd, 0

   IF ISFALSE SendMessage(hwnd, %WM_QUERYENDSESSION, 0, 0) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   SendMessage GetParent(hwnd), %WM_MDIDESTROY, hwnd, 0
   FUNCTION = %TRUE

END FUNCTION
' ========================================================================================

' ========================================================================================
FUNCTION HelloWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   DIM    clrTextArray(4) AS STATIC DWORD
   STATIC hwndClient AS DWORD
   STATIC hwndFrame  AS DWORD
   LOCAL  hdc        AS DWORD
   LOCAL  hMenu      AS DWORD
   LOCAL  pHelloData AS HELLODATA PTR
   LOCAL  ps         AS PAINTSTRUCT
   LOCAL  rc         AS RECT

   SELECT CASE uMsg

      CASE %WM_CREATE

         clrTextArray(0) = RGB(0, 0, 0)
         clrTextArray(1) = RGB(255, 0, 0)
         clrTextArray(2) = RGB(0, 255, 0)
         clrTextArray(3) = RGB(0, 0, 255)
         clrTextArray(4) = RGB(255, 255, 255)

         '  Allocate memory for window private data
         pHelloData = HeapAlloc(GetprocessHeap, %HEAP_ZERO_MEMORY, SIZEOF(HELLODATA))
         @pHelloData.iColor  = %IDM_COLOR_BLACK
         @pHelloData.clrText = RGB(0, 0, 0)
         SetWindowLong hwnd, 0, pHelloData

         ' Save some window handles
         hwndClient = GetParent(hwnd)
         hwndFrame  = GetParent(hwndClient)
         EXIT FUNCTION

      CASE %WM_COMMAND
         SELECT CASE LO(WORD, wParam)
            CASE %IDM_COLOR_BLACK, %IDM_COLOR_RED, %IDM_COLOR_GREEN, _
                 %IDM_COLOR_BLUE, %IDM_COLOR_WHITE
               ' Change the text color
               pHelloData = GetWindowLong (hwnd, 0)
               hMenu = GetMenu(hwndFrame)
               CheckMenuItem hMenu, @pHelloData.iColor, %MF_UNCHECKED
               @pHelloData.iColor = wParam
               CheckMenuItem hMenu, @pHelloData.iColor, %MF_CHECKED
               @pHelloData.clrText = clrTextArray(wParam - %IDM_COLOR_BLACK)
               InvalidateRect hwnd, BYVAL %NULL, %FALSE
         END SELECT
         EXIT FUNCTION

      CASE %WM_PAINT
         ' Paint the window
         hdc = BeginPaint(hwnd, ps)
         pHelloData = GetWindowLong (hwnd, 0)
         SetTextColor hdc, @pHelloData.clrText
         GetClientRect hwnd, rc
         DrawText hdc, "Hello, World!", -1, rc, %DT_SINGLELINE OR %DT_CENTER OR %DT_VCENTER
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_MDIACTIVATE
         ' Set the Hello menu if gaining focus
         IF lParam = hwnd THEN
            SendMessage hWndClient, %WM_MDISETMENU, hMenuHello, hMenuHelloWindow
         END IF
         ' Check or uncheck menu item
         pHelloData = GetWindowLong(hwnd, 0)
         CheckMenuItem hMenuHello, @pHelloData.iColor, _
                       IIF&(lParam = hwnd, %MF_CHECKED, %MF_UNCHECKED)
         ' Set the Init menu if losing focus
         IF lParam <> hwnd THEN
            SendMessage hwndCLient, %WM_MDISETMENU, hMenuInit, hMenuInitWindow
         END IF
         DrawMenuBar hwndFrame
         EXIT FUNCTION

      CASE %WM_QUERYENDSESSION, %WM_CLOSE
         IF MessageBox(hwnd, "OK to close window?", "Hello", %MB_ICONQUESTION OR %MB_OKCANCEL) <> %IDOK THEN
            EXIT FUNCTION
         END IF
         ' Fall through DefMDIChildProc

      CASE %WM_DESTROY
         pHelloData = GetWindowLong (hwnd, 0)
         HeapFree GetProcessHeap, 0, pHelloData
         EXIT FUNCTION

   END SELECT

   ' Pass unprocessed message to DefMDIChildProc

   FUNCTION = DefMDIChildProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================

' ========================================================================================
FUNCTION RectWndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hwndClient AS DWORD
   STATIC hwndFrame  AS DWORD
   LOCAL  hBrush     AS DWORD
   LOCAL  hdc        AS DWORD
   LOCAL  pRectData  AS RECTDATA PTR
   LOCAL  ps         AS PAINTSTRUCT
   LOCAL  xLeft      AS LONG
   LOCAL  xRight     AS LONG
   LOCAL  yTop       AS LONG
   LOCAL  yBottom    AS LONG
   LOCAL  nRed       AS INTEGER
   LOCAL  nGreen     AS INTEGER
   LOCAL  nBlue      AS INTEGER

   SELECT CASE uMsg

      CASE %WM_CREATE

         ' Allocate memory for window private data
         pRectData = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, SIZEOF(RECTDATA))
         SetWindowLong hwnd, 0, pRectData
         ' Start the timer going
         SetTimer hwnd, 1, 250, %NULL
         ' Save some window handles
         hwndClient = GetParent(hwnd)
         hwndFrame  = GetParent(hwndClient)
         EXIT FUNCTION

      CASE %WM_SIZE            ' // If not minimized, save the window size
         IF wParam <> %SIZE_MINIMIZED THEN
            pRectData = GetWindowLong(hwnd, 0)
            @pRectData.cxClient = LO(WORD, lParam)
            @pRectData.cyClient = HI(WORD, lParam)
         END IF
         ' %WM_SIZE must be processed by DefMDIChildProc

      CASE %WM_TIMER           ' // Display a random rectangle
         pRectData = GetWindowLong(hwnd, 0)
         xLeft   = RND * @pRectData.cxClient
         xRight  = RND * @pRectData.cxClient
         yTop    = RND * @pRectData.cyClient
         yBottom = RND * @pRectData.cyClient
         nRed    = RND * 255
         nGreen  = RND * 255
         nBlue   = RND * 255
         hdc = GetDC(hwnd)
         hBrush = CreateSolidBrush(RGB(nRed, nGreen, nBlue))
         SelectObject hdc, hBrush
         Rectangle hdc, min (xLeft, xRight), min (yTop, yBottom), _
                   MAX&(xLeft, xRight), MAX&(yTop, yBottom)
         ReleaseDC hwnd, hdc
         DeleteObject hBrush
         EXIT FUNCTION

      CASE %WM_PAINT           ' Clear the window
         InvalidateRect hwnd, BYVAL %NULL, %TRUE
         hdc = BeginPaint(hwnd, ps)
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_MDIACTIVATE     '/ Set the appropriate menu
         IF lParam = hwnd THEN
            SendMessage hwndClient, %WM_MDISETMENU, hMenuRect, hMenuRectWindow
         ELSE
            SendMessage hwndClient, %WM_MDISETMENU, hMenuInit, hMenuInitWindow
         END IF
         DrawMenuBar hwndFrame
         EXIT FUNCTION

      CASE %WM_DESTROY
         pRectData = GetWindowLong(hwnd, 0)
         HeapFree GetProcessHeap, 0, pRectData
         KillTimer hwnd, 1
         EXIT FUNCTION

   END SELECT

   ' Pass unprocessed message to DefMDIChildProc

   FUNCTION = DefMDIChildProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of MENUDEMO.C -- Menu Demonstration © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming Windows, 5th Edition.

The MENUDEMO program has five items in the main menu-File, Edit, Background, Timer, and Help. Each of these items has a popup. MENUDEMO does the simplest and most common type of menu processing, which involves trapping WM_COMMAND messages and checking the low word of wParam.

Code: [Select]

' ========================================================================================
' MENUDEMO.BAS
' This program is a translation/adaptation of MENUDEMO.C -- Menu Demonstration
' © Charles Petzold, 1998, described and analysed in Chapter 10 of the book Programming
' Windows, 5th Edition.
' The MENUDEMO program has five items in the main menu-File, Edit, Background, Timer, and
' Help. Each of these items has a popup. MENUDEMO does the simplest and most common type
' of menu processing, which involves trapping WM_COMMAND messages and checking the low
' word of wParam.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"
#RESOURCE RES, "menudemo.res"

%ID_TIMER = 1

%IDM_FILE_NEW     = 40001
%IDM_FILE_OPEN    = 40002
%IDM_FILE_SAVE    = 40003
%IDM_FILE_SAVE_AS = 40004
%IDM_APP_EXIT     = 40005
%IDM_EDIT_UNDO    = 40006
%IDM_EDIT_CUT     = 40007
%IDM_EDIT_COPY    = 40008
%IDM_EDIT_PASTE   = 40009
%IDM_EDIT_CLEAR   = 40010
%IDM_BKGND_WHITE  = 40011
%IDM_BKGND_LTGRAY = 40012
%IDM_BKGND_GRAY   = 40013
%IDM_BKGND_DKGRAY = 40014
%IDM_BKGND_BLACK  = 40015
%IDM_TIMER_START  = 40016
%IDM_TIMER_STOP   = 40017
%IDM_APP_HELP     = 40018
%IDM_APP_ABOUT    = 40019

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "MenuDemo"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = VARPTR(szAppName)
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Menu Demonstration"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   DIM idColor(0 TO 4) AS STATIC LONG
   STATIC iSelection AS LONG
   LOCAL hMenu AS DWORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         idColor(0) = %WHITE_BRUSH
         idColor(1) = %LTGRAY_BRUSH
         idColor(2) = %GRAY_BRUSH
         idColor(3) = %DKGRAY_BRUSH
         idColor(4) = %BLACK_BRUSH
         iSelection = %IDM_BKGND_WHITE
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND

         hMenu = GetMenu(hwnd)

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_NEW, _
                 %IDM_FILE_OPEN, _
                 %IDM_FILE_SAVE, _
                 %IDM_FILE_SAVE_AS
                 MessageBeep 0

            CASE %IDM_APP_EXIT:
                 SendMessage hwnd, %WM_CLOSE, 0, 0

            CASE %IDM_EDIT_UNDO, _
                 %IDM_EDIT_CUT, _
                 %IDM_EDIT_COPY, _
                 %IDM_EDIT_PASTE, _
                 %IDM_EDIT_CLEAR
                 MessageBeep 0

            CASE %IDM_BKGND_WHITE, _        ' // Note: Logic below
                 %IDM_BKGND_LTGRAY, _       ' //   assumes that IDM_WHITE
                 %IDM_BKGND_GRAY, _         ' //   through IDM_BLACK are
                 %IDM_BKGND_DKGRAY, _       ' //   consecutive numbers in
                 %IDM_BKGND_BLACK           ' //   the order shown here.

                 CheckMenuItem hMenu, iSelection, %MF_UNCHECKED
                 iSelection = LO(WORD, wParam)
                 CheckMenuItem hMenu, iSelection, %MF_CHECKED
                 SetClassLong hwnd, %GCL_HBRBACKGROUND, _
                     GetStockObject(idColor(LO(WORD, wParam) - %IDM_BKGND_WHITE))
                 InvalidateRect hwnd, BYVAL %NULL, %TRUE

            CASE %IDM_TIMER_START
               IF SetTimer(hwnd, %ID_TIMER, 1000, %NULL) THEN
                  EnableMenuItem hMenu, %IDM_TIMER_START, %MF_GRAYED
                  EnableMenuItem hMenu, %IDM_TIMER_STOP,  %MF_ENABLED
               END IF

            CASE %IDM_TIMER_STOP
               KillTimer hwnd, %ID_TIMER
               EnableMenuItem hMenu, %IDM_TIMER_START, %MF_ENABLED
               EnableMenuItem hMenu, %IDM_TIMER_STOP,  %MF_GRAYED

            CASE %IDM_APP_HELP
               MessageBox hwnd, "Help not yet implemented!", _
                           "MenuDemo", %MB_ICONEXCLAMATION OR %MB_OK

            CASE %IDM_APP_ABOUT
               MessageBox hwnd, "Menu Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                           "MenuDemo", %MB_ICONINFORMATION OR %MB_OK

         END SELECT
         EXIT FUNCTION

      CASE %WM_TIMER
         MessageBeep 0
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


MenuDemo.rc

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_TIMER_START                 40016
#define IDM_TIMER_STOP                  40017
#define IDM_APP_HELP                    40018
#define IDM_APP_ABOUT                   40019

/////////////////////////////////////////////////////////////////////////////
// Menu

MENUDEMO MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&New",                        IDM_FILE_NEW
        MENUITEM "&Open",                       IDM_FILE_OPEN
        MENUITEM "&Save",                       IDM_FILE_SAVE
        MENUITEM "Save &As...",                 IDM_FILE_SAVE_AS
        MENUITEM SEPARATOR
        MENUITEM "E&xit",                       IDM_APP_EXIT
    END
    POPUP "&Edit"
    BEGIN
        MENUITEM "&Undo",                       IDM_EDIT_UNDO
        MENUITEM SEPARATOR
        MENUITEM "C&ut",                        IDM_EDIT_CUT
        MENUITEM "&Copy",                       IDM_EDIT_COPY
        MENUITEM "&Paste",                      IDM_EDIT_PASTE
        MENUITEM "De&lete",                     IDM_EDIT_CLEAR
    END
    POPUP "&Background"
    BEGIN
        MENUITEM "&White",                      IDM_BKGND_WHITE, CHECKED
        MENUITEM "&Light Gray",                 IDM_BKGND_LTGRAY
        MENUITEM "&Gray",                       IDM_BKGND_GRAY
        MENUITEM "&Dark Gray",                  IDM_BKGND_DKGRAY
        MENUITEM "&Black",                      IDM_BKGND_BLACK
    END
    POPUP "&Timer"
    BEGIN
        MENUITEM "&Start",                      IDM_TIMER_START
        MENUITEM "S&top",                       IDM_TIMER_STOP, GRAYED
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&Help...",                    IDM_APP_HELP
        MENUITEM "&About MenuDemo...",          IDM_APP_ABOUT
    END
END



[José Roca]

 
Code that creates the same menu as used in the MENUDEMO program but without requiring a resource script file.

Code: [Select]

' ========================================================================================
' MENUDEMO2.BAS
' Code that creates the same menu as used in the MENUDEMO program but without requiring a
' resource script file.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

%ID_TIMER = 1

%IDM_FILE_NEW     = 40001
%IDM_FILE_OPEN    = 40002
%IDM_FILE_SAVE    = 40003
%IDM_FILE_SAVE_AS = 40004
%IDM_APP_EXIT     = 40005
%IDM_EDIT_UNDO    = 40006
%IDM_EDIT_CUT     = 40007
%IDM_EDIT_COPY    = 40008
%IDM_EDIT_PASTE   = 40009
%IDM_EDIT_CLEAR   = 40010
%IDM_BKGND_WHITE  = 40011
%IDM_BKGND_LTGRAY = 40012
%IDM_BKGND_GRAY   = 40013
%IDM_BKGND_DKGRAY = 40014
%IDM_BKGND_BLACK  = 40015
%IDM_TIMER_START  = 40016
%IDM_TIMER_STOP   = 40017
%IDM_APP_HELP     = 40018
%IDM_APP_ABOUT    = 40019

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd       AS DWORD
   LOCAL szAppName  AS ASCIIZ * 256
   LOCAL wcex       AS WNDCLASSEX
   LOCAL szCaption  AS ASCIIZ * 256
   LOCAL hMenu      AS DWORD
   LOCAL hMenuPopup AS DWORD

   szAppName          = "MenuDemo2"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Menu Demonstration #2"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   hMenu = CreateMenu()

      hMenuPopup = CreateMenu()
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_FILE_NEW,     "&New"
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_FILE_OPEN,    "&Open..."
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_FILE_SAVE,    "&Save"
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_FILE_SAVE_AS, "Save &As..."
         AppendMenu hMenuPopup, %MF_SEPARATOR, 0,                 BYVAL %NULL
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_APP_EXIT,     "E&xit"
      AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&File"

      hMenuPopup = CreateMenu()
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_EDIT_UNDO,  "&Undo"
         AppendMenu hMenuPopup, %MF_SEPARATOR, 0,               BYVAL %NULL
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_EDIT_CUT,   "Cu&t"
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_EDIT_COPY,  "&Copy"
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_EDIT_PASTE, "&Paste"
         AppendMenu hMenuPopup, %MF_STRING,    %IDM_EDIT_CLEAR, "De&lete"
      AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Edit"

      hMenuPopup = CreateMenu()
         AppendMenu hMenuPopup, %MF_STRING OR %MF_CHECKED, %IDM_BKGND_WHITE,  "&White"
         AppendMenu hMenuPopup, %MF_STRING,                %IDM_BKGND_LTGRAY, "&Light Gray"
         AppendMenu hMenuPopup, %MF_STRING,                %IDM_BKGND_GRAY,   "&Gray"
         AppendMenu hMenuPopup, %MF_STRING,                %IDM_BKGND_DKGRAY, "&Dark Gray"
         AppendMenu hMenuPopup, %MF_STRING,                %IDM_BKGND_BLACK,  "&Black"
      AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Background"

      hMenuPopup = CreateMenu()
         AppendMenu hMenuPopup, %MF_STRING,               %IDM_TIMER_START, "&Start"
         AppendMenu hMenuPopup, %MF_STRING OR %MF_GRAYED, %IDM_TIMER_STOP,  "S&top"
      AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Timer"

      hMenuPopup = CreateMenu()
         AppendMenu hMenuPopup, %MF_STRING, %IDM_APP_HELP,  "&Help"
         AppendMenu hMenuPopup, %MF_STRING, %IDM_APP_ABOUT, "&About MenuDemo..."
      AppendMenu hMenu, %MF_POPUP, hMenuPopup, "&Help"

   SetMenu hwnd, hMenu

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   DIM idColor(0 TO 4) AS STATIC LONG
   STATIC iSelection AS LONG
   LOCAL hMenu AS DWORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         idColor(0) = %WHITE_BRUSH
         idColor(1) = %LTGRAY_BRUSH
         idColor(2) = %GRAY_BRUSH
         idColor(3) = %DKGRAY_BRUSH
         idColor(4) = %BLACK_BRUSH
         iSelection = %IDM_BKGND_WHITE
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_COMMAND

         hMenu = GetMenu(hwnd)

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_NEW, _
                 %IDM_FILE_OPEN, _
                 %IDM_FILE_SAVE, _
                 %IDM_FILE_SAVE_AS
                 MessageBeep 0

            CASE %IDM_APP_EXIT:
                 SendMessage hwnd, %WM_CLOSE, 0, 0

            CASE %IDM_EDIT_UNDO, _
                 %IDM_EDIT_CUT, _
                 %IDM_EDIT_COPY, _
                 %IDM_EDIT_PASTE, _
                 %IDM_EDIT_CLEAR
                 MessageBeep 0

            CASE %IDM_BKGND_WHITE, _        ' // Note: Logic below
                 %IDM_BKGND_LTGRAY, _       ' //   assumes that IDM_WHITE
                 %IDM_BKGND_GRAY, _         ' //   through IDM_BLACK are
                 %IDM_BKGND_DKGRAY, _       ' //   consecutive numbers in
                 %IDM_BKGND_BLACK           ' //   the order shown here.

                 CheckMenuItem hMenu, iSelection, %MF_UNCHECKED
                 iSelection = LO(WORD, wParam)
                 CheckMenuItem hMenu, iSelection, %MF_CHECKED
                 SetClassLong hwnd, %GCL_HBRBACKGROUND, _
                     GetStockObject(idColor(LO(WORD, wParam) - %IDM_BKGND_WHITE))
                 InvalidateRect hwnd, BYVAL %NULL, %TRUE

            CASE %IDM_TIMER_START
               IF SetTimer(hwnd, %ID_TIMER, 1000, %NULL) THEN
                  EnableMenuItem hMenu, %IDM_TIMER_START, %MF_GRAYED
                  EnableMenuItem hMenu, %IDM_TIMER_STOP,  %MF_ENABLED
               END IF

            CASE %IDM_TIMER_STOP
               KillTimer hwnd, %ID_TIMER
               EnableMenuItem hMenu, %IDM_TIMER_START, %MF_ENABLED
               EnableMenuItem hMenu, %IDM_TIMER_STOP,  %MF_GRAYED

            CASE %IDM_APP_HELP
               MessageBox hwnd, "Help not yet implemented!", _
                           "MenuDemo", %MB_ICONEXCLAMATION OR %MB_OK

            CASE %IDM_APP_ABOUT
               MessageBox hwnd, "Menu Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                           "MenuDemo", %MB_ICONINFORMATION OR %MB_OK

         END SELECT
         EXIT FUNCTION

      CASE %WM_TIMER
         MessageBeep 0
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


[José Roca]

 
This program is a translation of METAFILE.C -- Metafile Demonstration Program © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.

Shows how to create a memory metafile during the %WM_CREATE message and display the image 100 times during the %WM_PAINT message.

Code: [Select]

' ========================================================================================
' METAFILE.BAS
' This program is a translation/adaptation of METAFILE.C -- Metafile Demonstration Program
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Shows how to create a memory metafile during the %WM_CREATE message and display the image
' 100 times during the %WM_PAINT message.
' ========================================================================================

#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "windows.inc"

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, _
                  BYVAL pszCmdLine AS WSTRINGZ PTR, BYVAL iCmdShow AS LONG) AS LONG

   LOCAL hwnd      AS DWORD
   LOCAL szAppName AS ASCIIZ * 256
   LOCAL wcex      AS WNDCLASSEX
   LOCAL szCaption AS ASCIIZ * 256

   szAppName          = "Metafile"
   wcex.cbSize        = SIZEOF(wcex)
   wcex.style         = %CS_HREDRAW OR %CS_VREDRAW
   wcex.lpfnWndProc   = CODEPTR(WndProc)
   wcex.cbClsExtra    = 0
   wcex.cbWndExtra    = 0
   wcex.hInstance     = hInstance
   wcex.hIcon         = LoadIcon(%NULL, BYVAL %IDI_APPLICATION)
   wcex.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
   wcex.hbrBackground = GetStockObject(%WHITE_BRUSH)
   wcex.lpszMenuName  = %NULL
   wcex.lpszClassName = VARPTR(szAppName)

   IF ISFALSE RegisterClassEx(wcex) THEN
      FUNCTION = %TRUE
      EXIT FUNCTION
   END IF

   szCaption = "Metafile Demonstration"
   hwnd = CreateWindowEx(%WS_EX_CONTROLPARENT, _   ' extended style
                         szAppName, _              ' window class name
                         szCaption, _              ' window caption
                         %WS_OVERLAPPEDWINDOW, _   ' window style
                         %CW_USEDEFAULT, _         ' initial x position
                         %CW_USEDEFAULT, _         ' initial y position
                         %CW_USEDEFAULT, _         ' initial x size
                         %CW_USEDEFAULT, _         ' initial y size
                         %NULL, _                  ' parent window handle
                         %NULL, _                  ' window menu handle
                         hInstance, _              ' program instance handle
                         BYVAL %NULL)              ' creation parameters

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   LOCAL uMsg AS tagMsg
   WHILE GetMessage(uMsg, %NULL, 0, 0)
      TranslateMessage uMsg
      DispatchMessage uMsg
   WEND

   FUNCTION = uMsg.wParam

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main dialog callback.
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG

   STATIC hmf AS DWORD
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  hBrush AS DWORD
   LOCAL  hdc AS DWORD
   LOCAL  hdcMeta AS DWORD
   LOCAL  x AS LONG
   LOCAL  y AS LONG
   LOCAL  ps  AS PAINTSTRUCT

   SELECT CASE uMsg

      CASE %WM_CREATE
         hdcMeta = CreateMetaFile(BYVAL %NULL)
         hBrush = CreateSolidBrush(RGB(0, 0, 255))
         Rectangle hdcMeta, 0, 0, 100, 100
         MoveToEx hdcMeta, 0, 0, BYVAL %NULL
         LineTo hdcMeta, 100, 100
         MoveToEx hdcMeta, 0, 100, BYVAL %NULL
         LineTo hdcMeta, 100, 0
         SelectObject hdcMeta, hBrush
         Ellipse hdcMeta, 20, 20, 80, 80
         hmf = CloseMetaFile(hdcMeta)
         DeleteObject hBrush
         EXIT FUNCTION

      CASE %WM_KEYDOWN
         SELECT CASE LO(WORD, wParam)
            CASE %VK_ESCAPE
               SendMessage hwnd, %WM_CLOSE, 0, 0
               EXIT FUNCTION
         END SELECT

      CASE %WM_SIZE
         cxClient = LO(WORD, lParam)
         cyClient = HI(WORD, lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         SetMapMode hdc, %MM_ANISOTROPIC
         SetWindowExtEx hdc, 1000, 1000, BYVAL %NULL
         SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
         FOR x = 0 TO 10
            FOR y = 0 TO 10
               SetWindowOrgEx hdc, -100 * x, -100 * y, BYVAL %NULL
               PlayMetaFile hdc, hmf
            NEXT
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         DeleteMetaFile hmf
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

   FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================