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

Font common dialog box demonstration with examples.

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

  • Font common dialog box demonstration with examples.

    ' june 23, 2002. adjustments made. the program runs now both with
    ' pb win 6 and 7.
    '
    ' this program demonstrates the use of windows' font common dialog and
    ' some examples of various text formats using a label (static) control
    ' as originally suggested for graphic purposes by lance edmonds
    ' in the powerbasic forum.
    '
    ' the code skeleton was generated by ezgui freeware dialog designer
    ' by christopher r. boss see web site at ezgui.com.
    ' unused code has been removed to improve clarity.
    '
    ' if you find any blunders or have comments for improvement you are
    ' most welcome. comments should go to this address:
    http://www.powerbasic.com/support/pb...ead.php?t=5990
    '
    ' by the way, is there an easy way of scrolling label (static) controls
    ' within the context of pb ddts or is that not possible?
    '
    ' best wishes,
    ' erik christensen, copenhagen, denmark. ---- e.chr@email.dk
    '
    Code:
    #compile exe
    #register none
    #dim all
    
    %noanimate    = 1
    %nobutton     = 1
    %nocombo      = 1
    %nodraglist   = 1
    %noheader     = 1
    %noimagelist  = 1
    %nolist       = 1
    %notrackbar   = 1
    
    #include "win32api.inc"
    #include "commctrl.inc"
    #include "comdlg32.inc"
    
    %form1_label1             = 100
    %form1_static1            = 105
    %form1_text1              = 110
    %form1_button1            = 115
    %form1_button2            = 120
    %form1_button3            = 125
    %form1_button4            = 130
    %form1_button5            = 135
    
    ' --------------------------------------------------
    declare sub showdialog_form1(byval hparent&)
    declare callback function form1_dlgproc
    declare callback function cbf_form1_button1()
    declare callback function cbf_form1_button2()
    declare callback function cbf_form1_button3()
    declare callback function cbf_form1_button4()
    declare callback function cbf_form1_button5()
    declare function choosecurrentfont(byval hwnd as long) as long
    declare sub showtext2(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
    declare sub showtext1(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
    declare sub showtext3(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
    declare function makefont(byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long,byval strikeout as long, _
        byval facename as string) as long
    global fosize as long,foweight as long,foital as long,founl as long,fostout as long,foface as string
    global hform1&    ' dialog handle
    global hfont      as long
    global lffont as logfont   ' logfont structure
    global cf as choosefontapi ' choosefont structure
    global hedit as long
    global hgraph as long
    global tm as textmetric    ' textmetric structure
    global lpsize as sizel
    global fontno&()           ' array of fonts
    global fono    as long     ' number of fonts in array (zero based)
    global x&,y&,x1&,y1&
    global rct as rect
    global ps as paintstruct   ' paint structure
    global brush as long
    global exampleflag as long
    global textfont as long
    global logpixelsy as long 'pixels per logical inch
                              'along the screen height
    ' *************************************************************
    function pbmain
        local count&
        local hdc as long
        local cc1 as init_common_controlsex
        cc1.dwsize=sizeof(cc1)
        cc1.dwicc=%icc_win95_classes
        initcommoncontrolsex cc1
        brush=createsolidbrush(rgb(255,255,255)) ' white brush
        showdialog_form1 0
        'retrieves a handle of a display device context (dc) for the
        'client area of the specified window (here the desktop).
        hdc = getdc(%hwnd_desktop)
        '
        'retrieves device-specific information about the number
        'of pixels per logical inch along the screen height
        '(depends on screen resolution setting).
        'this is important to define appropriate font sizes.
        logpixelsy  = getdevicecaps(hdc, %logpixelsy)
        '
        releasedc %hwnd_desktop, hdc
        '
        exampleflag=0
        fono=-1
        do
          dialog doevents to count&
        loop until count&=0
        if fono>=0 then call fontdelete()
        deleteobject brush
    end function
    ' *************************************************************
    sub showdialog_form1(byval hparent&)
        local style&, exstyle&,hctl&
        style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center or %ws_clipchildren
        ' nb: the clipchildren style must be included
        exstyle& = 0
        x&=396:y&=266
        dialog new hparent&, "choose font dialog demonstration", 0, 0,  x&, y&, style&, exstyle& to hform1&
        control add label, hform1&,  %form1_label1,  "your chosen font will be used in the edit box below."+ _
        " you may edit this text as you wish." , 2, 178, x&-4, 10, _
            %ws_child or %ws_visible
        dialog units hform1&, x&, y& to pixels x1&, y1&
        ' the graphics routines use pixels. hence this conversion.
        control add label, hform1&, %form1_static1, ", 0, 0, x&,174, _
            %ws_child or %ws_visible or %ss_grayframe or %ss_left
            ' nb: the grayframe style must be included
        control handle hform1&, %form1_static1 to hgraph ' handle for graphics window
        control add textbox, hform1&,  %form1_text1,  "the font in this edit box is changed according to your choice "+ _
            "using the choose font dialog.", 0,188, x&, 52, _
            %ws_child or %ws_visible or %es_left or %es_multiline or %ws_vscroll or %ws_tabstop, _
            %ws_ex_clientedge
        control add "button", hform1&,  %form1_button3,  "example &1", 10, 248, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_button3
        control add "button", hform1&,  %form1_button4,  "example &2", 60, 248, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_button4
        control add "button", hform1&,  %form1_button5,  "example &3", 110, 248, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_button5
        control add "button", hform1&,  %form1_button1,  "choose &font", 160, 248, 176, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_button1
        control add "button", hform1&,  %form1_button2,  "&end", 346, 248, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_button2
        control set focus hform1&,%form1_text1
        dialog show modeless hform1& , call form1_dlgproc
    end sub
    ' *************************************************************
    callback function form1_dlgproc
        local hdc as long
        ' get rectangle in label (static) control
        getclientrect hgraph,rct
        select case cbmsg
            case %wm_paint
              hdc = beginpaint(cbhndl, ps)
              ' obtain handle of the static label control
              hdc = getdc(getdlgitem(cbhndl, %form1_static1))
              select case exampleflag
                  case 0: call textgraphics0(hdc)
                  case 1: call textgraphics1(hdc)
                  case 2: call textgraphics2(hdc)
                  case 3: call textgraphics3(hdc)
              end select
              endpaint cbhndl, ps
              releasedc getdlgitem(cbhndl, %form1_static1), hdc
              function = 1
            ' -----------------------------------------------
            case %wm_ctlcolormsgbox , %wm_ctlcolorbtn, %wm_ctlcoloredit,_
                 %wm_ctlcolorstatic, %wm_ctlcolorscrollbar, %wm_ctlcolorlistbox
                ' control colors
                select case getdlgctrlid(cblparam)
                    case  %form1_text1
                        settextcolor cbwparam, cf.rgbcolors
                        function=brush
                    case else
                        function=0
                end select
            case else
        end select
    end function
    ' -------------------------------------------------------------
    callback function cbf_form1_button1
        local hctl&, res&
        control handle hform1&,%form1_text1 to hctl&
        res&=choosecurrentfont (hform1&)
    end function
    ' ------------------------------------------------
    callback function cbf_form1_button3
        local res&
        exampleflag=1
        res&=invalidaterect(hform1&,rct,%true)
    end function
    ' ------------------------------------------------
    callback function cbf_form1_button4
        local res&
        exampleflag=2
        res&=invalidaterect(hform1&,rct,%true)
    end function
    ' ------------------------------------------------
    callback function cbf_form1_button5
        local res&
        exampleflag=3
        res&=invalidaterect(hform1&,rct,%true)
    end function
    ' ------------------------------------------------
    callback function cbf_form1_button2
        dialog end cbhndl
    end function
    ' ------------------------------------------------
    ' ------------------------------------------------
    function makefont(byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long,byval strikeout as long, _
        byval facename as string) as long
    ' -----------------------
        'type logfont defines the attributes of a font.
        'see logfont in the win32 help file
        lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) '-(fonttypesize * logpixelsy) \ 72
                                                ' logical height of font
        lffont.lfwidth = 0                      ' logical average character width
        lffont.lfescapement = 0                 ' angle of escapement
        lffont.lforientation = 0                ' base-line orientation angle
        lffont.lfweight = fontweight            ' font weight
        lffont.lfitalic = italic                ' italic attribute flag
        lffont.lfunderline = underline          ' underline attribute flag
        lffont.lfstrikeout = strikeout          ' strikeout attribute flag
        lffont.lfcharset = %ansi_charset        ' character set identifier
        lffont.lfoutprecision = %out_tt_precis  ' output precision
        lffont.lfclipprecision = %clip_default_precis  ' clipping precision
        lffont.lfquality = %default_quality     ' output quality
        lffont.lfpitchandfamily = %ff_dontcare  ' pitch and family
        lffont.lffacename = facename            ' typeface name string
    ' -----------------------
        ' make font according to specifications
        function = createfontindirect (lffont)
    end function
    ' ------------------------------------------------
    ' ------------------------------------------------
    function choosecurrentfont(byval hwnd as long) as long
      local t$,red&,green&,blue&,res&,rescf&
      static hfontnew as long
      local  fonttypesize as long
      'update previous text font setting in font dialog box
      textfont=makefont(fosize,foweight,foital,founl,fostout,foface)
      'delete this font which is not going to be used otherwise
      call deleteobject(textfont)
    
      'from the win32 help file:
      'type choosefontapi  ' a type structure containing information about the font
                           ' see choosefont in the win32 help file
      '  lstructsize    as long   ' length in bytes of the structure
      '  hwndowner      as long   ' the handle of the dialog box
      '  hdc            as long   ' device context of printer (only if printer font flag is set)
      '  lplogfont      as logfont ptr  ' pointer to a logfont structure
      '  ipointsize     as long   ' specifies font size in units of 1/10 of a point
      '  flags          as long   ' flags (see above) used to initialize the dialog box.
                                  ' on return flags are set to indicate the user's input
      '  rgbcolors      as long   ' specifies text color if the %cf_effects flag is set
      '  lcustdata      as long   ' specifies application-defined data passed to hook procedure
      '  lpfnhook       as dword  ' pointer to a hook procedure processing messages for the dialog
      '  lptemplatename as asciiz ptr ' pointer to a dialog template resource
      '  hinstance      as long   ' handle of memory object containing a dialog box template
      '  lpszstyle      as asciiz ptr ' pointer to a buffer that contains style data
      '  nfonttype      as word   ' type of selected font on return (regular, bold, italic, etc.)
      '  alignment      as word   ' missing! i.e. not used ?
      '  nsizemin       as long   ' specifies the minimum point size a user can select (if %cf_limitsize is set)
      '  nsizemax       as long   ' specifies the maximum point size a user can select (if %cf_limitsize is set)
      'end type
    
      cf.lstructsize    = sizeof(cf)
      cf.hwndowner      = hwnd
      cf.hdc            = %null
      cf.lplogfont      = varptr(lffont) ' type logfont
      cf.ipointsize     = 0
      cf.flags          = %cf_inittologfontstruct or %cf_screenfonts or %cf_effects
      'cf.rgbcolors      = 0  'black. new selected color is returned from choosefont.
      cf.lcustdata      = 0
      cf.lpfnhook       = %null
      cf.lptemplatename = %null
      cf.hinstance      = %null
      cf.lpszstyle      = %null
      cf.nfonttype      = 0  'returned from choosefont
      cf.nsizemin       = 0  'returned from choosefont
      cf.nsizemax       = 0  'returned from choosefont
    
      rescf& = choosefont (cf) ' call to the win32api font dialog box
      if rescf&>0 then ' ok pressed
          'provides a pointer to the font information structure
          'cf.rgbcolors now contains the rgb value of the chosen color
          ' ----------------------
          incr fono
          redim preserve fontno&(0,fono)  ' this array collects the fonts chosen
          fontno&(fono)=createfontindirect (lffont) ' create font according to specification
          ' you may use this font array in your own applications
          textfont = fono ' currently selected font for edit box
          ' ----------------------
          control handle hform1&,%form1_text1 to hedit
          call sendmessage (hedit, %wm_setfont, fontno&(textfont), 0) ' send font to control
          call sendmessage (hedit, %em_setsel, -1, 0) ' deselect text in control
          ' -------------
          red& =    cf.rgbcolors mod 256
          green& = (cf.rgbcolors\256) mod 256
          blue& =  (cf.rgbcolors\256^2) mod 256
          ' -------------
          ' you can back calculate the fonttypesize from lffont.lfheight
          ' using this relation:
          fonttypesize = int(-lffont.lfheight * 72 / logpixelsy + 0.5)
          t$="fonttypesize: "   +str$(fonttypesize)            +$crlf+$crlf+ _
             "height: "         +str$(lffont.lfheight)         +$crlf+ _
             "width: "          +str$(lffont.lfwidth)          +$crlf+ _
             "escapement: "     +str$(lffont.lfescapement)     +$crlf+ _
             "orientation: "    +str$(lffont.lforientation)    +$crlf+ _
             "weight: "         +str$(lffont.lfweight)         +$crlf+ _
             "italic: "         +str$(lffont.lfitalic)         +$crlf+ _
             "underline: "      +str$(lffont.lfunderline)      +$crlf+ _
             "strikeout: "      +str$(lffont.lfstrikeout)      +$crlf+ _
             "charset: "        +str$(lffont.lfcharset)        +$crlf+ _
             "outprecision: "   +str$(lffont.lfoutprecision)   +$crlf+ _
             "clipprecision: "  +str$(lffont.lfclipprecision)  +$crlf+ _
             "quality: "        +str$(lffont.lfquality)        +$crlf+ _
             "pitchandfamily: " +str$(lffont.lfpitchandfamily) +$crlf+ _
             "facename: "       +lffont.lffacename             +$crlf+$crlf+ _
             "color: &h"+hex$(cf.rgbcolors,6)+"  =  "+format$(cf.rgbcolors,"########")+ _
             "  =  rgb("+format$(red&)+","+format$(green&)+","+format$(blue&)+")"
          msgbox t$,%mb_iconinformation,"logfont data + color"
          ' remember selection data:
          fosize=fonttypesize
          foweight=lffont.lfweight
          foital=lffont.lfitalic
          founl=lffont.lfunderline
          fostout=lffont.lfstrikeout
          foface=lffont.lffacename
      end if
      control handle hform1&,%form1_text1 to hedit
      call sendmessage (hedit, %em_setsel, -1, 0) ' deselect text in control
      res&=invalidaterect(%null,rct,%true)
      exampleflag=-1
      function = rescf&
    end function
    ' -------------------------
    ' -------------------------
    'from the win32 help file:
    'type textmetric
    '  tmheight as long           ' total height of font ********** used
    '  tmascent as long           ' height above base line
    '  tmdescent as long          ' length of descenders
    '  tminternalleading as long  ' space above characters
    '  tmexternalleading as long  ' space between rows   ********** used
    '  tmavecharwidth as long     ' average width
    '  tmmaxcharwidth as long     ' maximum width
    '  tmweight as long           ' weight
    '  tmoverhang as long         ' extra width added to special fonts
    '  tmdigitizedaspectx as long ' horizontal aspect
    '  tmdigitizedaspecty as long ' vertical aspect
    '  tmfirstchar as byte        ' first character in font
    '  tmlastchar as byte         ' last character in font
    '  tmdefaultchar as byte      ' default character
    '  tmbreakchar as byte        ' character used to break words
    '  tmitalic as byte           ' nonzero if italic
    '  tmunderlined as byte       ' nonzero if underlined
    '  tmstruckout as byte        ' nonzero if struck out
    '  tmpitchandfamily as byte   ' pitch and family of font
    '  tmcharset as byte          ' character set identifier
    'end type
    
    'type sizel
    '  cx as long
    '  cy as long
    'end type
    ' ----------------------------------
    ' ----------------------------------
    sub showtext1(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
        dim lpsz as asciiz * 255
        local currentfont as long
        local i%,j%,yd&,res&,xl&,flag&
    
        currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
    
        selectobject hdc, currentfont ' select font for the static control
        res&=settextcolor(hdc, txcol&)
        res& = gettextmetrics(hdc,tm) ' fills the specified buffer in the
                                      ' textmetrics structure with the
                                      ' metrics for the currently selected font.
        ' vertical extension (yd&)= character height + space between lines
        yd& = tm.tmheight + tm.tmexternalleading
    again:
        xl&=xx&
        flag&=0
        for i%=1 to len(textstr)
            lpsz=mid$(textstr,i%,1)
            'computes the width and height of the specified string.
            res&=gettextextentpoint32(hdc,lpsz,1,lpsize)
            xl&=xl&+lpsize.cx
            ' if string goes past right margin
            if xl& >= x1& then flag=2:exit for
        next
        if flag&=2 then
            ' go backwards to closest space (chr$(32))
            for j%=i% to 1 step -1
                if asc(textstr,j%)=32 then flag=3 : exit for ' space found
            next
        end if
        if flag&=3 then
            if j%=1 then
                ' first space found at position one - do not print
                lpsz=" : flag=1
            else
                ' use string only up to the identified space position
                lpsz=left$(textstr,j%-1)
            end if
            if flag&=3 then ' space found after position one
                ' print string up to space
                textout hdc, xx&,yy&, lpsz, byval len(lpsz)
                ' now concentrate on subsequent part of string
                textstr=mid$(textstr,j%+1)
                ' starting point of new line
                yy&=yy&+yd&:xx&=5
                ' repeat procedure
                goto again
            else ' space at position one
                ' goto new line
                yy&=yy&+yd&:xx&=5
                ' remove leading space(s)
                textstr=ltrim$(textstr)
                ' repeat procedure on next line
                goto again
            end if
        else
            if flag&=2 then yy&=yy&+yd& : xx&=5 ' new line; starting point
            lpsz=textstr
            ' get dimensions of string
            res&=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
            ' print string
            textout hdc, xx&,yy&, lpsz, byval len(lpsz)
            ' move to new x-position
            xx&=xx&+lpsize.cx
        end if
        call deleteobject(currentfont) ' delete font
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub showtext2(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
        dim lpsz as asciiz * 255
        local currentfont as long
        local i%,j%,yd&,res&
    
        currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
    
        selectobject hdc, currentfont ' select font for the static control
        res&=settextcolor(hdc, txcol&)
        res& = gettextmetrics(hdc,tm)
        ' vertical extension (yd&)= character height + space between lines
        yd& = tm.tmheight + tm.tmexternalleading
        lpsz=textstr
        textout hdc, xx&,yy&, lpsz, byval len(lpsz)
        if textstr=" then textfont=currentfont ' initial font for edit control
                                                       ' see last line in sub textgraphics0
        call deleteobject (currentfont) ' delete font
        ' go one line down
        yy&=yy&+yd&
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub showtext3(byval hdc as long,byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long, _
        byval facename as string,byval textstr as string,byref xx&,byref yy&,byref txcol&)
        dim lpsz as asciiz * 255
        local currentfont as long
        local i&,i2&,j&,j2&,res&,radius&,radian!,radian2!,xr&,yr&,yd&,korr!,xr2&,yr2&
        static before as long, fontstrt as long
    
        currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
    
        selectobject hdc, currentfont ' select font for the static control
        res&=settextcolor(hdc, txcol&)
        res& = gettextmetrics(hdc,tm)
        yd& = tm.tmheight/2       ' half of character heights
        lpsz=textstr
        res&=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
        radius&=lpsize.cx/2       ' half of string length
        korr!=atn(yd&/radius&)    ' correction needed to make string rotate
                                  ' around its centre
        call deleteobject (currentfont) ' delete font. not used further here.
        if before <> 1 then ' if calling this routine for the first time then:
            fontstrt = fono+1
            fono = fono + 73
            redim preserve fontno&(0,fono)
            for i&=3600 to 0 step -50
                lffont.lfescapement = i& ' this defines the angle of the text
                ' put font in font array
                fontno&(fontstrt+i&/50) = createfontindirect (lffont)
            next
            before = 1
        end if
        ' make string rotate
        j&=fontstrt+72 ' index for font for red and blue text
        for i&=3600 to 0 step -50 ' one 360 degrees rotation
            radian!=i&*0.00174533-korr! ' radian for blue and red text
            i2&=6300-i&
            if i2&>=3600 then i2&=i2&-3600
            j2&=fontstrt + i2&/50         ' index for font for green text
            radian2!=i2&*0.00174533-korr! ' radian for green text
            ' -----------------------------------
            xr&=xx&-radius&*cos(radian!)  ' start coordinates for
            yr&=yy&+radius&*sin(radian!)  ' red text
            ' -----------------------------------
            xr2&=2*xx&-radius&*cos(radian2!) ' start coordinates for
            yr2&=yy&+radius&*sin(radian2!)   ' green text
            ' -----------------------------------
            selectobject hdc, fontno&(j&) ' select font from font array
            res&=settextcolor(hdc, txcol&)
            textout hdc, xr&,yr&, lpsz, byval len(lpsz) ' print red text
            res&=settextcolor(hdc, rgb(0,0,255)) ' blue
            textout hdc, xr&+2*xx&,yr&, lpsz, byval len(lpsz) ' print blue text
            selectobject hdc, fontno&(j2&) ' select font from font array
            res&=settextcolor(hdc, rgb(0,160,0)) ' green
            textout hdc, xr2&,yr2&, lpsz, byval len(lpsz) ' print green text
            sleep 80
            if i&>0 then
                res&=settextcolor(hdc, rgb(255,255,255)) ' use white to erase text
                textout hdc, xr2&,yr2&, lpsz, byval len(lpsz) ' erase green text
                selectobject hdc, fontno&(j&) ' select font from font array
                textout hdc, xr&,yr&, lpsz, byval len(lpsz) ' erase red text
                textout hdc, xr&+2*xx&,yr&, lpsz, byval len(lpsz) ' erase blue text
                decr j& ' decrease index for font for blue and red text
            end if
        next
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub textgraphics0(hdc as long)
        local xx&,yy&,hedit as long
        fillrect hdc, rct, getstockobject(%white_brush)
        settextalign hdc,%ta_center '%ta_left
        xx&=x1&/2.4:yy&=y1/10
        call showtext2(hdc,134,1000,1,0,"edwardian script itc","welcome!",xx&,yy&,rgb(0,0,255))
        ' create start font for font dialog box
        fosize=12:foweight=400:foital=0:founl=0:fostout=0:foface="arial"
        textfont=makefont(fosize,foweight,foital,founl,fostout,foface)
        selectobject hdc, textfont
        control handle hform1&,%form1_text1 to hedit
        call sendmessage (hedit, %wm_setfont, textfont, 0) ' send font to control
        call deleteobject (textfont)
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub textgraphics1(hdc as long)
        local res&
        dim gtext as asciiz * 255
        local xx&,yy&,t$
        local extraspace&
        fillrect hdc, rct, getstockobject(%white_brush)
        settextalign hdc,%ta_left  ' %ta_center
        xx&=5:yy&=3
        t$="this program demonstrates the use of the "
        call showtext1(hdc,14,400,0,0,"arial",t$,xx&,yy&,8388608)
        t$="font common dialog box"
        call showtext1(hdc,14,700,1,1,"arial",t$,xx&,yy&,255)
        t$=" and the application of "
        call showtext1(hdc,14,400,0,0,"arial",t$,xx&,yy&,8388608)
        t$="various fonts "
        call showtext1(hdc,14,700,1,1,"arial",t$,xx&,yy&,32768)
        t$="in the same control. since text boxes (edit controls) do not allow "+ _
           "more than one font at a given time, a "
        call showtext1(hdc,14,400,0,0,"arial",t$,xx&,yy&,8388608)
        t$="label control (or static control)"
        call showtext1(hdc,14,1000,0,1,"arial",t$,xx&,yy&,16711680)
        t$=" is being applied as originally suggested for graphic purposes by lance edmonds in "+ _
           "the powerbasic forum. this limitation of edit controls implies that whenever "+ _
           "more different fonts and font sizes are being applied at a given time as in the "+ _
           "advanced word processors (e.g. word or wordperfect), the affair is being "+ _
           "managed using static controls in a very complex way. this may explain the "+ _
           "slowness of these programs in apparently simple tasks. "
        call showtext1(hdc,14,400,0,0,"arial",t$,xx&,yy&,8388608)
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub textgraphics2(hdc as long)
        local res&
        dim gtext as asciiz * 255
        local xx&,yy&
        local extraspace&
        fillrect hdc, rct, getstockobject(%white_brush)
        settextalign hdc,%ta_center '%ta_left
        extraspace&=5
        xx&=x1&/2:yy&=3
        call showtext2(hdc,11,700,1,0,"papyrus","some grooks by the danish poet piet hein",xx&,yy&,8388736)
        yy&=yy&+extraspace&
        call showtext2(hdc,7,700,0,0,"papyrus","1. problems",xx&,yy&,0)
        call showtext2(hdc,11,600,0,0,"tempus sans itc","problems worthy of attack - prove their worth by hitting back.",xx&,yy&,210)
        yy&=yy&+extraspace&
        call showtext2(hdc,7,700,0,0,"papyrus","2. that is the question - hamlet anno dominy.",xx&,yy&,0)
        call showtext2(hdc,12,700,0,0,"tempus sans itc","co-existence - or no existence.",xx&,yy&,rgb(0,96,0))
        yy&=yy&+extraspace&
        call showtext2(hdc,7,700,0,0,"papyrus","3. losing face",xx&,yy&,0)
        call showtext2(hdc,11,400,0,0,"klang mt","the noble art of losing face",xx&,yy&,16711680)
        call showtext2(hdc,11,400,0,0,"klang mt","may one day save the human race",xx&,yy&,16711680)
        call showtext2(hdc,11,400,0,0,"klang mt","and turn into eternal merit",xx&,yy&,16711680)
        call showtext2(hdc,11,400,0,0,"klang mt","what weaker minds would call disgrace.",xx&,yy&,16711680)
        yy&=yy&+extraspace&
        call showtext2(hdc,7,700,0,0,"papyrus","4. i'd like -",xx&,yy&,0)
        call showtext2(hdc,11,400,0,0,"eras medium itc","i'd like to know - what this whole show - is all about",xx&,yy&,8421376)
        call showtext2(hdc,11,400,0,0,"eras medium itc","before it's out",xx&,yy&,8421376)
        yy&=yy&+extraspace&
        call showtext2(hdc,6,400,0,0,"arial","sources: http://home4.inet.tele.dk/tuborg/grooks.htm   -  http://www.cs.rice.edu/~ssiyer/minstrels/poems/668.html  - <a href="http://hjem.get2net.dk/san/grooks.html",xx&,yy&,8388608)" target=_blank>http://hjem.get2net.dk/san/grooks.html",xx&,yy&,8388608)</a> 
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub textgraphics3(hdc as long)
        local res&
        dim gtext as asciiz * 255
        local xx&,yy&,t$
        fillrect hdc, rct, getstockobject(%white_brush)
        settextalign hdc,%ta_left
        xx&=x1&/4:yy&=y1&/3.4
        t$="rotating text"
        call showtext3(hdc,31,400,0,0,"arial",t$,xx&,yy&,255)
    end sub
    ' ----------------------------------
    ' ----------------------------------
    sub fontdelete () ' delete font before ending
      local i as long
      for i=0 to fono
          call deleteobject (fontno&(i&))
      next
    end sub



    [this message has been edited by erik christensen (edited june 26, 2002).]

  • #2
    June 23, 2003. Adjustments have been made. The program now runs
    both with PB Win 6 and 7.

    Regards,

    Erik


    ------------------

    Comment


    • #3
      ' This is an updated version, which also works with PBWin10.

      ' Best regards,

      ' Erik

      Code:
      ' This is an updated version, which also works with PBWin10. :)
      
      ' Best regards,
      
      ' Erik
      
      #COMPILE EXE
      #REGISTER NONE
      #DIM ALL
      
      %noanimate    = 1
      %nobutton     = 1
      %nocombo      = 1
      %nodraglist   = 1
      %noheader     = 1
      %noimagelist  = 1
      %nolist       = 1
      %notrackbar   = 1
      
      #INCLUDE "win32api.inc"
      #INCLUDE "commctrl.inc"
      #INCLUDE "comdlg32.inc"
      
      %form1_label1             = 100
      %form1_static1            = 105
      %form1_text1              = 110
      %form1_button1            = 115
      %form1_button2            = 120
      %form1_button3            = 125
      %form1_button4            = 130
      %form1_button5            = 135
      
      ' --------------------------------------------------
      GLOBAL fosize AS LONG,foweight AS LONG,foital AS LONG,founl AS LONG,fostout AS LONG,foface AS STRING
      GLOBAL hform1&             ' dialog handle
      GLOBAL hfont      AS LONG
      GLOBAL lffont AS logfont   ' logfont structure
      GLOBAL cf AS choosefontapi ' choosefont structure
      GLOBAL hedit AS LONG
      GLOBAL hgraph AS LONG
      GLOBAL tm AS textmetric    ' textmetric structure
      GLOBAL lpsize AS sizel
      GLOBAL fontno&()           ' array of fonts
      GLOBAL fono    AS LONG     ' number of fonts in array (zero based)
      GLOBAL x&,y&,x1&,y1&
      GLOBAL rct AS rect
      GLOBAL ps AS paintstruct   ' paint structure
      GLOBAL brush AS LONG
      GLOBAL exampleflag AS LONG
      GLOBAL textfont AS LONG
      
      ' *************************************************************
      FUNCTION PBMAIN
          LOCAL count&
          LOCAL hdc AS LONG
          LOCAL cc1 AS init_common_controlsex
          cc1.dwsize=SIZEOF(cc1)
          cc1.dwicc=%icc_win95_classes
          initcommoncontrolsex cc1
          brush=createsolidbrush(RGB(255,255,255)) ' white brush
          showdialog_form1 0
          exampleflag=0
          fono=-1
          DO
            DIALOG DOEVENTS TO count&
          LOOP UNTIL count&=0
          IF fono>=0 THEN CALL fontdelete()
          deleteobject brush
      END FUNCTION
      ' *************************************************************
      SUB showdialog_form1(BYVAL hparent&)
          LOCAL style&, exstyle&,hctl&, hedit&
          style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
          ' nb: the clipchildren style must be included
          exstyle& = 0
          x&=396*2:y&=266*2
          x1& = x& : y1& = y&
          DIALOG NEW PIXELS, hparent&, "Choose font dialog demonstration", 0, 0,  x&, y&, style&, exstyle& TO hform1&
          CONTROL ADD TEXTBOX, hform1&,  %form1_text1,  "The font in this text box is changed according to your choice "+ _
              "using the choose font dialog."+$CRLF, 0,188*2, x&, 52*2, _
              %WS_CHILD OR %WS_VISIBLE OR %ES_LEFT OR %ES_MULTILINE OR %WS_VSCROLL OR %WS_TABSTOP, _
              %WS_EX_CLIENTEDGE
          CONTROL ADD LABEL, hform1&,  %form1_label1,  "Your chosen font will be used in the text box below."+ _
          " You may edit the text as you wish." , 2*2, 178*2, x&*2-4*2, 10*2, _
              %WS_CHILD OR %WS_VISIBLE
          CONTROL ADD LABEL, hform1&, %form1_static1, "", 0, 0, x&,174*2, _
              %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
              ' nb: the grayframe style must be included
          CONTROL HANDLE hform1&, %form1_static1 TO hgraph ' handle for graphics window
          CONTROL ADD "button", hform1&,  %form1_button3,  "Example &1", 10*2, 248*2, 40*2, 12*2, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL cbf_form1_button3
          CONTROL ADD "button", hform1&,  %form1_button4,  "Example &2", 60*2, 248*2, 40*2, 12*2, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL cbf_form1_button4
          CONTROL ADD "button", hform1&,  %form1_button5,  "Example &3", 110*2, 248*2, 40*2, 12*2, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL cbf_form1_button5
          CONTROL ADD "button", hform1&,  %form1_button1,  "Choose &font", 160*2, 248*2, 176*2, 12*2, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL cbf_form1_button1
          CONTROL ADD "button", hform1&,  %form1_button2,  "&End", 346*2, 248*2, 40*2, 12*2, _
              %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL cbf_form1_button2
          exampleflag = 0
          CONTROL SET FOCUS hform1&, %form1_button3
          DIALOG SHOW MODELESS hform1& , CALL form1_dlgproc
      END SUB
      ' *************************************************************
      CALLBACK FUNCTION form1_dlgproc
          LOCAL hdc AS LONG
          ' get rectangle in label (static) control
          SELECT CASE AS LONG CB.MSG
              CASE %WM_INITDIALOG
              getclientrect hgraph,rct
      '    SELECT CASE CBMSG
              CASE %WM_PAINT
                hdc = beginpaint(CBHNDL, ps)
                ' obtain handle of the static label control
                hdc = getdc(getdlgitem(CBHNDL, %form1_static1))
                SELECT CASE exampleflag
                    CASE 0: CALL textgraphics0(hdc)
                    CASE 1: CALL textgraphics1(hdc)
                    CASE 2: CALL textgraphics2(hdc)
                    CASE 3: CALL textgraphics3(hdc)
                END SELECT
                endpaint CBHNDL, ps
                releasedc getdlgitem(CBHNDL, %form1_static1), hdc
                FUNCTION = 1
              ' -----------------------------------------------
              CASE %wm_ctlcolormsgbox , %wm_ctlcolorbtn, %wm_ctlcoloredit,_
                   %wm_ctlcolorstatic, %wm_ctlcolorscrollbar, %wm_ctlcolorlistbox
                  ' control colors
                  SELECT CASE getdlgctrlid(CBLPARAM)
                      CASE  %form1_text1
                          settextcolor CBWPARAM, cf.rgbcolors
                          FUNCTION=brush
                      CASE ELSE
                          FUNCTION=0
                  END SELECT
              CASE ELSE
          END SELECT
      END FUNCTION
      ' -------------------------------------------------------------
      CALLBACK FUNCTION cbf_form1_button1
          LOCAL hctl&, res&
          CONTROL HANDLE hform1&,%form1_text1 TO hctl&
          res&=choosecurrentfont (hform1&)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION cbf_form1_button3
          LOCAL res&
          exampleflag=1
          res&=invalidaterect(hform1&,rct,%true)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION cbf_form1_button4
          LOCAL res&
          exampleflag=2
          res&=invalidaterect(hform1&,rct,%true)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION cbf_form1_button5
          LOCAL res&
          exampleflag=3
          res&=invalidaterect(hform1&,rct,%true)
      END FUNCTION
      ' ------------------------------------------------
      CALLBACK FUNCTION cbf_form1_button2
          DIALOG END CBHNDL
      END FUNCTION
      ' ------------------------------------------------
      ' ------------------------------------------------
      FUNCTION makefont(BYVAL fonttypesize AS LONG,BYVAL fontweight AS LONG, _
          BYVAL italic AS LONG, BYVAL underline AS LONG,BYVAL strikeout AS LONG, _
          BYVAL facename AS STRING) AS LONG
      
          lffont.lfheight = fonttypesize          ' height of font
          lffont.lfwidth = 0                      ' logical average character width
          lffont.lfescapement = 0                 ' angle of escapement
          lffont.lforientation = 0                ' base-line orientation angle
          lffont.lfweight = fontweight            ' font weight
          lffont.lfitalic = italic                ' italic attribute flag
          lffont.lfunderline = underline          ' underline attribute flag
          lffont.lfstrikeout = strikeout          ' strikeout attribute flag
          lffont.lfcharset = %ansi_charset        ' character set identifier
          lffont.lfoutprecision = %out_tt_precis  ' output precision
          lffont.lfclipprecision = %clip_default_precis  ' clipping precision
          lffont.lfquality = %default_quality     ' output quality
          lffont.lfpitchandfamily = %ff_dontcare  ' pitch and family
          lffont.lffacename = facename            ' typeface name string
      ' -----------------------
          ' make font according to specifications
          FUNCTION = createfontindirect (lffont)
      END FUNCTION
      ' ------------------------------------------------
      ' ------------------------------------------------
      FUNCTION choosecurrentfont(BYVAL hwnd AS LONG) AS LONG
        LOCAL t$,red&,green&,blue&,res&,rescf&
        STATIC hfontnew AS LONG
        LOCAL  fonttypesize AS LONG
        'update previous text font setting in font dialog box
        textfont=makefont(fosize,foweight,foital,founl,fostout,foface)
        'delete this font which is not going to be used otherwise
        CALL deleteobject(textfont)
      
        'from the win32 help file:
        'type choosefontapi               ' a type structure containing information about the font
                                          ' see choosefont in the win32 help file
        '  lstructsize    as long         ' length in bytes of the structure
        '  hwndowner      as long         ' the handle of the dialog box
        '  hdc            as long         ' device context of printer (only if printer font flag is set)
        '  lplogfont      as logfont ptr  ' pointer to a logfont structure
        '  ipointsize     as long         ' specifies font size in units of 1/10 of a point
        '  flags          as long         ' flags (see above) used to initialize the dialog box.
                                          ' on return flags are set to indicate the user's input
        '  rgbcolors      as long         ' specifies text color if the %cf_effects flag is set
        '  lcustdata      as long         ' specifies application-defined data passed to hook procedure
        '  lpfnhook       as dword        ' pointer to a hook procedure processing messages for the dialog
        '  lptemplatename as asciiz ptr   ' pointer to a dialog template resource
        '  hinstance      as long         ' handle of memory object containing a dialog box template
        '  lpszstyle      as asciiz ptr   ' pointer to a buffer that contains style data
        '  nfonttype      as word         ' type of selected font on return (regular, bold, italic, etc.)
        '  alignment      as word         ' missing! i.e. not used ?
        '  nsizemin       as long         ' specifies the minimum point size a user can select (if %cf_limitsize is set)
        '  nsizemax       as long         ' specifies the maximum point size a user can select (if %cf_limitsize is set)
        'end type
      
        cf.lstructsize    = SIZEOF(cf)
        cf.hwndowner      = hwnd
        cf.hdc            = %null
        cf.lplogfont      = VARPTR(lffont) ' type logfont
        cf.ipointsize     = 0
        cf.flags          = %CF_INITTOLOGFONTSTRUCT OR %CF_SCREENFONTS OR %CF_EFFECTS
        'cf.rgbcolors      = 0  'black. new selected color is returned from choosefont.
        cf.lcustdata      = 0
        cf.lpfnhook       = %null
        cf.lptemplatename = %null
        cf.hinstance      = %null
        cf.lpszstyle      = %null
        cf.nfonttype      = 0  'returned from choosefont
        cf.nsizemin       = 0  'returned from choosefont
        cf.nsizemax       = 0  'returned from choosefont
      
        rescf& = choosefont (cf) ' call to the win32api font dialog box
        IF rescf&>0 THEN ' ok pressed
            'provides a pointer to the font information structure
            'cf.rgbcolors now contains the rgb value of the chosen color
            ' ----------------------
            INCR fono
            REDIM PRESERVE fontno&(0,fono)  ' this array collects the fonts chosen
            fontno&(fono)=createfontindirect (lffont) ' create font according to specification
            ' you may use this font array in your own applications
            textfont = fono ' currently selected font for edit box
            ' ----------------------
            CONTROL HANDLE hform1&,%form1_text1 TO hedit
            CALL sendmessage (hedit, %wm_setfont, fontno&(textfont), 0) ' send font to control
            CALL sendmessage (hedit, %em_setsel, -1, 0) ' deselect text in control
            ' -------------
            red& =    cf.rgbcolors MOD 256
            green& = (cf.rgbcolors\256) MOD 256
            blue& =  (cf.rgbcolors\256^2) MOD 256
            ' -------------
            ' you can back calculate the fonttypesize from lffont.lfheight
            ' using this relation:
            fonttypesize = INT(lffont.lfheight + 0.5)
            t$="fonttypesize: "   +STR$(fonttypesize)            +$CRLF+$CRLF+ _
               "height: "         +STR$(lffont.lfheight)         +$CRLF+ _
               "width: "          +STR$(lffont.lfwidth)          +$CRLF+ _
               "escapement: "     +STR$(lffont.lfescapement)     +$CRLF+ _
               "orientation: "    +STR$(lffont.lforientation)    +$CRLF+ _
               "weight: "         +STR$(lffont.lfweight)         +$CRLF+ _
               "italic: "         +STR$(lffont.lfitalic)         +$CRLF+ _
               "underline: "      +STR$(lffont.lfunderline)      +$CRLF+ _
               "strikeout: "      +STR$(lffont.lfstrikeout)      +$CRLF+ _
               "charset: "        +STR$(lffont.lfcharset)        +$CRLF+ _
               "outprecision: "   +STR$(lffont.lfoutprecision)   +$CRLF+ _
               "clipprecision: "  +STR$(lffont.lfclipprecision)  +$CRLF+ _
               "quality: "        +STR$(lffont.lfquality)        +$CRLF+ _
               "pitchandfamily: " +STR$(lffont.lfpitchandfamily) +$CRLF+ _
               "facename: "       +lffont.lffacename             +$CRLF+$CRLF+ _
               "color: &h"+HEX$(cf.rgbcolors,6)+"  =  "+FORMAT$(cf.rgbcolors,"########")+ _
               "  =  rgb("+FORMAT$(red&)+","+FORMAT$(green&)+","+FORMAT$(blue&)+")"
            MSGBOX t$,%MB_ICONINFORMATION,"logfont data + color"
            ' remember selection data:
            fosize=fonttypesize
            foweight=lffont.lfweight
            foital=lffont.lfitalic
            founl=lffont.lfunderline
            fostout=lffont.lfstrikeout
            foface=lffont.lffacename
        END IF
        CONTROL HANDLE hform1&,%form1_text1 TO hedit
        CALL sendmessage (hedit, %em_setsel, -1, 0) ' deselect text in control
        res&=invalidaterect(%null,rct,%true)
        exampleflag=-1
        FUNCTION = rescf&
      END FUNCTION
      ' -------------------------
      ' -------------------------
      'from the win32 help file:
      'type textmetric
      '  tmheight as long           ' total height of font ********** used
      '  tmascent as long           ' height above base line
      '  tmdescent as long          ' length of descenders
      '  tminternalleading as long  ' space above characters
      '  tmexternalleading as long  ' space between rows   ********** used
      '  tmavecharwidth as long     ' average width
      '  tmmaxcharwidth as long     ' maximum width
      '  tmweight as long           ' weight
      '  tmoverhang as long         ' extra width added to special fonts
      '  tmdigitizedaspectx as long ' horizontal aspect
      '  tmdigitizedaspecty as long ' vertical aspect
      '  tmfirstchar as byte        ' first character in font
      '  tmlastchar as byte         ' last character in font
      '  tmdefaultchar as byte      ' default character
      '  tmbreakchar as byte        ' character used to break words
      '  tmitalic as byte           ' nonzero if italic
      '  tmunderlined as byte       ' nonzero if underlined
      '  tmstruckout as byte        ' nonzero if struck out
      '  tmpitchandfamily as byte   ' pitch and family of font
      '  tmcharset as byte          ' character set identifier
      'end type
      
      'type sizel
      '  cx as long
      '  cy as long
      'end type
      ' ----------------------------------
      ' ----------------------------------
      SUB showtext1(BYVAL hdc AS LONG,BYVAL fonttypesize AS LONG,BYVAL fontweight AS LONG, _
          BYVAL italic AS LONG, BYVAL underline AS LONG, _
          BYVAL facename AS STRING,BYVAL textstr AS STRING,BYREF xx&,BYREF yy&,BYREF txcol&)
          DIM lpsz AS ASCIIZ * 255
          LOCAL currentfont AS LONG
          LOCAL i%,j%,yd&,res&,XL&,flag&
      
          currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
      
          selectobject hdc, currentfont ' select font for the static control
          res&=settextcolor(hdc, txcol&)
          res& = gettextmetrics(hdc,tm) ' fills the specified buffer in the
                                        ' textmetrics structure with the
                                        ' metrics for the currently selected font.
          ' vertical extension (yd&)= character height + space between lines
          yd& = tm.tmheight + tm.tmexternalleading
      again:
          XL&=xx&
          flag&=0
          FOR i%=1 TO LEN(textstr)
              lpsz=MID$(textstr,i%,1)
              'computes the width and height of the specified string.
              res&=gettextextentpoint32(hdc,lpsz,1,lpsize)
              XL&=XL&+lpsize.cx
              ' if string goes past right margin
              IF XL& >= x1& THEN flag=2:EXIT FOR
          NEXT
          IF flag&=2 THEN
              ' go backwards to closest space (chr$(32))
              FOR j%=i% TO 1 STEP -1
                  IF ASC(textstr,j%)=32 THEN flag=3 : EXIT FOR ' space found
              NEXT
          END IF
          IF flag&=3 THEN
              IF j%=1 THEN
                  ' first space found at position one - do not print
                  lpsz="" : flag=1
              ELSE
                  ' use string only up to the identified space position
                  lpsz=LEFT$(textstr,j%-1)
              END IF
              IF flag&=3 THEN ' space found after position one
                  ' print string up to space
                  textout hdc, xx&,yy&, lpsz, BYVAL LEN(lpsz)
                  ' now concentrate on subsequent part of string
                  textstr=MID$(textstr,j%+1)
                  ' starting point of new line
                  yy&=yy&+yd&:xx&=5
                  ' repeat procedure
                  GOTO again
              ELSE ' space at position one
                  ' goto new line
                  yy&=yy&+yd&:xx&=5
                  ' remove leading space(s)
                  textstr=LTRIM$(textstr)
                  ' repeat procedure on next line
                  GOTO again
              END IF
          ELSE
              IF flag&=2 THEN yy&=yy&+yd& : xx&=5 ' new line; starting point
              lpsz=textstr
              ' get dimensions of string
              res&=gettextextentpoint32(hdc,lpsz,BYVAL LEN(lpsz),lpsize)
              ' print string
              textout hdc, xx&,yy&, lpsz, BYVAL LEN(lpsz)
              ' move to new x-position
              xx&=xx&+lpsize.cx
          END IF
          CALL deleteobject(currentfont) ' delete font
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB showtext2(BYVAL hdc AS LONG,BYVAL fonttypesize AS LONG,BYVAL fontweight AS LONG, _
          BYVAL italic AS LONG, BYVAL underline AS LONG, _
          BYVAL facename AS STRING,BYVAL textstr AS STRING,BYREF xx&,BYREF yy&,BYREF txcol&)
          DIM lpsz AS ASCIIZ * 255
          LOCAL currentfont AS LONG
          LOCAL i%,j%,yd&,res&
      
          currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
      
          selectobject hdc, currentfont ' select font for the static control
          res&=settextcolor(hdc, txcol&)
          res& = gettextmetrics(hdc,tm)
          ' vertical extension (yd&)= character height + space between lines
          yd& = tm.tmheight + tm.tmexternalleading
          lpsz=textstr
          textout hdc, xx&,yy&, lpsz, BYVAL LEN(lpsz)
          IF textstr="" THEN textfont=currentfont ' initial font for edit control
                                                         ' see last line in sub textgraphics0
          CALL deleteobject (currentfont) ' delete font
          ' go one line down
          yy&=yy&+yd&
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB showtext3(BYVAL hdc AS LONG,BYVAL fonttypesize AS LONG,BYVAL fontweight AS LONG, _
          BYVAL italic AS LONG, BYVAL underline AS LONG, _
          BYVAL facename AS STRING,BYVAL textstr AS STRING,BYREF xx&,BYREF yy&,BYREF txcol&)
          DIM lpsz AS ASCIIZ * 255
          LOCAL currentfont AS LONG
          LOCAL i&,i2&,j&,j2&,res&,radius&,radian!,radian2!,xr&,yr&,yd&,korr!,xr2&,yr2&
          STATIC before AS LONG, fontstrt AS LONG
      
          currentfont=makefont(fonttypesize,fontweight,italic,underline,0,facename)
      
          selectobject hdc, currentfont ' select font for the static control
          res&=settextcolor(hdc, txcol&)
          res& = gettextmetrics(hdc,tm)
          yd& = tm.tmheight/2       ' half of character heights
          lpsz=textstr
          res&=gettextextentpoint32(hdc,lpsz,BYVAL LEN(lpsz),lpsize)
          radius&=lpsize.cx/2       ' half of string length
          korr!=ATN(yd&/radius&)    ' correction needed to make string rotate
                                    ' around its centre
          CALL deleteobject (currentfont) ' delete font. not used further here.
      
          IF before <> 1 THEN ' if calling this routine for the first time then:
              fontstrt = fono+1
              fono = fono + 73
              REDIM PRESERVE fontno&(0,fono)
              FOR i&=3600 TO 0 STEP -50
                  lffont.lfescapement = i& ' this defines the angle of the text
                  ' lffont.lforientation = i& ' Font orientation does not seem to work even with advanced graphics being set.
                  ' put font in font array
                  fontno&(fontstrt+i&/50) = createfontindirect (lffont)
              NEXT
              before = 1
          END IF
          ' make string rotate
          j&=fontstrt+72 ' index for font for red and blue text
          FOR i&=3600 TO 0 STEP -50 ' one 360 degrees rotation
              radian!=i&*0.00174533-korr! ' radian for blue and red text
              i2&=6300-i&
              IF i2&>=3600 THEN i2&=i2&-3600
              j2&=fontstrt + i2&/50         ' index for font for green text
              radian2!=i2&*0.00174533-korr! ' radian for green text
              ' -----------------------------------
              xr&=xx&-radius&*COS(radian!)  ' start coordinates for
              yr&=yy&+radius&*SIN(radian!)  ' red text
              ' -----------------------------------
              xr2&=2*xx&-radius&*COS(radian2!) ' start coordinates for
              yr2&=yy&+radius&*SIN(radian2!)   ' green text
              ' -----------------------------------
              selectobject hdc, fontno&(j&) ' select font from font array
              res&=settextcolor(hdc, txcol&)
              textout hdc, xr&,yr&, lpsz, BYVAL LEN(lpsz) ' print red text
      
              res&=settextcolor(hdc, RGB(0,0,255)) ' blue
              textout hdc, xr&+2*xx&,yr&, lpsz, BYVAL LEN(lpsz) ' print blue text
      
              res&=settextcolor(hdc, RGB(0,160,0)) ' green
              selectobject hdc, fontno&(j2&) ' select font from font array
              textout hdc, xr2&,yr2&, lpsz, BYVAL LEN(lpsz) ' print green text
      
              res&=settextcolor(hdc, RGB(255,255,255))
              textout hdc, 1,1, lpsz, BYVAL LEN(lpsz)  ' print dummy white text to finalize previous textout - this seems necessary for some reason
      
              SLEEP 80
              IF i&>0 THEN
                  res&=settextcolor(hdc, RGB(255,255,255)) ' use white to erase text
                  selectobject hdc, fontno&(j&)            ' select font from font array
                  textout hdc, xr&,yr&, lpsz, BYVAL LEN(lpsz) ' erase red text
                  textout hdc, xr&+2*xx&,yr&, lpsz, BYVAL LEN(lpsz) ' erase blue text
                  selectobject hdc, fontno&(j2&) ' select font from font array
                  textout hdc, xr2&,yr2&, lpsz, BYVAL LEN(lpsz) ' erase green text
                  DECR j& ' decrease index for font for blue and red text
              END IF
          NEXT
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB textgraphics0(hdc AS LONG)
          LOCAL xx&,yy&,hedit AS LONG
          fillrect hdc, rct, getstockobject(%white_brush)
          settextalign hdc,%ta_center '%ta_left
          xx&=385 'x1&'/12.4:
          yy&=55 'y1/10
          CALL showtext2(hdc,240,1000,1,0,"Monotype Corsiva","Welcome!",xx&,yy&,RGB(0,0,255))
          ' create start font for font dialog box
          fosize=20:foweight=400:foital=0:founl=0:fostout=0:foface="arial"
          textfont=makefont(fosize,foweight,foital,founl,fostout,foface)
          selectobject hdc, textfont
          CONTROL HANDLE hform1&,%form1_text1 TO hedit
          CALL sendmessage (hedit, %wm_setfont, textfont, 0) ' send font to control
          CALL deleteobject (textfont)
          exampleflag = 0
      
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB textgraphics1(hdc AS LONG)
          LOCAL res&
          DIM gtext AS ASCIIZ * 255
          LOCAL xx&,yy&,t$
          LOCAL extraspace&
          fillrect hdc, rct, getstockobject(%white_brush)
          settextalign hdc,%ta_left  ' %ta_center
          xx&=5:yy&=3
          t$="This program demonstrates the use of the "
          CALL showtext1(hdc,32,400,0,0,"arial",t$,xx&,yy&,8388608)
          t$="font common dialog box"
          CALL showtext1(hdc,32,700,1,1,"arial",t$,xx&,yy&,255)
          t$=" and the application of "
          CALL showtext1(hdc,32,400,0,0,"arial",t$,xx&,yy&,8388608)
          t$="various fonts"
          CALL showtext1(hdc,32,700,1,1,"arial",t$,xx&,yy&,32768)
          t$=" in the same control. Since text boxes (edit controls) do not allow "+ _
             "more than one font at a given time, a "
          CALL showtext1(hdc,32,400,0,0,"arial",t$,xx&,yy&,8388608)
          t$="label control (or static control)"
          CALL showtext1(hdc,32,1000,0,1,"arial",t$,xx&,yy&,16711680)
          t$=" is being applied as originally suggested for graphic purposes by Lance Edmonds in "+ _
             "the powerbasic forum. This limitation of edit controls implies that whenever "+ _
             "more different fonts and font sizes are being applied at a given time as in the "+ _
             "advanced word processors (e.g. word), the affair is being "+ _
             "managed using static controls in a complex way. "
          CALL showtext1(hdc,32,400,0,0,"arial",t$,xx&,yy&,8388608)
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB textgraphics2(hdc AS LONG)
          LOCAL res&
          DIM gtext AS ASCIIZ * 255
          LOCAL xx&,yy&
          LOCAL extraspace&
          fillrect hdc, rct, getstockobject(%white_brush)
          settextalign hdc,%ta_center '%ta_left
          extraspace&=5
          xx&=x1&/2:yy&=3
          CALL showtext2(hdc,28,700,1,0,"papyrus","Some Grooks by the Danish poet Piet Hein",xx&,yy&,8388736)
          yy&=yy&+extraspace&
          CALL showtext2(hdc,24,700,0,0,"papyrus","1. Problems",xx&,yy&,0)
          CALL showtext2(hdc,22,600,0,0,"tempus sans itc","Problems worthy of attack - prove their worth by hitting back.",xx&,yy&,210)
          yy&=yy&+extraspace&
          CALL showtext2(hdc,24,700,0,0,"papyrus","2. That is the question - Hamlet anno domini.",xx&,yy&,0)
          CALL showtext2(hdc,22,700,0,0,"tempus sans itc","Co-existence - or no existence.",xx&,yy&,RGB(0,96,0))
          yy&=yy&+extraspace&
          CALL showtext2(hdc,24,700,0,0,"papyrus","3. Losing face",xx&,yy&,0)
          CALL showtext2(hdc,22,400,0,0,"Monotype Corsiva","The noble art of losing face",xx&,yy&,16711680)
          CALL showtext2(hdc,22,400,0,0,"Monotype Corsiva","May one day save the human race",xx&,yy&,16711680)
          CALL showtext2(hdc,22,400,0,0,"Monotype Corsiva","And turn into eternal merit",xx&,yy&,16711680)
          CALL showtext2(hdc,22,400,0,0,"Monotype Corsiva","What weaker minds would call disgrace.",xx&,yy&,16711680)
          yy&=yy&+extraspace&
          CALL showtext2(hdc,24,700,0,0,"papyrus","4. I'd like -",xx&,yy&,0)
          CALL showtext2(hdc,22,400,0,0,"jokerman","I'd like to know - what this whole show - is all about",xx&,yy&,8421376)
          CALL showtext2(hdc,22,400,0,0,"jokerman","before it's out",xx&,yy&,8421376)
          yy&=yy&+extraspace&
          CALL showtext2(hdc,12,400,0,0,"arial","Sources:  http://en.wikiquote.org/wiki/Piet_Hein   -   http://www.leptonica.com/cachedpages/grooks/grooks.html",xx&,yy&,8388608)
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB textgraphics3(hdc AS LONG)
          LOCAL res&
          DIM gtext AS ASCIIZ * 255
          LOCAL xx&,yy&,t$
          fillrect hdc, rct, getstockobject(%white_brush)
          settextalign hdc,%ta_left
          xx&=x1&/4:yy&=y1&/3.08
          t$="rotating text"
          CALL showtext3(hdc,55,400,0,0,"arial",t$,xx&,yy&,255)
          exampleflag = -1
      END SUB
      ' ----------------------------------
      ' ----------------------------------
      SUB fontdelete () ' delete font before ending
        LOCAL i AS LONG
        FOR i=0 TO fono
            CALL deleteobject (fontno&(i&))
        NEXT
      END SUB
      Attached Files

      Comment

      Working...
      X