Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

PBDLL: Font Parameters

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBDLL: Font Parameters

    ' I had to do this experimentation for a project I'm working on.
    ' I thought I'd share the end results.
    Code:
    '-------------------------------------------------------------------------------
    '
    '  Font Investigation Program
    '  by Ian Cairns - February 15/2000
    '-------------------------------------------------------------------------------
    
    $DIM ALL
    $COMPILE EXE
    $DEBUG ERROR ON
    $OPTION VERSION4
    
    #INCLUDE "WIN32API.INC"
    #INCLUDE "COMDLG32.INC"
    
    ' Define Menu ID codes:
    %IDM_SELECTFONT       = 1
    %IDM_CHANGEBACKGROUND = 2
    %IDM_EXIT             = 3
    
    '------------------------------------------------------------------------------
    GLOBAL szAppName AS ASCIIZ*21
    '------------------------------------------------------------------------------
    
    FUNCTION WINMAIN (BYVAL hInstance     AS LONG, _
                      BYVAL hPrevInstance AS LONG, _
                      lpCmdLine           AS ASCIIZ PTR, _
                      BYVAL iCmdShow      AS LONG) AS LONG
    
      LOCAL Msg         AS tagMsg
      LOCAL wClass      AS WndClassEx
      LOCAL hWndMain    AS DWORD
    
    ' Initialize
    '~~~~~~~~~~~
      szAppName              = "Font Display Program"
    
    ' Fill window class structure
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~
      wClass.cbSize        = SIZEOF(wClass)
      wClass.style         = %CS_HREDRAW OR %CS_VREDRAW
      wClass.lpfnWndProc   = CODEPTR(MainWndProc)
      wClass.cbClsExtra    = 0
      wClass.cbWndExtra    = 0
      wClass.hInstance     = hInstance
      wClass.hIcon         = LoadIcon  (%NULL, BYVAL %IDI_APPLICATION)
      wClass.hCursor       = LoadCursor(%NULL, BYVAL %IDC_ARROW)
      wClass.hbrBackground = GetStockObject(%WHITE_BRUSH)
      wClass.lpszMenuName  = VARPTR(szAppName)
      wClass.lpszClassName = VARPTR(szAppName)
      wClass.hIConSm       = LoadIcon  (%NULL, BYVAL %IDI_APPLICATION)
    
    
    ' Register the window-class
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~
      RegisterClassEx wClass
    
    ' Create a window using the registered class
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      hWndMain = CreateWindow(szAppName, _               ' window class name
                              "Font Selection and Display", _ ' window caption
                              %WS_OVERLAPPEDWINDOW OR _
                              %WS_VSCROLL OR %WS_HSCROLL,_  ' window style
                              %CW_USEDEFAULT, _            ' initial x position
                              %CW_USEDEFAULT, _            ' initial y position
                              %CW_USEDEFAULT, _            ' initial x size
                              %CW_USEDEFAULT, _            ' initial y size
                              %HWND_DESKTOP, _             ' parent window handle
                              %NULL, _                     ' window menu handle
                              hInstance, _                 ' program instance handle
                              BYVAL %NULL)                 ' creation parameters
    
    ' Show Window
    '~~~~~~~~~~~~
      ShowWindow hWndMain, iCmdShow
      UpdateWindow hWndMain
    
      WHILE GetMessage(Msg, %NULL, 0, 0)
    
        TranslateMessage Msg
        DispatchMessage Msg
      WEND
    
      FUNCTION = msg.wParam
    
    END FUNCTION  ' WinMain
    
    '------------------------------------------------------------------------------
    
    FUNCTION MainWndProc (BYVAL hWnd AS DWORD, BYVAL wMsg AS LONG, _
                      BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
    
      STATIC cxCaps      AS LONG,_
             cxChar      AS LONG,_
             cyChar      AS LONG,_
             cxClient    AS LONG,_
             cyClient    AS LONG,_
             iMaxWidth   AS LONG,_
             iVscrollPos AS LONG,_
             iVscrollMax AS LONG,_
             iHscrollPos AS LONG,_
             iHscrollMax AS LONG,_
             sz_Max      AS LONG,_
             hMenu       AS LONG, _
             hMenuPopup  AS LONG,_
             tm          AS TEXTMETRIC,_
             cf          AS CHOOSEFONTAPI, _
             lfFont      AS LOGFONT, _
             lfFontRGB   AS LONG,_
             hFont       AS LONG,_
             BackgroundKolor  AS CHOOSECOLORAPI
    
      DIM    FontInfo(1 : 15)      AS STATIC STRING, _
             tmpCustColors(0 : 15) AS STATIC DWORD
    
      LOCAL  hdc         AS LONG,_
             ps          AS PAINTSTRUCT,_
             si          AS SCROLLINFO,_
             x           AS LONG,_
             y           AS LONG,_
             i           AS LONG,_
             iPaintBeg   AS LONG,_
             iPaintEnd   AS LONG,_
             iVscrollInc AS LONG,_
             iHscrollInc AS LONG,_
             pointSize   AS LONG
    
      SELECT CASE wMsg
    ' ~~~~~~~~~~~~~~~~
        CASE %WM_CREATE
    '   ~~~~~~~~~~~~~~~
          cf.lStructSize    = SIZEOF(cf)
          cf.hWndOwner      = hWnd
          cf.hDC            = %NULL
          cf.lpLogFont      = VARPTR(lfFont)
          cf.iPointSize     = 0
          cf.Flags          = %CF_INITTOLOGFONTSTRUCT OR %CF_EFFECTS OR %CF_BOTH' _
    '                          OR %CF_TTONLY OR %CF_SCRIPTSONLY
          cf.rgbColors      = lfFontRGB
          cf.lCustData      = 0
          cf.lpfnHook       = %NULL
          cf.lpTemplateName = %NULL
          cf.hInstance      = %NULL
          cf.lpszStyle      = %NULL
          cf.nFontType      = 0
          cf.nSizeMin       = 0
          cf.nSizeMax       = 0
    
          CALL GetObject(GetStockObject(%SYSTEM_FONT), SIZEOF(lfFont), lfFont)
          hFont = CreateFontIndirect (lfFont)
          CALL SendMessage (hWnd, %WM_SETFONT, hFont, 0)
    
          BackgroundKolor.lStructSize    = SIZEOF(BackgroundKolor)
          BackgroundKolor.hwndOwner      = %NULL
          BackgroundKolor.hInstance      = %NULL
          BackgroundKolor.rgbResult      = RGB(&HFF, &HFF, &HFF)
          BackgroundKolor.lpCustColors   =  VARPTR(tmpCustColors())
          BackgroundKolor.Flags          = %CC_RGBINIT  OR %CC_FULLOPEN
          BackgroundKolor.lCustData      = 0
          BackgroundKolor.lpfnHook       = %NULL
          BackgroundKolor.lpTemplateName = %NULL
    
    ' Get Text Metrics
          hdc = GetDC (hWnd)
          CALL GetTextMetrics (hdc, tm)        'Get font parameters
          cxChar = tm.tmAveCharWidth           'Average character width
          IF (tm.tmPitchAndFamily AND 1) THEN  'Average uppercase width
            cxCaps = cxChar * 3 \ 2            '(same as cxChar for fixed
          ELSE                                 ' pitch, 150% for variable)
            cxCaps = cxChar
          END IF
          cyChar = tm.tmHeight + tm.tmExternalLeading  'Line spacing
          CALL ReleaseDC (hWnd, hdc)
          iMaxWidth = 30 * cxChar + cxCaps
          sz_Max = 15
    
    ' Create Menu
          hMenu = CreateMenu ()
          hMenuPopup = CreateMenu ()
          CALL AppendMenu (hMenuPopup, %MF_STRING,    %IDM_SELECTFONT,        "&Select Font ...")
          CALL AppendMenu (hMenuPopup, %MF_STRING,    %IDM_CHANGEBACKGROUND, "&Change Background Color ...")
          CALL AppendMenu (hMenuPopup, %MF_STRING,    %IDM_EXIT,               "E&xit")
          CALL AppendMenu (hMenu, %MF_POPUP, hMenuPopup, "&Menu")
          CALL SetMenu (hWnd, hMenu)
    
    ' Resize resets Scrollbars
        CASE %WM_SIZE
    '   ~~~~~~~~~~~~~
          cxClient    = LOWRD(lParam)
          cyClient    = HIWRD(lParam)
    
    ' Set Vertical Scroll bar Range and page Size
          si.cbSize = LEN(si)
          si.fMask  = %SIF_RANGE OR %SIF_PAGE
          si.nMin = 0
          si.nMax = MAX%(1, sz_Max)
          si.nPage = cyClient / cyChar
          CALL SetScrollInfo(hWnd, %SB_VERT, si, %TRUE)
    
    ' Set Horizontal Scroll bar Range and page Size
          si.cbSize = LEN(si)
          si.fMask  = %SIF_RANGE OR %SIF_PAGE
          si.nMin = 0
          si.nMax = MAX%(1, 1 + iMaxWidth / cxChar)
          si.nPage = cxClient / cxChar
          CALL SetScrollInfo(hWnd, %SB_HORZ, si, %TRUE)
    
          FUNCTION = 0
    
        CASE %WM_VSCROLL
    '   ~~~~~~~~~~~~~~~~
          si.cbSize = LEN(si)
          si.fMask  = %SIF_ALL
          CALL GetScrollInfo(hWnd, %SB_VERT, si)
    
          iVscrollPos = si.nPos
          SELECT CASE LOWRD(wParam)
            CASE %SB_TOP
              si.nPos = si.nMin
            CASE %SB_BOTTOM
              si.nPos = si.nMax
            CASE %SB_LINEUP
              DECR si.nPos
            CASE %SB_LINEDOWN
              INCR si.nPos
            CASE %SB_PAGEUP
              si.nPos = si.nPos - si.nPage
            CASE %SB_PAGEDOWN
              si.nPos = si.nPos + si.nPage
            CASE %SB_THUMBTRACK
              si.nPos = si.nTrackPos
          END SELECT
          si.fMask = %SIF_POS
          CALL SetScrollInfo(hWnd, %SB_VERT, si, %TRUE)
          CALL GetScrollInfo(hWnd, %SB_VERT, si)
          IF si.nPos <> iVscrollPos THEN
            CALL ScrollWindow(hWnd, 0, cyChar * (iVscrollPos - si.nPos), BYVAL %NULL, BYVAL %NULL)
            CALL UpdateWindow(hWnd)
          END IF
          FUNCTION = 0
    
        CASE %WM_HSCROLL
    '   ~~~~~~~~~~~~~~~~
          si.cbSize = LEN(si)
          si.fMask  = %SIF_ALL
          CALL GetScrollInfo(hWnd, %SB_HORZ, si)
    
          iHscrollPos = si.nPos
          SELECT CASE LOWRD(wParam)
            CASE %SB_LEFT
              si.nPos = si.nMin
            CASE %SB_RIGHT
              si.nPos = si.nMax
            CASE %SB_LINELEFT
              DECR si.nPos
            CASE %SB_LINERIGHT
              INCR si.nPos
            CASE %SB_PAGELEFT
              si.nPos = si.nPos - si.nPage
            CASE %SB_PAGERIGHT
              si.nPos = si.nPos + si.nPage
            CASE %SB_THUMBTRACK
              si.nPos = si.nTrackPos
          END SELECT
          si.fMask = %SIF_POS
          CALL SetScrollInfo(hWnd, %SB_HORZ, si, %TRUE)
          CALL GetScrollInfo(hWnd, %SB_HORZ, si)
          IF si.nPos <> iHscrollPos THEN
            CALL ScrollWindow(hWnd, cxChar * (iHscrollPos - si.nPos), 0,BYVAL %NULL, BYVAL %NULL)
            CALL UpdateWindow(hWnd)
          END IF
          FUNCTION = 0
    
    ' Translate Key messages into Scroll Messages
        CASE %WM_KEYDOWN
    '   ~~~~~~~~~~~~~~~~
          SELECT CASE (wParam)
            CASE %VK_HOME
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_TOP,      0)
            CASE %VK_END
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_BOTTOM,   0)
            CASE %VK_PRIOR     'PgUp
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_PAGEUP,   0)
            CASE %VK_NEXT      'PgDn
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_PAGEDOWN, 0)
            CASE %VK_UP
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_LINEUP,   0)
            CASE %VK_DOWN
              CALL SendMessage (hWnd, %WM_VSCROLL, %SB_LINEDOWN, 0)
            CASE %VK_LEFT
              CALL SendMessage (hWnd, %WM_HSCROLL, %SB_LINEUP,   0)
            CASE %VK_RIGHT
              CALL SendMessage (hWnd, %WM_HSCROLL, %SB_LINEDOWN, 0)
          END SELECT
    
        CASE %WM_PAINT
    '   ~~~~~~~~~~~~~~
          ps.fErase = 0
          hdc = BeginPaint(hWnd, ps)   'initiates window painting
          CALL SelectObject (hdc, CreateFontIndirect(lfFont))
    
          CALL SetBkColor (hdc,  BackgroundKolor.rgbResult)
          CALL FillRect(hdc,ps.rcPaint, CreateSolidBrush (BackgroundKolor.rgbResult) )
    
          CALL SetBkMode (hdc, %TRANSPARENT)
          CALL SetTextColor (hdc, lfFontRGB)
    
    ' Get Vertical ScrollBar position
          si.cbSize = LEN(si)
          si.fMask  = %SIF_ALL
          CALL GetScrollInfo(hWnd, %SB_VERT, si)
          iVscrollPos = si.nPos
    
    ' Get Horizontal ScrollBar position
          si.cbSize = LEN(si)
          si.fMask  = %SIF_ALL
          CALL GetScrollInfo(hWnd, %SB_HORZ, si)
          iHscrollPos = si.nPos
    
    ' Set area for painting
          iPaintBeg = MAX%(0, iVscrollPos + ps.rcPaint.nTop / cyChar)
          iPaintEnd = MIN (sz_Max, iVscrollPos + ps.rcPaint.nBottom /cyChar +1)
          x = cxChar * (1 - iHscrollPos) - cxChar
          y = cyChar * (i - iVscrollPos) - cyChar
    
          FOR i = iPaintBeg TO iPaintEnd
            y = cyChar * (i - iVscrollPos) - cyChar
            CALL TextOut (hdc, x, y, BYCOPY FontInfo(i), LEN(FontInfo(i)))
          NEXT i
          CALL EndPaint(hWnd, ps)  'ends window painting
          FUNCTION = 0
    
    ' Actions based on Menu Choices:
        CASE %WM_COMMAND
    '   ~~~~~~~~~~~~~~~~
          hMenu = GetMenu (hWnd)
    
          SELECT CASE LOWRD(wParam)
            CASE %IDM_SELECTFONT
    '       ~~~~~~~~~~~~~~~~~~~~
              IF ChooseFont (cf) THEN
                lfFontRGB = cf.rgbColors
                CALL DeleteObject (hFont)
                hFont = CreateFontIndirect (lfFont)
    
                hdc = GetDC (hWnd)
                CALL SelectObject (hdc, hFont)
    ' Get Text Metrics
                CALL GetTextMetrics (hdc, tm)        'Get font parameters
    ' Alternate method of getting point size without going through ChooseFont:
    '  pointSize =  (tm.tmHeight - tm.tmInternalLeading) * (72 / GetDeviceCaps(hdc, %LOGPIXELSY) )
                CALL ReleaseDC (hWnd, hdc)
    
                cxChar = tm.tmAveCharWidth           'Average character width
                IF (tm.tmPitchAndFamily AND 1) THEN  'Average uppercase width
                  cxCaps = cxChar * 3 \ 2            '(same as cxChar for fixed
                ELSE                                 ' pitch, 150% for variable)
                  cxCaps = cxChar
                END IF
                cyChar = tm.tmHeight + tm.tmExternalLeading  'Line spacing
    
                FontInfo(1)  = "FaceName: "       + lfFont.lfFacename
                FontInfo(2)  = "Point Size: "     + STR$(       cf.iPointSize/10)
                FontInfo(3)  = "PitchAndFamily: " + LTRIM$(STR$(lfFont.lfPitchAndFamily))
                FontInfo(4)  = "Height: "         + LTRIM$(STR$(lfFont.lfHeight))
                FontInfo(5)  = "Width: "          + LTRIM$(STR$(lfFont.lfWidth))
                FontInfo(6)  = "Escapement: "     + LTRIM$(STR$(lfFont.lfEscapement))
                FontInfo(7)  = "Orientation: "    + LTRIM$(STR$(lfFont.lfOrientation))
                FontInfo(8)  = "Weight: "         + LTRIM$(STR$(lfFont.lfWeight))
                FontInfo(9)  = "Italic: "         + LTRIM$(STR$(lfFont.lfItalic))
                FontInfo(10) = "Underline: "      + LTRIM$(STR$(lfFont.lfUnderline))
                FontInfo(11) = "Strikeout: "      + LTRIM$(STR$(lfFont.lfStrikeout))
                FontInfo(12) = "CharSet: "        + LTRIM$(STR$(lfFont.lfCharSet))
                FontInfo(13) = "OutPrecision: "   + LTRIM$(STR$(lfFont.lfOutPrecision))
                FontInfo(14) = "ClipPrecision: "  + LTRIM$(STR$(lfFont.lfClipPrecision))
                FontInfo(15) = "Quality: "        + LTRIM$(STR$(lfFont.lfQuality))
                iMaxWidth = 1
                FOR i = 1 TO 15
                  iMaxWidth = MAX(iMaxWidth,LEN(FontInfo(i)) )
                NEXT i
                iMaxWidth = (iMaxWidth+1) * cxChar + cxCaps
                CALL InvalidateRect(hWnd, BYVAL %NULL, 1)            ' Paint Entire Client Window
                CALL SendMessage(hWnd, %WM_SIZE, cxClient, cyClient) ' Reset Scroll Bars
              END IF
              FUNCTION = 0
    
            CASE %IDM_CHANGEBACKGROUND
    '       ~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Select Colored Brush into Device Context
              IF ChooseColor ( BackgroundKolor )  > 0 THEN
                CALL InvalidateRect(hWnd, BYVAL %NULL, 1) 'Paint Entire Client Window
              END IF
              FUNCTION = 0
    
            CASE %IDM_EXIT
    '       ~~~~~~~~~~~~~~
              CALL DeleteObject(hFont)
              PostQuitMessage 0
              FUNCTION = 0
    
          END SELECT
        CASE %WM_DESTROY
    '   ~~~~~~~~~~~~~~~~
          CALL DeleteObject(hFont)
          PostQuitMessage 0
          FUNCTION = 0
          EXIT FUNCTION
    
      END SELECT
    
      FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
    
    END FUNCTION
    '-----------------------------------------------------------------------------
    :) IRC :)
Working...
X