Charles Petzold's Examples

[José Roca]

 
This program is a translation of EMF11.C -- Enhanced Metafile Demo #11 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.

We've been drawing a ruler that displays inches, and we've also been dealing with dimensions in units of millimeters. Such jobs might seem like good candidates for using the various mapping modes provided under GDI. Yet I've insisted on using pixels and doing all the necessary calculations "manually." Why is that? The simple answer is that the use of mapping modes in connection with metafiles can be quite confusing. But let's try it out to see.

When you call SetMapMode using a metafile device context, the function is encoded in the metafile just like any other GDI function. This is demonstrated in the EMF11 program.

Code Select Expand


' ========================================================================================
' EMF11.BAS
' This program is a translation/adaptation of EMF11.C -- Enhanced Metafile Demo #11
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' We've been drawing a ruler that displays inches, and we've also been dealing with
' dimensions in units of millimeters. Such jobs might seem like good candidates for using
' the various mapping modes provided under GDI. Yet I've insisted on using pixels and
' doing all the necessary calculations "manually." Why is that?
' The simple answer is that the use of mapping modes in connection with metafiles can be
' quite confusing. But let's try it out to see.
' When you call SetMapMode using a metafile device context, the function is encoded in the
' metafile just like any other GDI function. This is demonstrated in the EMF11 program.
' ========================================================================================

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

%IDM_PRINT = 40001
%IDM_EXIT  = 40002
%IDM_ABOUT = 40003

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   hAccel = LoadAccelerators(hInstance, szAppName)

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)

   LOCAL i AS LONG
   LOCAL iHeight AS LONG
   LOCAL lf AS LOGFONT
   LOCAL ch AS ASCIIZ * 2

   ' Black pen with 1-point width
   SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)

   ' Rectangle surrounding entire pen (with adjustment)
   Rectangle (hdc, 0, -1, cx + 1, cy + 1)

   ' Tick marks
   FOR i = 1 TO 95
      IF i MOD 16 = 0 THEN
         iHeight = cy /  2    ' inches
      ELSEIF i MOD 8 = 0 THEN
         iHeight = cy /  3    ' half inches
      ELSEIF i MOD 4 = 0 THEN
         iHeight = cy /  5    ' quarter inches
      ELSEIF i MOD 2 = 0 THEN
         iHeight = cy /  8    ' eighths
      ELSE
         iHeight = cy / 12    ' sixteenths
      END IF
      MoveToEx hdc, i * cx / 96, 0, BYVAL %NULL
      LineTo   hdc, i * cx / 96, iHeight
   NEXT

   ' Create logical font
   lf.lfHeight = cy / 2
   lf.lfFaceName = "Times New Roman"
   SelectObject hdc, CreateFontIndirect(lf)
   SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
   SetBkMode    hdc, %TRANSPARENT

   ' Display numbers
   FOR i = 1 TO 5
      ch = FORMAT$(i)
      TextOut hdc, i * cx / 6, cy / 2, ch, 1
   NEXT

   ' Clean up
   DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
   DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))

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

' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)

   LOCAL hdcEMF AS DWORD
   LOCAL hemf   AS DWORD

   hdcEMF = CreateEnhMetaFile(%NULL, "EMF11.emf", BYVAL %NULL, "EMF11" & $NUL & "EMF Demo #11" & $NUL)
   IF hdcEMF = %NULL THEN EXIT SUB

   SetMapMode hdcEMF, %MM_LOENGLISH

   DrawRuler (hdcEMF, 600, 100)

   hemf = CloseEnhMetaFile(hdcEMF)

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL emh     AS ENHMETAHEADER
   LOCAL hemf    AS DWORD
   LOCAL cxMms   AS LONG
   LOCAL cyMms   AS LONG
   LOCAL cxPix   AS LONG
   LOCAL cyPix   AS LONG
   LOCAL cxImage AS LONG
   LOCAL cyImage AS LONG
   LOCAL rc      AS RECT

   cxMms = GetDeviceCaps(hdc, %HORZSIZE)
   cyMms = GetDeviceCaps(hdc, %VERTSIZE)
   cxPix = GetDeviceCaps(hdc, %HORZRES)
   cyPix = GetDeviceCaps(hdc, %VERTRES)

   hemf = GetEnhMetaFile("EMF11.emf")

   GetEnhMetaFileHeader hemf, SIZEOF(emh), emh

   cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
   cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop

   cxImage = cxImage * cxPix / cxMms / 100
   cyImage = cyImage * cyPix / cyMms / 100

   rc.nLeft   = (cxArea - cxImage) / 2
   rc.nTop    = (cyArea - cyImage) / 2
   rc.nRight  = (cxArea + cxImage) / 2
   rc.nBottom = (cyArea + cyImage) / 2

   PlayEnhMetaFile hdc, hemf, rc

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG

   STATIC szMessage AS ASCIIZ * 32
   LOCAL  bSuccess AS LONG
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG

   STATIC dinfo AS DOCINFO
   LOCAL  szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
   nCopies = 1 : nFromPage = 1 : nToPage = 1
   IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
   IF hdcPrn = %NULL THEN EXIT FUNCTION

   cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
   cyPage = GetDeviceCaps(hdcPrn, %VERTRES)

   szMessage = "EMF11: Printing"
   dinfo.cbSize = SIZEOF(DOCINFO)
   dinfo.lpszDocName = VARPTR(szMessage)

   IF StartDoc(hdcPrn, dinfo) > 0 THEN
      IF StartPage(hdcPrn) > 0 THEN
         PaintRoutine hwnd, hdcPrn, cxPage, cyPage
         IF EndPage(hdcPrn) > 0 THEN
            bSuccess = %TRUE
            EndDoc hdcPrn
         END IF
      END IF
   END IF

   DeleteDC hdcPrn

   FUNCTION = bSuccess

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

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

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

   SELECT CASE uMsg

      CASE %WM_CREATE
         CreateRoutine hwnd
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LOWRD(wParam)

            CASE %IDM_PRINT
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               bSuccess = PrintRoutine(hwnd)
               ShowCursor %FALSE
               SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
               IF ISFALSE bSuccess THEN
                  MessageBox hwnd, "Error encountered during printing", "EMF11", %MB_OK OR %MB_TASKMODAL
               END IF

            CASE %IDM_EXIT
               SendMessage hwnd, %WM_CLOSE, 0, 0

            CASE %IDM_ABOUT
               MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
                          "(c) Charles Petzold, 1998", "EMF11", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL

         END SELECT
         EXIT FUNCTION

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint(hwnd, ps)
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of EMF12.C -- Enhanced Metafile Demo #12 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.

Calculating the destination rectangle in EMF11 involves some calls to GetDeviceCaps. Our second goal is to eliminate those and use a mapping mode instead. GDI treats the coordinates of the destination rectangle as logical coordinates. Using the %MM_HIMETRIC mode seems like a good candidate for these coordinates, because that makes logical units 0.01 millimeters, the same units used for the bounding rectangle in the enhanced metafile header.

The EMF12 program restores the DrawRuler logic as originally presented in EMF8 but uses the %MM_HIMETRIC mapping mode to display the metafile.

Code Select Expand


' ========================================================================================
' EMF12.BAS
' This program is a translation/adaptation of EMF12.C -- Enhanced Metafile Demo #12
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Calculating the destination rectangle in EMF11 involves some calls to GetDeviceCaps. Our
' second goal is to eliminate those and use a mapping mode instead. GDI treats the
' coordinates of the destination rectangle as logical coordinates. Using the %MM_HIMETRIC
' mode seems like a good candidate for these coordinates, because that makes logical units
' 0.01 millimeters, the same units used for the bounding rectangle in the enhanced
' metafile header.
' The EMF12 program restores the DrawRuler logic as originally presented in EMF8 but uses
' the %MM_HIMETRIC mapping mode to display the metafile.
' ========================================================================================

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

%IDM_PRINT = 40001
%IDM_EXIT  = 40002
%IDM_ABOUT = 40003

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   hAccel = LoadAccelerators(hInstance, szAppName)

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)

   LOCAL i AS LONG
   LOCAL iHeight AS LONG
   LOCAL lf AS LOGFONT
   LOCAL ch AS ASCIIZ * 2

   ' Black pen with 1-point width
   SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)

   ' Rectangle surrounding entire pen (with adjustment)
   Rectangle (hdc, 0, 0, cx + 1, cy + 1)

   ' Tick marks
   FOR i = 1 TO 95
      IF i MOD 16 = 0 THEN
         iHeight = cy /  2    ' inches
      ELSEIF i MOD 8 = 0 THEN
         iHeight = cy /  3    ' half inches
      ELSEIF i MOD 4 = 0 THEN
         iHeight = cy /  5    ' quarter inches
      ELSEIF i MOD 2 = 0 THEN
         iHeight = cy /  8    ' eighths
      ELSE
         iHeight = cy / 12    ' sixteenths
      END IF
      MoveToEx hdc, i * cx / 96, cy, BYVAL %NULL
      LineTo   hdc, i * cx / 96, cy - iHeight
   NEXT

   ' Create logical font
   lf.lfHeight = cy / 2
   lf.lfFaceName = "Times New Roman"
   SelectObject hdc, CreateFontIndirect(lf)
   SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
   SetBkMode    hdc, %TRANSPARENT

   ' Display numbers
   FOR i = 1 TO 5
      ch = FORMAT$(i)
      TextOut hdc, i * cx / 6, cy / 2, ch, 1
   NEXT

   ' Clean up
   DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
   DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))

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

' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)

   LOCAL hdcEMF AS DWORD
   LOCAL hemf   AS DWORD
   LOCAL cxMms  AS LONG
   LOCAL cyMms  AS LONG
   LOCAL cxPix  AS LONG
   LOCAL cyPix  AS LONG
   LOCAL xDpi   AS LONG
   LOCAL yDpi   AS LONG

   hdcEMF = CreateEnhMetaFile(%NULL, "EMF12.emf", BYVAL %NULL, "EMF12" & $NUL & "EMF Demo #12" & $NUL)
   IF hdcEMF = %NULL THEN EXIT SUB

   cxMms = GetDeviceCaps(hdcEMF, %HORZSIZE)
   cyMms = GetDeviceCaps(hdcEMF, %VERTSIZE)
   cxPix = GetDeviceCaps(hdcEMF, %HORZRES)
   cyPix = GetDeviceCaps(hdcEMF, %VERTRES)

   xDpi = cxPix * 254 / cxMms / 10
   yDpi = cyPix * 254 / cyMms / 10

   DrawRuler (hdcEMF, 6 * xDpi, yDpi)

   hemf = CloseEnhMetaFile(hdcEMF)

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL emh     AS ENHMETAHEADER
   LOCAL hemf    AS DWORD
   LOCAL pt      AS POINTAPI
   LOCAL cxImage AS LONG
   LOCAL cyImage AS LONG
   LOCAL rc      AS RECT

   SetMapMode hdc, %MM_HIMETRIC

   SetViewportOrgEx hdc, 0, cyArea, BYVAL %NULL

   pt.x = cxArea
   pt.y = 0

   DPtoLP hdc, pt, 1

   hemf = GetEnhMetaFile("EMF12.emf")

   GetEnhMetaFileHeader hemf, SIZEOF(emh), emh

   cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
   cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop

   rc.nLeft   = (pt.x - cxImage) / 2
   rc.nTop    = (pt.y + cyImage) / 2
   rc.nRight  = (pt.x + cxImage) / 2
   rc.nBottom = (pt.y - cyImage) / 2

   PlayEnhMetaFile hdc, hemf, rc

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG

   STATIC szMessage AS ASCIIZ * 32
   LOCAL  bSuccess AS LONG
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG

   STATIC dinfo AS DOCINFO
   LOCAL  szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
   nCopies = 1 : nFromPage = 1 : nToPage = 1
   IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
   IF hdcPrn = %NULL THEN EXIT FUNCTION

   cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
   cyPage = GetDeviceCaps(hdcPrn, %VERTRES)

   szMessage = "EMF12: Printing"
   dinfo.cbSize = SIZEOF(DOCINFO)
   dinfo.lpszDocName = VARPTR(szMessage)

   IF StartDoc(hdcPrn, dinfo) > 0 THEN
      IF StartPage(hdcPrn) > 0 THEN
         PaintRoutine hwnd, hdcPrn, cxPage, cyPage
         IF EndPage(hdcPrn) > 0 THEN
            bSuccess = %TRUE
            EndDoc hdcPrn
         END IF
      END IF
   END IF

   DeleteDC hdcPrn

   FUNCTION = bSuccess

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

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

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

   SELECT CASE uMsg

      CASE %WM_CREATE
         CreateRoutine hwnd
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               bSuccess = PrintRoutine(hwnd)
               ShowCursor %FALSE
               SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
               IF ISFALSE bSuccess THEN
                  MessageBox hwnd, "Error encountered during printing", "EMF12", %MB_OK OR %MB_TASKMODAL
               END IF

            CASE %IDM_EXIT
               SendMessage hwnd, %WM_CLOSE, 0, 0

            CASE %IDM_ABOUT
               MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
                          "(c) Charles Petzold, 1998", "EMF12", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL

         END SELECT
         EXIT FUNCTION

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint(hwnd, ps)
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of EMF13.C -- Enhanced Metafile Demo #13 © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.

Now we've seen how we can use a mapping mode when creating the metafile and also for displaying it. Can we do both?

It turns out that it works, as EMF13 demonstrates.

Code Select Expand


' ========================================================================================
' EMF13.BAS
' This program is a translation/adaptation of EMF13.C -- Enhanced Metafile Demo #13
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Now we've seen how we can use a mapping mode when creating the metafile and also for
' displaying it. Can we do both?
' It turns out that it works, as EMF13 demonstrates.
' ========================================================================================

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

%IDM_PRINT = 40001
%IDM_EXIT  = 40002
%IDM_ABOUT = 40003

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   hAccel = LoadAccelerators(hInstance, szAppName)

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Draws a ruler
' ========================================================================================
SUB DrawRuler (BYVAL hdc AS DWORD, BYVAL cx AS LONG, BYVAL cy AS LONG)

   LOCAL i AS LONG
   LOCAL iHeight AS LONG
   LOCAL lf AS LOGFONT
   LOCAL ch AS ASCIIZ * 2

   ' Black pen with 1-point width
   SelectObject hdc, CreatePen (%PS_SOLID, cx / 72 / 6, 0)

   ' Rectangle surrounding entire pen (with adjustment)
   Rectangle (hdc, 0, -1, cx + 1, cy + 1)

   ' Tick marks
   FOR i = 1 TO 95
      IF i MOD 16 = 0 THEN
         iHeight = cy /  2    ' inches
      ELSEIF i MOD 8 = 0 THEN
         iHeight = cy /  3    ' half inches
      ELSEIF i MOD 4 = 0 THEN
         iHeight = cy /  5    ' quarter inches
      ELSEIF i MOD 2 = 0 THEN
         iHeight = cy /  8    ' eighths
      ELSE
         iHeight = cy / 12    ' sixteenths
      END IF
      MoveToEx hdc, i * cx / 96, 0, BYVAL %NULL
      LineTo   hdc, i * cx / 96, iHeight
   NEXT

   ' Create logical font
   lf.lfHeight = cy / 2
   lf.lfFaceName = "Times New Roman"
   SelectObject hdc, CreateFontIndirect(lf)
   SetTextAlign hdc, %TA_BOTTOM OR %TA_CENTER
   SetBkMode    hdc, %TRANSPARENT

   ' Display numbers
   FOR i = 1 TO 5
      ch = FORMAT$(i)
      TextOut hdc, i * cx / 6, cy / 2, ch, 1
   NEXT

   ' Clean up
   DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
   DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))

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

' ========================================================================================
' Create enhanced metafile
' ========================================================================================
SUB CreateRoutine (BYVAL hwnd AS DWORD)

   LOCAL hdcEMF AS DWORD
   LOCAL hemf   AS DWORD

   hdcEMF = CreateEnhMetaFile(%NULL, "EMF13.emf", BYVAL %NULL, "EMF13" & $NUL & "EMF Demo #13" & $NUL)
   IF hdcEMF = %NULL THEN EXIT SUB

   SetMapMode hdcEMF, %MM_LOENGLISH

   DrawRuler (hdcEMF, 600, 100)

   hemf = CloseEnhMetaFile(hdcEMF)

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Displays the enhanced metafile
' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL emh     AS ENHMETAHEADER
   LOCAL hemf    AS DWORD
   LOCAL pt      AS POINTAPI
   LOCAL cxImage AS LONG
   LOCAL cyImage AS LONG
   LOCAL rc      AS RECT

   SetMapMode hdc, %MM_HIMETRIC

   SetViewportOrgEx hdc, 0, cyArea, BYVAL %NULL

   pt.x = cxArea
   pt.y = 0

   DPtoLP hdc, pt, 1

   hemf = GetEnhMetaFile("EMF13.emf")

   GetEnhMetaFileHeader hemf, SIZEOF(emh), emh

   cxImage = emh.rclFrame.nRight - emh.rclFrame.nLeft
   cyImage = emh.rclFrame.nBottom - emh.rclFrame.nTop

   rc.nLeft   = (pt.x - cxImage) / 2
   rc.nTop    = (pt.y + cyImage) / 2
   rc.nRight  = (pt.x + cxImage) / 2
   rc.nBottom = (pt.y - cyImage) / 2

   PlayEnhMetaFile hdc, hemf, rc

   DeleteEnhMetaFile hemf

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

' ========================================================================================
' Prints the enhanced metafile
' ========================================================================================
FUNCTION PrintRoutine (BYVAL hwnd AS DWORD) AS LONG

   STATIC szMessage AS ASCIIZ * 32
   LOCAL  bSuccess AS LONG
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG

   STATIC dinfo AS DOCINFO
   LOCAL  szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
   nCopies = 1 : nFromPage = 1 : nToPage = 1
   IF ISFALSE PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN EXIT FUNCTION
   IF hdcPrn = %NULL THEN EXIT FUNCTION

   cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
   cyPage = GetDeviceCaps(hdcPrn, %VERTRES)

   szMessage = "EMF13: Printing"
   dinfo.cbSize = SIZEOF(DOCINFO)
   dinfo.lpszDocName = VARPTR(szMessage)

   IF StartDoc(hdcPrn, dinfo) > 0 THEN
      IF StartPage(hdcPrn) > 0 THEN
         PaintRoutine hwnd, hdcPrn, cxPage, cyPage
         IF EndPage(hdcPrn) > 0 THEN
            bSuccess = %TRUE
            EndDoc hdcPrn
         END IF
      END IF
   END IF

   DeleteDC hdcPrn

   FUNCTION = bSuccess

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

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

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

   SELECT CASE uMsg

      CASE %WM_CREATE
         CreateRoutine hwnd
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               bSuccess = PrintRoutine(hwnd)
               ShowCursor %FALSE
               SetCursor LoadCursor (%NULL, BYVAL %IDC_ARROW)
               IF ISFALSE bSuccess THEN
                  MessageBox hwnd, "Error encountered during printing", "EMF13", %MB_OK OR %MB_TASKMODAL
               END IF

            CASE %IDM_EXIT
               SendMessage hwnd, %WM_CLOSE, 0, 0

            CASE %IDM_ABOUT
               MessageBox hwnd, "Enhanced Metafile Demo Program" & $LF & _
                          "(c) Charles Petzold, 1998", "EMF13", %MB_OK OR %MB_ICONINFORMATION OR %MB_TASKMODAL

         END SELECT
         EXIT FUNCTION

      CASE %WM_SIZE
         cxClient = LOWRD(lParam)
         cyClient = HIWRD(lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint(hwnd, ps)
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of EMFVIEW.C -- View Enhanced Metafiles © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming Windows, 5th Edition.

Demonstrates how to transfer metafiles to and from the clipboard, and it also allows loading metafiles, saving metafiles, and printing them.

Code Select Expand


' ========================================================================================
' EMFVIEW.BAS
' This program is a translation/adaptation of EMFVIEW.C -- View Enhanced Metafiles
' © Charles Petzold, 1998, described and analysed in Chapter 18 of the book Programming
' Windows, 5th Edition.
' Demonstrates how to transfer metafiles to and from the clipboard, and it also allows
' loading metafiles, saving metafiles, and printing them.
' ========================================================================================

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

%IDM_FILE_OPEN       = 40001
%IDM_FILE_SAVE_AS    = 40002
%IDM_FILE_PRINT      = 40003
%IDM_FILE_PROPERTIES = 40004
%IDM_APP_EXIT        = 40005
%IDM_EDIT_CUT        = 40006
%IDM_EDIT_COPY       = 40007
%IDM_EDIT_PASTE      = 40008
%IDM_EDIT_DELETE     = 40009
%IDM_APP_ABOUT       = 40010

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

   hAccel = LoadAccelerators(hInstance, szAppName)

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
' Creates palette from metafile
' ========================================================================================
FUNCTION CreatePaletteFromMetaFile (hemf AS DWORD) AS DWORD

   LOCAL hPalette AS DWORD
   LOCAL iNum     AS LONG
   LOCAL plp      AS LOGPALETTE PTR

   IF hemf = %NULL THEN EXIT FUNCTION
   iNum = GetEnhMetaFilePaletteEntries(hemf, 0, BYVAL %NULL)
   IF iNum = 0 THEN EXIT FUNCTION
   plp = CoTaskMemAlloc(SIZEOF(LOGPALETTE) + (iNum - 1) * SIZEOF(PALETTEENTRY))
   @plp.palVersion = &H0300
   @plp.palNumEntries = iNum
   GetEnhMetaFilePaletteEntries hEmf, iNum , @plp.palPalEntry(0)
   hPalette = CreatePalette(BYVAL plp)
   CoTaskMemFree plp
   FUNCTION = hPalette

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

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

   STATIC hemf AS DWORD
   LOCAL  bSuccess AS LONG
   LOCAL  emheader AS ENHMETAHEADER
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  hemfCopy AS DWORD
   LOCAL  hMenu AS DWORD
   LOCAL  hPalette AS DWORD
   LOCAL  i AS LONG
   LOCAL  iLEngth AS LONG
   LOCAL  iEnable AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  rc AS RECT
   LOCAL  pBuffer AS ASCIIZ PTR
   LOCAL  strDesc AS STRING

   STATIC strPath AS STRING
   STATIC fOptions AS STRING
   STATIC dwStyle AS DWORD
   STATIC strFileSpec AS STRING

   STATIC dinfo AS DOCINFO
   LOCAL  szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         ' Initialize variables to default values
         strPath  = CURDIR$
         fOptions = "Enhanced Metafiles (*.EMF)|*.emf|"
         fOptions = fOptions & "All Files (*.*)|*.*"
         strFileSpec = "*.EMF"
         FUNCTION = 0
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_FILE_OPEN

               ' Call the OpenFileDialog wrapper function (included in COMDLG32.INC)
               dwStyle  = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST
               IF ISFALSE OpenFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "EMF", dwStyle) THEN EXIT FUNCTION
               ' If there is an existing EMF, get rid of it
               IF hemf THEN
                  DeleteEnhMetaFile hemf
                  hemf = %NULL
               END IF
               ' Load the EMF into memory
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               hemf = GetEnhMetaFile(BYCOPY strFileSpec)
               ' Invalidate the client area for later update
               ShowCursor %FALSE
               SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
               InvalidateRect hwnd, BYVAL %NULL, %TRUE
               IF hemf = %NULL THEN
                  MessageBox hwnd, "Cannot load metafile", "EmfView", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
                  EXIT FUNCTION
               END IF

            CASE %IDM_FILE_SAVE_AS
               IF ISFALSE hemf THEN EXIT FUNCTION
               ' Call the SaveFileDialog wrapper function (included in COMDLG32.INC)
               dwStyle = %OFN_EXPLORER OR %OFN_FILEMUSTEXIST OR %OFN_HIDEREADONLY OR %OFN_OVERWRITEPROMPT
               IF ISFALSE(SaveFileDialog(hwnd, "", strFileSpec, strPath, fOptions, "EMF", dwStyle)) THEN EXIT FUNCTION
               ' Save the DIB to memory
               SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
               ShowCursor %TRUE
               hemfCopy = CopyEnhMetaFile(hemf, BYCOPY strFileSpec)
               ShowCursor %FALSE
               SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
               IF hemfCopy THEN
                  DeleteEnhMetaFile hemf
                  hemf = hemfCopy
               ELSE
                  MessageBox hwnd, "Cannot save metafile", "EmfView", %MB_OK OR %MB_ICONERROR OR %MB_TASKMODAL
                  EXIT FUNCTION
               END IF

            CASE %IDM_FILE_PRINT
               IF hemf = %NULL THEN EXIT FUNCTION
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     rc.nLeft = 0
                     rc.nRight = GetDeviceCaps(hdcPrn, %HORZRES)
                     rc.nTop = 0
                     rc.nBottom = GetDeviceCaps(hdcPrn, %VERTRES)
                     bSuccess = %FALSE
                     ' Play the EMF to the printer
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     szDocName = "EmfView: Printing"
                     dinfo.cbSize = SIZEOF(DOCINFO)
                     dinfo.lpszDocName = VARPTR(szDocName)
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PlayEnhMetaFile hdcPrn, hemf, rc
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Could not print metafile", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  END IF
               END IF

            CASE %IDM_FILE_PROPERTIES
               IF ISFALSE hemf THEN EXIT FUNCTION
               iLength = GetEnhMetaFileDescription (hemf, 0, BYVAL %NULL)
               pBuffer = CoTaskMemALloc (iLength + 256)
               GetEnhMetaFileHeader hemf, SIZEOF(ENHMETAHEADER), emheader
               ' Format header file information
               i = wsprintf(BYVAL pBuffer, "Bounds = (%i, %i) to (%i, %i) pixels" & $LF, _
                            BYVAL emheader.rclBounds.nLeft, BYVAL emheader.rclBounds.nTop, _
                            BYVAL emheader.rclBounds.nRight, BYVAL emheader.rclBounds.nBottom)
               i = wsprintf(BYVAL pBuffer + i, "Frame = (%i, %i) to (%i, %i) mms" & $LF, _
                            BYVAL emheader.rclFrame.nLeft, BYVAL emheader.rclBounds.nTop, _
                            BYVAL emheader.rclBounds.nRight, BYVAL emheader.rclBounds.nBottom) + i
               i = wsprintf(BYVAL pBuffer + i, "Resolution = (%i, %i) pixels = (%i, %i) mms" & $LF, _
                            BYVAL emheader.szlDevice.cx, BYVAL emheader.szlDevice.cy, _
                            BYVAL emheader.szlMillimeters.cx, _
                            BYVAL emheader.szlMillimeters.cy) + i
               i = wsprintf(BYVAL pBuffer + i, "Size = %i, Records = %i, Handles = %i, Palette entries = %i" & $LF, _
                            BYVAL emheader.nBytes, BYVAL emheader.nRecords, _
                            BYVAL emheader.nHandles, BYVAL emheader.nPalEntries) + i
               ' Include the metafile description, if present
               IF iLength THEN
                  strDesc = SPACE$(iLength)
                  GetEnhMetaFileDescription (hemf, iLength, BYVAL STRPTR(strDesc))
                  i = wsprintf(BYVAL pBuffer + i, "Description = %s", BYVAL STRPTR(strDesc)) + i
               END IF
               MessageBox hwnd, BYVAL pBuffer, "Metafile Properties", %MB_OK OR %MB_TASKMODAL
               CoTaskMemFree pBuffer

            CASE %IDM_EDIT_COPY, %IDM_EDIT_CUT
               IF hemf = %NULL THEN EXIT FUNCTION
               ' Transfer metafile copy to the clipboard
               hemfCopy = CopyEnhMetaFile (hemf, BYVAl %NULL)
               OpenClipboard hwnd
               EmptyClipboard
               SetClipboardData %CF_ENHMETAFILE, hemfCopy
               CloseClipboard
               IF LO(WORD, wParam) = %IDM_EDIT_CUT THEN
                  DeleteEnhMetaFile hemf
                  hemf = %NULL
                  InvalidateRect hwnd, BYVAL %NULL, %TRUE
               END IF

            CASE %IDM_EDIT_DELETE
               IF hemf THEN
                  DeleteEnhMetaFile hemf
                  hemf = %NULL
                  InvalidateRect hwnd, BYVAL %NULL, %TRUE
               END IF

            CASE %IDM_EDIT_PASTE
               OpenClipboard hwnd
               hemfCopy = GetClipboardData(%CF_ENHMETAFILE)
               CloseClipboard
               IF ISTRUE hemfCopy AND ISTRUE hemf THEN
                  DeleteEnhMetaFile hemf
                  hemf = %NULL
               END IF
               hemf = CopyEnhMetaFile(hemfCopy, BYVAL %NULL)
               InvalidateRect hwnd, BYVAL %NULL, %TRUE

            CASE %IDM_APP_ABOUT
               MessageBox hwnd, "Enhanced Metafile Viewer" & $LF & _
                          "(c) Charles Petzold, 1998", "EmfView", %MB_OK OR %MB_TASKMODAL

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

         END SELECT
         EXIT FUNCTION

      CASE %WM_INITMENUPOPUP
         ' Enable or disable menu options
         hMenu = GetMenu(hwnd)
         IF hemf <> %NULL THEN
            iEnable = %MF_ENABLED
         ELSE
            iEnable = %MF_GRAYED
         END IF
         EnableMenuItem hMenu, %IDM_FILE_SAVE_AS, iEnable
         EnableMenuItem hMenu, %IDM_FILE_PRINT, iEnable
         EnableMenuItem hMenu, %IDM_FILE_PROPERTIES, iEnable
         EnableMenuItem hMenu, %IDM_EDIT_CUT, iEnable
         EnableMenuItem hMenu, %IDM_EDIT_COPY, iEnable
         EnableMenuItem hMenu, %IDM_EDIT_DELETE, iEnable
         IF IsClipboardFormatAvailable(%CF_ENHMETAFILE) THEN
            EnableMenuItem hMenu, %IDM_EDIT_DELETE, %MF_ENABLED
         ELSE
            EnableMenuItem hMenu, %IDM_EDIT_DELETE, %MF_GRAYED
         END IF
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         IF hemf THEN
            hPalette = CreatePaletteFromMetafile(hemf)
            IF hPalette THEN
               SelectPalette hdc, hPalette, %FALSE
               RealizePalette hdc
            END IF
            GetClientRect hwnd, rc
            PlayEnhMetaFile hdc, hemf, rc
            IF hPalette THEN DeleteObject hPalette
         END IF
         EndPaint(hwnd, ps)
         EXIT FUNCTION

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

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

     CASE %WM_DESTROY
        ' Free the allocated memory and end the program
         IF hemf THEN DeleteEnhMetaFile hemf
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of ENDJOIN.C -- Ends and Joins Demo © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

The program draws three V-shaped wide lines using the end and join styles in the order listed above. The program also draws three identical lines using the stock black pen. This shows how the wide line compares with the normal thin line.

Code Select Expand


' ========================================================================================
' ENDJOIN.BAS
' This program is a translation/adaptation of ENDJOIN.C -- Ends and Joins Demo
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The program draws three V-shaped wide lines using the end and join styles in the order
' listed above. The program also draws three identical lines using the stock black pen.
' This shows how the wide line compares with the normal thin line.
' ========================================================================================

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   DIM iEnd(0 TO 2) AS STATIC LONG
   ARRAY ASSIGN iEnd() = %PS_ENDCAP_ROUND, %PS_ENDCAP_SQUARE, %PS_ENDCAP_FLAT
   DIM iJoin(0 TO 2) AS STATIC LONG
   ARRAY ASSIGN iJoin() = %PS_JOIN_ROUND, %PS_JOIN_BEVEL, %PS_JOIN_MITER

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

   SELECT CASE uMsg

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

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         SetMapMode hdc, %MM_ANISOTROPIC
         SetWindowExtEx hdc, 100, 100, BYVAL %NULL
         SetViewportExtEx hdc, cxClient, cyClient, BYVAL %NULL
         lb.lbStyle = %BS_SOLID
         lb.lbColor = RGB(128, 128, 128)
         lb.lbHatch = 0
         FOR i = 0 TO 2
            SelectObject hdc, ExtCreatePen (%PS_SOLID OR %PS_GEOMETRIC OR _
                         iEnd(i) OR iJoin(i), 10, lb, 0, BYVAL %NULL)
            BeginPath hdc
            MoveToEx hdc, 10 + 30 * i, 25, BYVAl %NULL
            LineTo hdc, 20 + 30 * i, 75
            LineTo hdc, 30 + 30 * i, 25
            EndPath hdc
            StrokePath hdc
            DeleteObject SelectObject (hdc, GetStockObject(%BLACK_PEN))
            MoveToEx hdc, 10 + 30 * i, 25, BYVAl %NULL
            LineTo hdc, 20 + 30 * i, 75
            LineTo hdc, 30 + 30 * i, 25
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of ENVIRON.C -- Environment List Box © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming Windows, 5th Edition.

The ENVIRON program uses a list box in its client area to display the name of your current operating system environment variables (such as PATH and WINDIR). As you select an environment variable, the environment string is displayed across the top of the client area.

Code Select Expand


' ========================================================================================
' ENVIRON.BAS
' This program is a translation/adaptation of ENVIRON.C -- Environment List Box
' © Charles Petzold, 1998, described and analysed in Chapter 9 of the book Programming
' Windows, 5th Edition.
' The ENVIRON program uses a list box in its client area to display the name of your
' current operating system environment variables (such as PATH and WINDIR). As you select
' an environment variable, the environment string is displayed across the top of the
' client area.
' ========================================================================================

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

%ID_LIST = 1
%ID_TEXT = 2

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
SUB FillListBox (BYVAL hwndList AS DWORD)

   LOCAL pVarBlock AS ASCIIZ PTR
   LOCAL strVarName AS STRING
   LOCAL p AS LONG

   ' Get pointer to environment block
   pVarBlock = GetEnvironmentStrings()
   IF pVarBlock = %NULL THEN EXIT SUB

   DO
      strVarName = @pVarBlock
      IF LEN(strVarName) = 0 THEN  EXIT DO
      pVarBlock = pVarBlock + LEN(strVarName) + 1
      ' Skip variable names beginning with "="
      IF LEFT$(strVarName, 1) <> "=" THEN
         ' Extract the environment variable name
         p = INSTR(strVarName, "=")
         IF p THEN strVarName = LEFT$(strVarName, p - 1)
         ' Show the variable name in the listbox
         SendMessage hwndList, %LB_ADDSTRING, 0, STRPTR(strVarName)
      END IF
   LOOP

   ' Frees the block of environment strings
   FreeEnvironmentStrings BYVAL pVarBlock

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

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

   STATIC hwndList  AS DWORD
   STATIC hwndText  AS DWORD
   LOCAL  iIndex    AS LONG
   LOCAL  iLength   AS LONG
   LOCAL  cxChar    AS LONG
   LOCAL  cyChar    AS LONG
   LOCAL  pVarName  AS ASCIIZ PTR
   LOCAL  pVarValue AS ASCIIZ PTR

   SELECT CASE uMsg

      CASE %WM_CREATE

         cxChar = LO(WORD, GetDialogBaseUnits())
         cyChar = HI(WORD, GetDialogBaseUnits())

         ' Create listbox and static text windows.

         hwndList = CreateWindowEx(0, "Listbox", BYVAL %NULL, _
                           %WS_CHILD OR %WS_VISIBLE OR %LBS_STANDARD, _
                           cxChar, cyChar * 3, _
                           cxChar * 30 + GetSystemMetrics(%SM_CXVSCROLL), _
                           cyChar * 15, _
                           hwnd, %ID_LIST, _
                           GetWindowLong (hwnd, %GWL_HINSTANCE), _
                           BYVAL %NULL)

         hwndText = CreateWindowEx(0, "Static", BYVAL %NULL, _
                           %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT, _
                           cxChar, cyChar, _
                           GetSystemMetrics(%SM_CXSCREEN), cyChar, _
                           hwnd, %ID_TEXT, _
                           GetWindowLong(hwnd, %GWL_HINSTANCE), _
                           BYVAL %NULL)

         FillListBox hwndList
         EXIT FUNCTION

      CASE %WM_SETFOCUS
         SetFocus hwndList
         EXIT FUNCTION

      CASE %WM_COMMAND
         IF LO(WORD, wParam) = %ID_LIST AND HI(WORD, wParam) = %LBN_SELCHANGE THEN
            ' Get current selection
            iIndex  = SendMessage(hwndList, %LB_GETCURSEL, 0, 0)
            iLength = SendMessage(hwndList, %LB_GETTEXTLEN, iIndex, 0) + 1
            pVarName = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, iLength)
            SendMessage hwndList, %LB_GETTEXT, iIndex, pVarName
            ' Get environment string
            iLength = GetEnvironmentVariable(@pVarName, BYVAL %NULL, 0)
            pVarValue = HeapAlloc(GetProcessHeap, %HEAP_ZERO_MEMORY, iLength)
            GetEnvironmentVariable @pVarName, BYVAL pVarValue, iLength
            ' Show it in window
            SetWindowText hwndText, @pVarValue
            HeapFree GetProcessHeap, 0, BYVAL pVarName
            HeapFree GetProcessHeap, 0, BYVAL pVarValue
         END IF
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of FONTCLIP.C -- Using Path for Clipping on Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

You can use a path, and hence a TrueType font, to define a clipping region.

Code Select Expand


' ========================================================================================
' FONTCLIP.BAS
' This program is a translation/adaptation of FONTCLIP.C -- Using Path for Clipping on Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' You can use a path, and hence a TrueType font, to define a clipping region.
' ========================================================================================

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

$szAppName = "FontClip"
$szTitle   = "FontClip: Using Path for Clipping on Font"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINT
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL szString AS ASCIIZ * 256
   LOCAL hFont AS DWORD
   LOCAL y AS LONG
   LOCAL iOffset AS LONG
   LOCAL tsize AS SIZE
   DIM   pt(3) AS POINT

   szString = "Clipping"
   hFont = EzCreateFont(hdc, "Times New Roman", 1200, 0, 0, %TRUE)
   SelectObject hdc, hFont
   GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
   BeginPath hdc
   TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
   EndPath hdc
   ' Set clipping area
   SelectClipPath hdc, %RGN_COPY
   ' Draw Bezier splines
   iOffset = (cxArea + cyArea) \ 4

   FOR y = -iOffset TO cyArea + iOffset - 1
      pt(0).x = 0
      pt(0).y = y
      pt(1).x = cxArea / 3
      pt(1).y = y + iOffset
      pt(2).x = 2 * cxArea \ 3
      pt(2).y = y - iOffset
      pt(3).x = cxArea
      pt(3).y = y
      SelectObject hdc, CreatePen (%PS_SOLID, 1, RGB(RND * 256, RND * 256, RND * 256))
      PolyBezier hdc, pt(0), 4
      DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
   NEXT

   DeleteObject SelectObject(hdc, GetStockObject(%WHITE_BRUSH))
   SelectObject hdc, GetStockObject(%SYSTEM_FONT)
   DeleteObject hFont

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "FontClip: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

     CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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



FONTDEMO.RC

Code Select Expand


#define IDM_PRINT                       40001
#define IDM_ABOUT                       40002

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

FONTDEMO MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print...",                   IDM_PRINT
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&About...",                   IDM_ABOUT
    END
END


[José Roca]

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

Code Select Expand


' ========================================================================================
' FONTDEMO.BAS
' This program is a translation/adaptation of FONTDEMO.C -- Font Demonstration Shell
' Program © Charles Petzold, 1998, described and analysed in Chapter 17 of the book
' Programming Windows, 5th Edition.
' ========================================================================================

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

$szAppName = "FontDemo"
$szTitle   = "FontDemo: Font Demonstration Shell Program"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINTAPI
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL hFont AS DWORD
   LOCAL y AS LONG
   LOCAL iPointSize AS LONG
   LOCAL lf AS LOGFONT
   LOCAL szBuffer AS ASCIIZ * 100
   LOCAL tm AS TEXTMETRIC
   LOCAL szFormat AS ASCIIZ * 256

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

   ' Try some fonts
   y = 0

   FOR iPointSize = 80 TO 120
      hFont = EzCreateFont(hdc, "Times New Roman", iPointSize, 0, 0, %TRUE)
      GetObject hFont, SIZEOF(LOGFONT), lf
      SelectObject hdc, hFont
      GetTextMetrics hdc, tm
      szFormat = "lf.lfHeight = %i, tm.tmHeight = %i"
      wsprintf szBuffer, "Times New Roman font of %i.%i points, ", _
                         szFormat, _
                         BYVAL iPointSize \ 10, BYVAL iPointSize MOD 10, _
                         BYVAL lf.lfHeight, BYVAL tm.tmHeight
      TextOut hdc, 0, y, szBuffer, LEN(szBuffer)
      DeleteObject SelectObject(hdc, GetStockObject(%SYSTEM_FONT))
      y = y + tm.tmHeight
   NEXT

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "Font Demo: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

     CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

      CASE %WM_SIZE
         cxClient = LOWRD(lParam)
         cyClient = HIWRD(lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of FONTFILL.C -- Using Path to Fill Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

You can also use paths to define areas for filling. You create the path in the same way as shown in the past two programs, select a filling pattern, and call FillPath. Another function you can call is StrokeAndFillPath, which both outlines a path and fills it with one function call.

Code Select Expand


' ========================================================================================
' FONTFILL.BAS
' This program is a translation/adaptation of FONTFILL.C -- Using Path to Fill Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' You can also use paths to define areas for filling. You create the path in the same way
' as shown in the past two programs, select a filling pattern, and call FillPath. Another
' function you can call is StrokeAndFillPath, which both outlines a path and fills it with
' one function call.
' ========================================================================================

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

$szAppName = "FontFill"
$szTitle   = "FontFill: Using Path to Fill Font"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINTAPI
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL  hFont AS DWORD
   STATIC szString AS ASCIIZ * 256
   LOCAL  tsize AS APISIZE

   szString = "Filling"
   hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
   SelectObject hdc, hFont
   SetBkMode hdc, %TRANSPARENT
   GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
   BeginPath hdc
   TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
   EndPath hdc
   SelectObject hdc, CreateHatchBrush(%HS_DIAGCROSS, RGB(255, 0, 0))
   SetBkColor hdc, RGB(0, 0, 255)
   SetBkMode hdc, %OPAQUE
   StrokeAndFillPath hdc
   DeleteObject SelectObject(hdc, GetStockObject(%WHITE_BRUSH))
   SelectObject hdc, GetStockObject(%SYSTEM_FONT)
   DeleteObject hFont

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "FontFill: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LOWRD(wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

      CASE %WM_SIZE
         cxClient = LOWRD(lParam)
         cyClient = HIWRD(lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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



FONTDEMO.RC

Code Select Expand


#define IDM_PRINT                       40001
#define IDM_ABOUT                       40002

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

FONTDEMO MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print...",                   IDM_PRINT
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&About...",                   IDM_ABOUT
    END
END


[José Roca]

 
This program is a translation of FONTOUT1.C -- Using Path to Outline Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

The program creates a 144-point TrueType font and calls the GetTextExtentPoint32 function to obtain the dimensions of the text box. It then calls the TextOut function in a path definition so that the text is centered in the client window. Because the TextOut function is called in a path bracket-that is, between calls to BeginPath and EndPath-GDI does not display the text immediately. Instead, the character outlines are stored in the path definition.

After the path bracket is ended, FONTOUT1 calls StrokePath. Because no special pen has been selected into the device context, GDI simply draws the character outlines using the default pen.

Code Select Expand


' ========================================================================================
' FONTOUT1.BAS
' This program is a translation/adaptation of FONTOUT1.C -- Using Path to Outline Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' The program creates a 144-point TrueType font and calls the GetTextExtentPoint32
' function to obtain the dimensions of the text box. It then calls the TextOut function in
' a path definition so that the text is centered in the client window. Because the TextOut
' function is called in a path bracket-that is, between calls to BeginPath and EndPath-GDI
' does not display the text immediately. Instead, the character outlines are stored in the
' path definition.
' After the path bracket is ended, FONTOUT1 calls StrokePath. Because no special pen has
' been selected into the device context, GDI simply draws the character outlines using the
' default pen.
' ========================================================================================

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

$szAppName = "FontOut1"
$szTitle   = "FontOut1: Using Path to Outline Font"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINT
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL  hFont AS DWORD
   STATIC szString AS ASCIIZ * 256
   LOCAL  tsize AS SIZE

   szString = "Outline"
   hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
   SelectObject hdc, hFont
   GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
   BeginPath hdc
   TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
   EndPath hdc
   StrokePath hdc
   SelectObject hdc, GetStockObject(%SYSTEM_FONT)
   DeleteObject hFont

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "FontOut1: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

     CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

      CASE %WM_SIZE
         cxClient = LOWRD(lParam)
         cyClient = HIWRD(lParam)
         EXIT FUNCTION

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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



FONTDEMO.RC

Code Select Expand


#define IDM_PRINT                       40001
#define IDM_ABOUT                       40002

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

FONTDEMO MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print...",                   IDM_PRINT
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&About...",                   IDM_ABOUT
    END
END



[José Roca]

 
This program is a translation of FONTOUT2.C -- Using Path to Outline Font © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

Using the ExtCreatePen function, you can outline the characters of a font with something other than the default pen.

Code Select Expand


' ========================================================================================
' FONTOUT2.BAS
' This program is a translation/adaptation of FONTOUT2.C -- Using Path to Outline Font
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' Using the ExtCreatePen function, you can outline the characters of a font with something
' other than the default pen.
' ========================================================================================

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

$szAppName = "FontOut2"
$szTitle   = "FontOut2: Using Path to Outline Font"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINT
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL  hFont AS DWORD
   STATIC szString AS ASCIIZ * 256
   LOCAL  tsize AS SIZE
   LOCAL  lb AS LOGBRUSH

   szString = "Outline"
   hFont = EzCreateFont (hdc, "Times New Roman", 1440, 0, 0, %TRUE)
   SelectObject hdc, hFont
   SetBkMode hdc, %TRANSPARENT
   GetTextExtentPoint32 hdc, szString, LEN(szString), tsize
   BeginPath hdc
   TextOut hdc, (cxArea - tsize.cx) \ 2, (cyArea - tsize.cy) \ 2, szString, LEN(szString)
   EndPath hdc
   lb.lbStyle = %BS_SOLID
   lb.lbColor = RGB(255, 0, 0)
   lb.lbHatch = 0
   SelectObject hdc, ExtCreatePen (%PS_GEOMETRIC OR %PS_DOT, _
                GetDeviceCaps(hdc, %LOGPIXELSX) \ 24, lb, 0, BYVAL %NULL)
   StrokePath hdc
   DeleteObject SelectObject(hdc, GetStockObject(%BLACK_PEN))
   SelectObject hdc, GetStockObject(%SYSTEM_FONT)
   DeleteObject hFont

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "FontOut2: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

      CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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



FONTDEMO.RC

Code Select Expand


#define IDM_PRINT                       40001
#define IDM_ABOUT                       40002

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

FONTDEMO MENU DISCARDABLE
BEGIN
    POPUP "&File"
    BEGIN
        MENUITEM "&Print...",                   IDM_PRINT
    END
    POPUP "&Help"
    BEGIN
        MENUITEM "&About...",                   IDM_ABOUT
    END
END


[José Roca]

 

This program is a translation of FONTROT.C -- Rotated Fonts © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming Windows, 5th Edition.

Although EzCreateFont does not allow you to specify a rotation angle for the font, it's fairly easy to make an adjustment after calling the function, as the FONTROT ("Font Rotate") program demonstrates.

Code Select Expand


' ========================================================================================
' FONTROT.BAS
' This program is a translation/adaptation of FONTROT.C -- Rotated Fonts
' © Charles Petzold, 1998, described and analysed in Chapter 17 of the book Programming
' Windows, 5th Edition.
' Although EzCreateFont does not allow you to specify a rotation angle for the font, it's
' fairly easy to make an adjustment after calling the function, as the FONTROT
' ("Font Rotate") program demonstrates.
' ========================================================================================

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

$szAppName = "FontRot"
$szTitle   = "FontRot: Rotated Fonts"

%IDM_PRINT = 40001
%IDM_ABOUT = 40002

%EZ_ATTR_BOLD      = 1
%EZ_ATTR_ITALIC    = 2
%EZ_ATTR_UNDERLINE = 4
%EZ_ATTR_STRIKEOUT = 8

' ========================================================================================
FUNCTION EzCreateFont (BYVAL hdc AS DWORD, szFaceName AS ASCIIZ, BYVAL iDeciPtHeight AS LONG, _
         BYVAL iDeciPtWidth AS LONG, BYVAL iAttributes AS LONG, BYVAL fLogRes AS LONG) AS DWORD

   LOCAL cxDpi AS SINGLE
   LOCAL cyDpi AS SINGLE
   LOCAL hFont AS DWORD
   LOCAL lf    AS LOGFONT
   LOCAL pt    AS POINT
   LOCAL tm    AS TEXTMETRIC

   SaveDC hdc

   SetGraphicsMode hdc, %GM_ADVANCED
   ModifyWorldTransform hdc, BYVAL %NULL, %MWT_IDENTITY
   SetViewportOrgEx hdc, 0, 0, BYVAL %NULL
   SetWindowOrgEx   hdc, 0, 0, BYVAL %NULL

   IF fLogRes THEN
      cxDpi = GetDeviceCaps(hdc, %LOGPIXELSX)
      cyDpi = GetDeviceCaps(hdc, %LOGPIXELSY)
   ELSE
      cxDpi = (25.4 * GetDeviceCaps(hdc, %HORZRES) / _
                      GetDeviceCaps(hdc, %HORZSIZE))
      cyDpi = (25.4 * GetDeviceCaps(hdc, %VERTRES) / _
                      GetDeviceCaps(hdc, %VERTSIZE))
   END IF

   pt.x = iDeciPtWidth  * cxDpi \ 72
   pt.y = iDeciPtHeight * cyDpi \ 72

   DPtoLP hdc, pt, 1
   lf.lfHeight         = - ABS(pt.y) \ 10.0 + 0.5
   lf.lfWidth          = 0
   lf.lfEscapement     = 0
   lf.lfOrientation    = 0
   lf.lfWeight         = IIF&(iAttributes AND %EZ_ATTR_BOLD, 700, 0)
   lf.lfItalic         = IIF&(iAttributes AND %EZ_ATTR_ITALIC, 1, 0)
   lf.lfUnderline      = IIF&(iAttributes AND %EZ_ATTR_UNDERLINE, 1, 0)
   lf.lfStrikeOut      = IIF&(iAttributes AND %EZ_ATTR_STRIKEOUT, 1, 0)
   lf.lfCharSet        = %DEFAULT_CHARSET
   lf.lfOutPrecision   = 0
   lf.lfClipPrecision  = 0
   lf.lfQuality        = 0
   lf.lfPitchAndFamily = 0
   lf.lfFaceName       = szFaceName

   hFont = CreateFontIndirect(lf)

   IF iDeciPtWidth THEN
      hFont = SelectObject(hdc, hFont)
      GetTextMetrics hdc, tm
      DeleteObject SelectObject(hdc, hFont)
      lf.lfWidth = tm.tmAveCharWidth * ABS(pt.x) \ ABS(pt.y) + 0.5
      hFont = CreateFontIndirect(lf)
   END IF

   RestoreDC hdc, -1
   FUNCTION = hFont

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

' ========================================================================================
SUB PaintRoutine (BYVAL hwnd AS DWORD, BYVAL hdc AS DWORD, BYVAL cxArea AS LONG, BYVAL cyArea AS LONG)

   LOCAL  hFont AS DWORD
   LOCAL  i AS LONG
   LOCAL  lf AS LOGFONT
   STATIC szString AS ASCIIZ * 256
   LOCAL  szFormat AS ASCIIZ * 256

   szString = "   Rotation"
   hFont = EzCreateFont(hdc, "Times New Roman", 540, 0, 0, %TRUE)
   GetObject hFont, SIZEOF(LOGFONT), lf
   DeleteObject hFont

   SetBkMode hdc, %TRANSPARENT
   SetTextAlign hdc, %TA_BASELINE
   SetViewportOrgEx hdc, cxArea \ 2, cyArea \ 2, BYVAL %NULL

   FOR i = 0 TO 11
      lf.lfOrientation = i * 300
      lf.lfEscapement = lf.lfOrientation
      SelectObject hdc, CreateFontIndirect(lf)
      TextOut hdc, 0, 0, szString, LEN(szString)
      DeleteObject SelectObject (hdc, GetStockObject(%SYSTEM_FONT))
   NEXT

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC dinfo AS DOCINFO
   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  fSuccess AS LONG
   LOCAL  hdc AS DWORD
   LOCAL  hdcPrn AS DWORD
   LOCAL  cxPage AS LONG
   LOCAL  cyPage AS LONG
   LOCAL  ps AS PAINTSTRUCT
   LOCAL  bSuccess AS LONG
   STATIC szDocName AS ASCIIZ * 256
   LOCAL  Flags AS DWORD
   LOCAL  nCopies AS WORD
   LOCAL  nFromPage AS WORD
   LOCAL  nToPage AS WORD

   SELECT CASE uMsg

      CASE %WM_CREATE
         szDocName = "FontRot: Printing"
         dinfo.cbSize = SIZEOF(DOCINFO)
         dInfo.lpszDocName = VARPTR(szDocName)
         EXIT FUNCTION

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

     CASE %WM_COMMAND

         SELECT CASE LO(WORD, wParam)

            CASE %IDM_PRINT
               ' Get printer DC
               Flags = %PD_RETURNDC OR %PD_NOPAGENUMS OR %PD_NOSELECTION
               nCopies = 1 : nFromPage = 1 : nToPage = 1
               IF PrinterDialog(hwnd, Flags, hdcPrn, nCopies, nFromPage, nToPage, 1, 1) THEN
                  IF hdcPrn = %NULL THEN
                     MessageBox hwnd, "Cannot obtain Printer DC", "EmfView", %MB_OK OR %MB_ICONEXCLAMATION OR %MB_TASKMODAL
                  ELSE
                     ' Get size of printable area of page
                     cxPage = GetDeviceCaps(hdcPrn, %HORZRES)
                     cyPage = GetDeviceCaps(hdcPrn, %VERTRES)
                     fSuccess = %FALSE
                     ' Do the printer page
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_WAIT)
                     ShowCursor %TRUE
                     IF StartDoc(hdcPrn, dinfo) > 0 AND StartPage(hdcPrn) > 0 THEN
                        PaintRoutine hwnd, hdcPrn, cxPage, cyPage
                        IF EndPage(hdcPrn) > 0 THEN
                           bSuccess = %TRUE
                           EndDoc hdcPrn
                        END IF
                     END IF
                     ShowCursor %FALSE
                     SetCursor LoadCursor(%NULL, BYVAL %IDC_ARROW)
                  END IF
                  DeleteDC hdcPrn
                  IF bSuccess = %FALSE THEN
                     MessageBox hwnd, "Error encountered during printing", _
                                BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
                  END IF
               END IF
               EXIT FUNCTION

            CASE %IDM_ABOUT
               MessageBox hwnd, "Font Demonstration Program" & $LF & _
                                "(c) Charles Petzold, 1998", _
                          BYCOPY $szAppName, %MB_ICONINFORMATION OR %MB_OK
               EXIT FUNCTION

         END SELECT

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         PaintRoutine hwnd, hdc, cxClient, cyClient
         EndPaint hwnd, ps
         EXIT FUNCTION

      CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

 
This program is a translation of FORMFEED.C -- Advances printer to next page © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming Windows, 5th Edition.

The FORMFEED program demonstrates the absolute minimum requirements for printing.

Code Select Expand


' ========================================================================================
' FORMFEED.BAS
' This program is a translation of FORMFEED.C -- Advances printer to next page
' © Charles Petzold, 1998, described and analysed in Chapter 13 of the book Programming
' Windows, 5th Edition.
' The FORMFEED program demonstrates the absolute minimum requirements for printing.
' ========================================================================================

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

' ========================================================================================
' GetPrinterDC function
' Methods for obtaining the default printer device context have changed over the years.
' Currently, the standard method involves using the EnumPrinters function. This function
' fills an array of structures that contain information about each attached printer. You
' even have a choice of several structures to use with this function, depending on the
' level of detail you want. These structures have names of PRINTER_INFO_x, where x is a
' number.
' ========================================================================================
FUNCTION GetPrinterDC () AS DWORD

   LOCAL dwLevel    AS DWORD
   LOCAL dwFlags    AS DWORD
   LOCAL dwNeeded   AS DWORD
   LOCAL dwReturned AS DWORD
   LOCAL hdc        AS DWORD
   LOCAL tos        AS OSVERSIONINFO
   LOCAL pinfo4     AS PRINTER_INFO_4 PTR
   LOCAL pinfo5     AS PRINTER_INFO_5 PTR

   dwLevel = 5
   dwFlags = %PRINTER_ENUM_LOCAL
   IF ISTRUE GetVersionEx(tos) THEN
      IF tos.dwPlatformId = %VER_PLATFORM_WIN32_NT THEN
         dwLevel = 4
         dwFlags = %PRINTER_ENUM_NETWORK OR %PRINTER_ENUM_LOCAL
      END IF
   END IF

   EnumPrinters dwFlags, "", dwLevel, BYVAL %NULL, 0, dwNeeded, dwReturned
   IF dwLevel = 4 THEN
      pInfo4 = CoTaskMemAlloc(dwNeeded)
      EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo4, dwNeeded, dwNeeded, dwReturned
      hdc = CreateDC("", @pInfo4.@pPrinterName, "", BYVAL %NULL)
      CoTaskMemFree pInfo4
   ELSE
      pInfo5 = CoTaskMemAlloc(dwNeeded)
      EnumPrinters dwFlags, "", dwLevel, BYVAL pInfo5, dwNeeded, dwNeeded, dwReturned
      hdc = CreateDC("", BYVAL @pInfo5.pPrinterName, "", BYVAL %NULL)
      CoTaskMemFree pInfo5
   END IF

   FUNCTION = hdc

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

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

   LOCAL dinfo     AS DOCINFO
   LOCAL szDocName AS ASCIIZ * 256
   LOCAL hdcPrint  AS DWORD

   szDocName = "FormFeed"
   dinfo.cbSize = SIZEOF(DOCINFO)
   dinfo.lpszDocName = VARPTR(szDocName)

   hdcPrint = GetPrinterDC()
   IF hdcPrint <> %NULL THEN
      IF StartDoc(hdcPrint, dinfo) > 0 THEN
         IF StartPage(hdcPrint) > 0 AND EndPage(hdcPrint) > 0 THEN
            EndDoc hdcPrint
         END IF
      END IF
      DeleteDC hdcPrint
   END IF

   FUNCTION  = 0

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


[José Roca]

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

You can also use bitmaps to display items in menus. If you immediately recoiled at the thought of pictures of file folders, paste jars, and trash cans in a menu, don't think of pictures. Think instead of how useful menu bitmaps might be for a drawing program. Think of using different fonts and font sizes, line widths, hatch patterns, and colors in your menus.

Code Select Expand


' ========================================================================================
' GRAFMENU.BAS
' This program is a translation/adaptation of GRAFMENU.C -- Demonstrates Bitmap Menu Items
' © Charles Petzold, 1998, described and analysed in Chapter 14 of the book Programming
' Windows, 5th Edition.
' You can also use bitmaps to display items in menus. If you immediately recoiled at the
' thought of pictures of file folders, paste jars, and trash cans in a menu, don't think
' of pictures. Think instead of how useful menu bitmaps might be for a drawing program.
' Think of using different fonts and font sizes, line widths, hatch patterns, and colors
' in your menus.
' ========================================================================================

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

%IDM_FONT_COUR    = 101
%IDM_FONT_ARIAL   = 102
%IDM_FONT_TIMES   = 103
%IDM_HELP         = 104
%IDM_EDIT_UNDO    = 40005
%IDM_EDIT_CUT     = 40006
%IDM_EDIT_COPY    = 40007
%IDM_EDIT_PASTE   = 40008
%IDM_EDIT_CLEAR   = 40009
%IDM_FILE_NEW     = 40010
%IDM_FILE_OPEN    = 40011
%IDM_FILE_SAVE    = 40012
%IDM_FILE_SAVE_AS = 40013

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

' ========================================================================================
' StretchBitmap: Scales bitmap to display resolution
' ========================================================================================
FUNCTION StretchBitmap (BYVAL hBitmap1 AS DWORD) AS DWORD

   LOCAL bm1      AS BITMAP
   LOCAL bm2      AS BITMAP
   LOCAL hBitmap2 AS DWORD
   LOCAL hdc      AS DWORD
   LOCAL hdcMem1  AS DWORD
   LOCAL hdcMem2  AS DWORD
   LOCAL cxChar   AS DWORD
   LOCAL cyChar   AS DWORD

   ' Get the width and height of a system font character
   cxChar = LOWRD(GetDialogBaseUnits())
   cyChar = HIWRD(GetDialogBaseUnits())

   ' Create 2 memory DCs compatible with the display
   hdc = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
   hdcMem1 = CreateCompatibleDC(hdc)
   hdcMem2 = CreateCompatibleDC(hdc)
   DeleteDC hdc

   ' Get the dimensions of the bitmap to be stretched
   GetObject hBitmap1, SIZEOF(BITMAP), bm1

   ' Scale these dimensions based on the system font size
   bm2 = bm1
   bm2.bmWidth      = (cxChar * bm2.bmWidth)  / 4
   bm2.bmHeight     = (cyChar * bm2.bmHeight) / 8
   bm2.bmWidthBytes = ((bm2.bmWidth + 15) / 16) * 2

   ' Create a new bitmap of larger size

   hBitmap2 = CreateBitmapIndirect(bm2)

   '  Select the bitmaps in the memory DCs and do a StretchBlt
   SelectObject hdcMem1, hBitmap1
   SelectObject hdcMem2, hBitmap2
   StretchBlt hdcMem2, 0, 0, bm2.bmWidth, bm2.bmHeight, _
              hdcMem1, 0, 0, bm1.bmWidth, bm1.bmHeight, %SRCCOPY

   ' Clean up
   DeleteDC hdcMem1
   DeleteDC hdcMem2
   DeleteObject hBitmap1

   FUNCTION = hBitmap2

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

' ========================================================================================
' GetBitmapFont: Creates bitmaps with font names
' ========================================================================================
FUNCTION GetBitmapFont (BYVAL i AS LONG) AS DWORD

   DIM szFaceName(2) AS ASCIIZ * 256
   LOCAL hBitmap AS DWORD
   LOCAL hdc AS DWORD
   LOCAL hdcMem AS DWORD
   LOCAL hFont AS DWORD
   LOCAL tsize AS SIZE
   LOCAL tm AS TEXTMETRIC

   szFaceName(0) = "Courier New"
   szFaceName(1) = "Arial"
   szFaceName(2) = "Times New Roman"

   hdc = CreateIC("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
   GetTextMetrics hdc, tm

   hdcMem = CreateCompatibleDC(hdc)
   hFont  = CreateFont (2 * tm.tmHeight, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, szFaceName(i))

   hFont = SelectObject(hdcMem, hFont)
   GetTextExtentPoint32 hdcMem, szFaceName(i), LEN(szFaceName(i)), tsize

   hBitmap = CreateBitmap(tsize.cx, tsize.cy, 1, 1, BYVAL %NULL)
   SelectObject hdcMem, hBitmap

   TextOut hdcMem, 0, 0, szFaceName(i), LEN(szFaceName(i))

   DeleteObject SelectObject(hdcMem, hFont)
   DeleteDC hdcMem
   DeleteDC hdc

   FUNCTION = hBitmap

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

' ========================================================================================
' DeleteAllBitmaps: Deletes all the bitmaps in the menu
' ========================================================================================
SUB DeleteAllBitmaps (BYVAL hwnd AS DWORD)

   LOCAL hMenu AS DWORD
   LOCAL i     AS LONG
   LOCAL mii   AS MENUITEMINFO

   mii.cbSize = SIZEOF(MENUITEMINFO)
   mii.fMask  = %MIIM_SUBMENU OR %MIIM_TYPE

   ' Delete Help bitmap on system menu
   hMenu = GetSystemMenu(hwnd, %FALSE)
   GetMenuItemInfo hMenu, %IDM_HELP, %FALSE, mii
   DeleteObject mii.dwTypeData

   ' Delete top-level menu bitmaps
   hMenu = GetMenu(hwnd)
   FOR i = 0 TO 2
      GetMenuItemInfo hMenu, i, %TRUE, mii
      DeleteObject mii.dwTypeData
   NEXT

   ' Delete bitmap items on Font menu
   hMenu = mii.hSubMenu
   FOR i = 0 TO 2
      GetMenuItemInfo hMenu, i, %TRUE, mii
      DeleteObject mii.dwTypeData
   NEXT

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

' ========================================================================================
' AddHelpToSys: Adds bitmap Help item to system menu
' ========================================================================================
SUB AddHelpToSys (BYVAL hInstance AS DWORD, BYVAL hwnd AS DWORD)

   LOCAL hBitmap AS DWORD
   LOCAL hMenu   AS DWORD

   hMenu = GetSystemMenu(hwnd, %FALSE)
   hBitmap = StretchBitmap(LoadBitmap (hInstance, "BitmapHelp"))
   AppendMenu hMenu, %MF_SEPARATOR, 0, BYVAL %NULL
   AppendMenu hMenu, %MF_BITMAP, %IDM_HELP, BYVAL hBitmap

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

' ========================================================================================
' CreateMyMenu: Assembles menu from components
' ========================================================================================
FUNCTION CreateMyMenu (BYVAL hInstance AS DWORD) AS DWORD

   LOCAL hBitmap    AS DWORD
   LOCAL hMenu      AS DWORD
   LOCAL hMenuPopup AS DWORD
   LOCAL i          AS LONG

   hMenu = CreateMenu()

   hMenuPopup = LoadMenu(hInstance, "MenuFile")
   hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapFile"))
   AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap

   hMenuPopup = LoadMenu(hInstance, "MenuEdit")
   hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapEdit"))
   AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap

   hMenuPopup = CreateMenu()
   FOR i = 0 TO 2
      hBitmap = GetBitmapFont(i)
      AppendMenu hMenuPopup, %MF_BITMAP, %IDM_FONT_COUR + i, BYVAL hBitmap
   NEXT

   hBitmap = StretchBitmap(LoadBitmap(hInstance, "BitmapFont"))
   AppendMenu hMenu, %MF_BITMAP OR %MF_POPUP, hMenuPopup, BYVAL hBitmap

   FUNCTION = hMenu

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

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

   LOCAL  hMenu AS DWORD
   STATIC iCurrentFont AS LONG
   STATIC hInstance AS DWORD
   LOCAL  lpc AS CREATESTRUCT PTR

   SELECT CASE uMsg

      CASE %WM_CREATE
         iCurrentFont = %IDM_FONT_COUR
         lpc = lParam
         hInstance = @lpc.hInstance
         AddHelpToSys hInstance, hwnd
         hMenu = CreateMyMenu(hInstance)
         SetMenu hwnd, hMenu
         CheckMenuItem hMenu, iCurrentFont, %MF_CHECKED
         EXIT FUNCTION

      CASE %WM_SYSCOMMAND
         SELECT CASE LOWRD(wParam)
            CASE %IDM_HELP
               MessageBox hwnd, "Help not yet implemented!", _
                          "GrafMenu", %MB_OK OR %MB_ICONEXCLAMATION
               EXIT FUNCTION
         END SELECT

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

      CASE %WM_COMMAND

         SELECT CASE LOWRD(wParam)

            CASE %IDM_FILE_NEW, _
                 %IDM_FILE_OPEN, _
                 %IDM_FILE_SAVE, _
                 %IDM_FILE_SAVE_AS, _
                 %IDM_EDIT_UNDO, _
                 %IDM_EDIT_CUT, _
                 %IDM_EDIT_COPY, _
                 %IDM_EDIT_PASTE, _
                 %IDM_EDIT_CLEAR
                 MessageBeep 0
                 EXIT FUNCTION

            CASE %IDM_FONT_COUR, %IDM_FONT_ARIAL, %IDM_FONT_TIMES
               hMenu = GetMenu(hwnd)
               CheckMenuItem hMenu, iCurrentFont, %MF_UNCHECKED
               iCurrentFont = LOWRD(wParam)
               CheckMenuItem hMenu, iCurrentFont, %MF_CHECKED
               EXIT FUNCTION

         END SELECT

      CASE %WM_DESTROY
         DeleteALlBitmaps hwnd
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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


[José Roca]

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

Does not use the Windows Palette Manager but instead tries to normally display 65 shades of gray as a "fountain" of color ranging black to white.

Code Select Expand


' ========================================================================================
' GRAYS1.BAS
' This program is a translation/adaptation of GRAYS1.C -- Gray Shades © Charles Petzold, 1998,
' described and analysed in Chapter 16 of the book Programming Windows, 5th Edition.
' Does not use the Windows Palette Manager but instead tries to normally display 65 shades
' of gray as a "fountain" of color ranging black to white.
' ========================================================================================

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

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

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

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

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

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

   ShowWindow hwnd, iCmdShow
   UpdateWindow hwnd

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

   FUNCTION = uMsg.wParam

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

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

   STATIC cxClient AS LONG
   STATIC cyClient AS LONG
   LOCAL  hBrush   AS DWORD
   LOCAL  hdc      AS DWORD
   LOCAL  i        AS LONG
   LOCAL  ps       AS PAINTSTRUCT
   LOCAL  rc       AS RECT

   SELECT CASE uMsg

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

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

      CASE %WM_PAINT
         hdc = BeginPaint(hwnd, ps)
         ' Draw the fountain of grays
         FOR i = 0 TO 64
            rc.nLeft   = i * cxClient / 65
            rc.nTop    = 0
            rc.nRight  = (i + 1) * cxClient / 65
            rc.nBottom = cyClient
            hBrush = CreateSolidBrush(RGB(MIN&(255, 4 * i), _
                                          MIN&(255, 4 * i), _
                                          MIN&(255, 4 * i)))
            FillRect hdc, rc, hBrush
            DeleteObject hBrush
         NEXT
         EndPaint hwnd, ps
         EXIT FUNCTION

     CASE %WM_DESTROY
         PostQuitMessage 0
         EXIT FUNCTION

   END SELECT

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

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