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

Enhanced metafile curve drawing example with copying to clipboard

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

  • Enhanced metafile curve drawing example with copying to clipboard

    ' enhanced metafile curve drawing example with copying to clipboard
    '
    ' nb: adjusted version january 16, 2004.
    '
    ' this simple example illustrates drawing a function curve onto the
    ' screen. you can define any continuous function and the labels for
    ' the x- and y-axis. the diagram will be drawn with tic marks and
    ' values on the axes as well as the label text. via the clipboard
    ' the diagram can be copied into a word document and edited there.
    ' try double clicking on the pasted graph in word and see what
    ' happens.
    '
    ' this is a slightly modified version based on the linear regression
    ' program posted previously in this link:
    http://www.powerbasic.com/support/pb...ad.php?t=24134
    '
    ' you can rather easily convert the present code to an include file.
    '
    ' best regards,
    '
    ' erik christensen ------ e.chr@email.dk ------ january 14, 2004
    '
    ' changes per january 16, 2004:
    '
    ' calculation of the rectangle for the enhanced metafile has been
    ' changed according to an example in the msdn library.
    ' the device context for the application window is used as a reference
    ' device context from which the resolution data is being used to calculate
    ' correctly the dimensions of the picture frame in .01-millimeter units.
    ' the method that i used previously did not lead to the correct dimensions
    ' in all cases.
    '
    ' thanks for the feed-back. i hope these changes are working on all
    ' systems.
    '
    ' best regards
    '
    ' erik
    Code:
    #compile exe
    #register none
    #dim all
    '
    #include "win32api.inc"
    
    %form1_graphcopy          = 100
    %form1_graphlabel         = 105
    ' --------------------------------------------------
    global hform1&             ' dialog handle
    global hform1_menu0&
    global hform1_menu2&
    global hgraph as long      ' handle for graphics window - a label (or static) control
    global brush&
    global rows as long        ' number of rows in array
    global rowsnew as long     ' number of rows with complete x,y values in a given analysis
    global lffont as logfont   ' logfont structure
    global logpixelsy as long  ' pixels per inch of screen height
    global logpixelsx as long  ' pixels per inch of screen width
    global numdat() as single  ' numerical data array
    global xmax as single, xmin as single, ymax as single, ymin as single
    global powerx as single, powery as single
    global xvar&,yvar&
    global grafflag as long
    global xdialun&,ydialun&,xpixmax&,ypixmax&
    global rct as rect
    global ps as paintstruct   ' paint structure
    global xfact as single, yfact as single
    global lpsize as sizel
    global xtext$,ytext$
    '
    function gcolor(byval i as long) as long
      select case i
        ' common rgb colors:
        case 0 : function = &h000000???  '%black - same as rgb(0,0,0)
        case 1 : function = &hff0000???  '%blue
        case 2 : function = &h00ff00???  '%green
        case 3 : function = &hffff00???  '%cyan
        case 4 : function = &h0000ff???  '%red
        case 5 : function = &hff00ff???  '%magenta
        case 6 : function = &h00ffff???  '%yellow
        case 7 : function = &hffffff???  '%white - same as rgb(255,255,255)
        case 8 : function = &h808080???  '%gray
        case 9 : function = &hc0c0c0???  '%ltgray
        ' additional colors can be added e.g. using the rgb function,
        ' e.g. case 10: function = rgb(164,164,164)
        ' and so on.
        case else : function = &h000000???  '%black
      end select
    end function
    '
    function penstyle(byval i as long) as long
      select case i
        ' pen styles
        case 0 :   function = %ps_solid       ' _______
        case 1 :   function = %ps_dash        ' -------
        case 2 :   function = %ps_dot         ' .......
        case 3 :   function = %ps_dashdot     ' _._._._
        case 4 :   function = %ps_dashdotdot  ' _.._.._
        case else: function = %ps_solid
      end select
    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) ' better than: -(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    (0,1)
        lffont.lfunderline = underline          ' underline attribute flag (0,1)
        lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
        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
    '
    sub prepareandmakegraph (byval hdc as long,byval nv as long,byval  np as long,byval xmax as single, _
        byval xmin as single,byval ymax as single,byval ymin as single,byval iix as long, _
        byval iiy as long,byref numdat() as single,byval xtxt$,byval ytxt$)
        ' -
        dim start as single,stepsize as single, labels as long
        dim xstep as single,xlabels as long, xhigh as single
        dim ystep as single,ylabels as long, yhigh as single
        dim xlow as single, ylow as single
        dim lemarg as single, rimarg as single, upmarg as single, lomarg as single
        dim xconvfac as single, yconvfac as single
        local i&,hpen as long
        local xpix as single,ypix as single, radius as single
        local ystart as single,yend as single,penwidth as single
        '
        fillrect hdc, rct, getstockobject(%white_brush)
        if abs(xmax) > abs(xmin) then
            powerx = xmax
        else
            powerx = xmin
        end if
        powerx = int(log10(abs(powerx) / 10))
        if abs(ymax) > abs(ymin) then
            powery = ymax
        else
            powery = ymin
        end if
        powery = int(log10(abs(powery) / 10))
        call findaxisdimandscale(xmax, xmin, xlow, xstep, xlabels)
        call findaxisdimandscale(ymax, ymin, ylow, ystep, ylabels)
        xhigh = xlow + (xlabels - 1) * xstep
        yhigh = ylow + (ylabels - 1) * ystep
        ' define wideness of "margins" for plot
        lemarg = xpixmax&/9
        rimarg = xpixmax&/15
        upmarg = ypixmax&/9
        lomarg = ypixmax&/6.5
        xconvfac = (xpixmax& - lemarg - rimarg) / (xhigh - xlow)
        yconvfac = (ypixmax& - upmarg - lomarg) / (yhigh - ylow)
        call makexandyaxiswithtext(hdc,lemarg, lomarg, rimarg, upmarg, xlow, xstep, xhigh, _
             ylow, ystep, yhigh, xconvfac, yconvfac, xtxt$, ytxt$, 0)
        '
        penwidth=logpixelsx/254*2.1
        hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(1))) ' blue
        ' draw curve
        xpix=round((numdat(1&,1)-xlow)*xconvfac+lemarg,0)
        ypix=round(ypixmax&-((numdat(1&,2)-ylow)*yconvfac+lomarg),0)
        movetoex hdc, xpix, ypix, byval %null
        for i&=2 to rowsnew
            xpix=round((numdat(i&,1)-xlow)*xconvfac+lemarg,0)
            ypix=round(ypixmax&-((numdat(i&,2)-ylow)*yconvfac+lomarg),0)
            lineto hdc, xpix, ypix
        next
    end sub
    '
    sub findaxisdimandscale (byval maxval as single,byval minval as single,byref start as single,byref stepsize as single,byref labels as long)
        local range as double,eksp as double,bbbb as double, iii as long
        range = maxval - minval
        range = log10(range)
        eksp = ceil(range)
        range = 10 ^ (range - eksp)
        while range < 1
            range = range * 10
            eksp = eksp - 1
        wend
        if ceil(range) >= 5 then
            labels = ceil(range) + 1
            stepsize = 1 * 10 ^ eksp
        elseif ceil(range) >= 2 then
            labels = ceil(2 * range) + 1
            stepsize = .5 * 10 ^ eksp
        else
            labels = ceil(5 * range) + 1
            stepsize = .2 * 10 ^ eksp
        end if
        bbbb = 0
        if maxval > 0 then
            iii = 1
            do
                iii = iii + 1
                bbbb = bbbb + stepsize
            loop until bbbb > maxval
            if (iii - labels) * stepsize > minval then labels = labels + 1
                start = (iii - labels) * stepsize
        else
            iii = 0
            do
                iii =  iii -1
                bbbb = bbbb - stepsize
            loop until bbbb < minval
            if (iii + labels - 1) * stepsize < maxval then labels = labels + 1
            start = iii * stepsize
        end if
    end sub
    '
    sub makexandyaxiswithtext (byval hdc as long,byval lemarg as single,byval lomarg as single,byval rimarg as single,byval upmarg as single, _
        byval xlow as single,byval xstep as single,byval xhigh as single,byval ylow as single,byval ystep as single, _
        byval yhigh as single,byval xconvfac as single,byval yconvfac as single, byval xtxt$, _
        byval ytxt$,byval ipat as long)
        '-
        dim lpsz as asciiz * 255
        local hpen as long,hfont&
        local i as long, flag as long, kk as long, longtics as long
        local res as long
        local si as single,ex$,xx1 as single
        local yy1 as single
        local xval as single,yval as single,penwidth as single
        '-
        res=fillrect(hdc, rct, getstockobject(%white_brush))
        '
        hfont&=makefont(11,400,0,0,0,"arial")
        selectobject hdc, hfont&
        settextalign hdc,%ta_left
    
        penwidth=logpixelsx/254*2.1
        hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(0)))  ' black pen
        '- draw x-axis and y-axis
        movetoex hdc, xpixmax&-rimarg,ypixmax&-lomarg, byval %null
        lineto hdc, lemarg,ypixmax&-lomarg
        lineto hdc, lemarg,upmarg
        '
        ' check number of ciphers in tic labels on x-axis
        xval = xlow
        for si = lemarg to xpixmax& - rimarg step xconvfac * xstep * .9999
            if abs(powerx)>=3 then
                xx1 = int(xval / 10 ^ powerx + .5)
            else
                xx1=round(xval,3)
            end if
            xval = xval + xstep
            if abs(xx1)>=10000 then longtics = 1
            incr kk
        next
    
        if longtics = 1 and kk >=8 then flag = 1 ' many long tic labels.
        '
        '- make tic intervals and labels on x-axis
        xval = xlow : kk = 0
        settextalign hdc,%ta_center
        for si = lemarg to xpixmax& - rimarg step xconvfac * xstep * .9999
            if abs(powerx)>=3 then
                xx1 = int(xval / 10 ^ powerx + .5)
            else
                xx1=round(xval,3)
            end if
            lpsz = ltrim$(str$(xx1))
            res=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
            incr kk
            if flag = 1 then ' only show every other tic label
                if kk mod 2 = 1 then textout hdc, si, ypixmax&-lomarg+ypixmax&/40, lpsz, byval len(lpsz)
                if kk mod 2 = 0 then lpsize.cx = 0
            else             ' show every tic label
                textout hdc, si, ypixmax&-lomarg+ypixmax&/40, lpsz, byval len(lpsz)
            end if
            movetoex hdc, si,ypixmax&-lomarg, byval %null
            lineto hdc, si,ypixmax&-lomarg+ypixmax&/50
            xval = xval + xstep
        next
        '- put name of x-variable on diagram
        if powerx >=3 then ex$ = " / 10^" + mid$(str$(-powerx), 2)
        if abs(powerx)<3 then ex$ = "
        if powerx <=-3 then ex$ = " x 10^" + mid$(str$(powerx), 2)
        xtxt$ = xtxt$ + ex$
        lpsz=xtxt$
        settextalign hdc,%ta_right
        textout hdc, xpixmax&-rimarg+lpsize.cx*0.5, ypixmax&-lomarg+ypixmax&/13, lpsz, byval len(lpsz)
        '- make tic intervals and labels on y-axis
        yval = ylow
        for si = ypixmax&-lomarg to upmarg step -yconvfac * ystep * .9999
            if abs(powery)>=3 then
                yy1 = int(yval / 10 ^ powery + .5)
            else
                yy1=round(yval,3)
            end if
            lpsz = ltrim$(str$(yy1))
            res=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
            textout hdc, lemarg-xpixmax&/48, si-lpsize.cy*0.5, lpsz, byval len(lpsz)
            yval = yval + ystep
            movetoex hdc,lemarg, si, byval %null
            lineto hdc, lemarg-xpixmax&/70,si
        next
        '-put name of y-variable on diagram
        if powery >= 3 then ex$ = " / 10^" + mid$(str$(-powery), 2)
        if abs(powery) <3 then ex$ = "
        if powery < -3 then ex$ = " x 10^" + mid$(str$(powery), 2)
        ytxt$ = ytxt$ + ex$
        lpsz=ytxt$
        settextalign hdc,%ta_left
        textout hdc, lemarg-xpixmax&/48-lpsize.cx,upmarg-ypixmax&/13, lpsz, byval len(lpsz)
        deleteobject hfont&
    end sub
    '
    ' ---------------------------------------------------------
    callback function form1_dlgproc
        local hemf as long,lpszfile as asciiz*80
        local hdcemf as long
        local hdc as long
        local res as long
        static grafcopyflag as long
        select case cbmsg
            case %wm_paint
                beginpaint cbhndl, ps
                if grafflag=10 then ' graph can be made
                    getclientrect hgraph,rct
                    ' specify rectancle in 0.01 mm units for creation of metafile:
                    local hdcref&,iwidthmm&,iheightmm&,iwidthpels&,iheightpels&
                    '
                    ' obtain a handle to a reference device context.
                    hdcref = getdc(cbhndl)
                    '
                    ' determine the picture frame dimensions.
                    ' iwidthmm is the display width in millimeters.
                    ' iheightmm is the display height in millimeters.
                    ' iwidthpels is the display width in pixels.
                    ' iheightpels is the display height in pixels
    
                    iwidthmm = getdevicecaps(hdcref, %horzsize)
                    iheightmm = getdevicecaps(hdcref, %vertsize)
                    iwidthpels = getdevicecaps(hdcref, %horzres)
                    iheightpels = getdevicecaps(hdcref, %vertres)
                    releasedc cbhndl, hdcref
    
                    ' retrieve the coordinates of the client
                    ' rectangle, in pixels.
                    getclientrect hgraph,rct
    
                    ' convert client coordinates to .01-mm units.
                    ' use iwidthmm, iwidthpels, iheightmm, and
                    ' iheightpels to determine the number of
                    ' .01-millimeter units per pixel in the x-
                    ' and y-directions.
    
                    rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
                    rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
                    rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
                    rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
                    '
                    hdcemf = createenhmetafile (%null, byval %null, rct, byval %null)
                    ' get rectangle in pixels to display diagram
                    getclientrect hgraph,rct
                    call prepareandmakegraph (hdcemf,2, rows, xmax, xmin, ymax, ymin, 1, 2, numdat(),xtext$,ytext$)      'head(xvar&), head(yvar&))
                    hemf = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
                    ' handle to label where the diagram is to be drawn
                    hdc = getdc(getdlgitem(cbhndl, %form1_graphlabel))
                    call playenhmetafile (hdc, hemf, rct)
                    ' "plays" the metafile in the label window,
                    ' i.e. the graphics procedures are now being performed in
                    ' that window.
                    if grafcopyflag=3 then ' copy graphic enhanced metafile to clipboard
                        ' this code is due to peter stephensen:
                        %cf_enhmetafile = 14
                        if openclipboard(%null) then
                            emptyclipboard
                            setclipboarddata %cf_enhmetafile, hemf
                            closeclipboard
                        end if
                        grafcopyflag=0
                    end if
                else
                    hdc = getdc(getdlgitem(cbhndl, %form1_graphlabel))
                    res&=fillrect (hdc, rct, getstockobject(%white_brush))
                end if
                endpaint cbhndl, ps
                releasedc getdlgitem(cbhndl,%form1_graphlabel), hdc
                function = 1
            case %wm_command
                select case cbctl
                    case  %form1_graphcopy
                        ' the following causes the metafile to be copied to the clipboard.
                        grafcopyflag=3   ' see case %wm_paint above
                        res&=invalidaterect(hform1&,byval %null,%true)
                    case else
                end select
            case else
        end select
    end function
    '
    sub showdialog_form1(byval hparent&)
        local style&, exstyle& ,hctl&
        local labelstyle&,labelstyle2&
        local n&, ct&, r&,res&
        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
        dialog new hparent&, "curve drawing", 0, 0,  342,  264, style&, exstyle& to hform1&
        labelstyle& = %ws_child or %ws_visible or %ss_center
        xdialun&=334:ydialun&=245
        dialog units hform1&, xdialun&, ydialun& to pixels xpixmax&, ypixmax&
        xfact=xpixmax&/xdialun&: yfact=ypixmax&/ydialun&  ' conversion factors from dialog units to pixels
        ' the graphics routines use pixels. hence this conversion.
        labelstyle2& = %ws_child or %ws_visible or %ss_grayframe or %ss_left
        ' nb: the grayframe style must be included
        control add label, hform1&,  %form1_graphlabel,  ", 4, 2, xdialun&,ydialun&, labelstyle2& ',%ws_ex_clientedge
        control handle hform1&, %form1_graphlabel to hgraph ' handle for graphics window
        menu new bar to hform1_menu0&
        menu new popup to hform1_menu2&
        menu add popup, hform1_menu0& ,"&copy", hform1_menu2&, %mf_enabled
        menu add string, hform1_menu2&, "copy present &graph to clipboard", %form1_graphcopy, %mf_enabled       ' %mf_grayed
        menu attach hform1_menu0&, hform1&
        dialog show modeless hform1& , call form1_dlgproc
    end sub
    ' ------------------------------------------------
    function pbmain
        local count&
        local hdc as long
        brush&=createsolidbrush(rgb(255,255,255)) ' white
        hdc = getdc(%hwnd_desktop)
        logpixelsy  = getdevicecaps(hdc, %logpixelsy)
        logpixelsx  = getdevicecaps(hdc, %logpixelsx)
        releasedc %hwnd_desktop, hdc
        showdialog_form1 0
        redim numdat(1 to 5000,1 to 2)
        local i#,kk&,jj#
        ' create curve points (x,y)
        for i = 1 to 48*atn(1) step 0.05
            incr kk&
            numdat(kk,1) = i                     ' x-value
            numdat(kk,2) = 50#*1#/(2+sin(i))-20  ' function value y (you can replace with any other function you want to display)
            xmax=max(xmax,numdat(kk,1))
            xmin=min(xmin,numdat(kk,1))
            ymax=max(ymax,numdat(kk,2))
            ymin=min(ymin,numdat(kk,2))
        next
        xtext$ = "x-value"
        ytext$ = "function value y"
        rows = 2
        grafflag = 10
        rowsnew = kk& ' number of points used
        do
            dialog doevents to count&
        loop until count&=0
        deleteobject brush&
    end function


    [this message has been edited by erik christensen (edited january 16, 2004).]

  • #2
    -


    [This message has been edited by Erik Christensen (edited July 13, 2007).]

    Comment


    • #3
      ' enhanced metafile curve drawing example with copying to clipboard
      '
      ' corrected version - see below
      '
      ' this simple example illustrates drawing a function curve onto the
      ' screen. you can define any continuous function and the labels for
      ' the x- and y-axis. the diagram will be drawn with tic marks and
      ' values on the axes as well as the label text. via the clipboard
      ' the diagram can be copied into a word document and edited there.
      ' try double clicking on the pasted graph in word and see what
      ' happens.
      '
      ' this is a slightly modified version based on the linear regression
      ' program posted previously in this link:
      'http://www.powerbasic.com/support/pb...ad.php?t=24134
      '
      ' you can rather easily convert the present code to an include file.
      '
      ' best regards,
      '
      ' erik christensen ------ e.chr@email.dk ------ january 14, 2004
      '
      ' changes per january 16, 2004:
      '
      ' calculation of the rectangle for the enhanced metafile has been
      ' changed according to an example in the msdn library.
      ' the device context for the application window is used as a reference
      ' device context from which the resolution data is being used to calculate
      ' correctly the dimensions of the picture frame in .01-millimeter units.
      ' the method that i used previously did not lead to the correct dimensions
      ' in all cases.
      '
      ' thanks for the feed-back. i hope these changes are working on all
      ' systems.
      '
      ' best regards
      '
      ' erik
      '
      ' p.s. july 13, 2007. i discovered that the program only could run on pbwin7x
      ' and not run on pbwin8x.
      ' therefore i have overhauled the code which should now also run on pbwin8x.
      ' this new version completely avoids global variables.

      Code:
      #compile exe
      #register none
      #dim all
      '
      #include "win32api.inc"
      
      %form1_graphcopy          = 100
      %form1_graphlabel         = 105
      ' --------------------------------------------------
      '
      function gcolor(byval i as long) as long
        select case i
          ' common rgb colors:
          case 0 : function = &h000000???  '%black - same as rgb(0,0,0)
          case 1 : function = &hff0000???  '%blue
          case 2 : function = &h00ff00???  '%green
          case 3 : function = &hffff00???  '%cyan
          case 4 : function = &h0000ff???  '%red
          case 5 : function = &hff00ff???  '%magenta
          case 6 : function = &h00ffff???  '%yellow
          case 7 : function = &hffffff???  '%white - same as rgb(255,255,255)
          case 8 : function = &h808080???  '%gray
          case 9 : function = &hc0c0c0???  '%ltgray
          ' additional colors can be added e.g. using the rgb function,
          ' e.g. case 10: function = rgb(164,164,164)
          ' and so on.
          case else : function = &h000000???  '%black
        end select
      end function
      '
      function penstyle(byval i as long) as long
        select case i
          ' pen styles
          case 0 :   function = %ps_solid       ' _______
          case 1 :   function = %ps_dash        ' -------
          case 2 :   function = %ps_dot         ' .......
          case 3 :   function = %ps_dashdot     ' _._._._
          case 4 :   function = %ps_dashdotdot  ' _.._.._
          case else: function = %ps_solid
        end select
      end function
      '
      function makefont(byval fontheight as long,byval fontweight as long, _
          byval italic as long, byval underline as long,byval strikeout as long, _
          byval facename as string) as long
          local lffont as logfont   ' logfont structure
      
      ' -----------------------
          'type logfont defines the attributes of a font.
          'see logfont in the win32 help file
          lffont.lfheight = fontheight            ' logical height of font
          lffont.lfwidth = 0                      ' logical average character width (if zero then windows sets the width using a standard aspect ratio)
          lffont.lfescapement = 0                 ' angle of escapement
          lffont.lforientation = 0                ' base-line orientation angle
          lffont.lfweight = fontweight            ' font weight
          lffont.lfitalic = italic                ' italic attribute flag    (0,1)
          lffont.lfunderline = underline          ' underline attribute flag (0,1)
          lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
          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
      '
      sub prepareandmakegraph (byval hdc as long,byval nv as long,byval  np as long,byval xmax as single, _
                  byval xmin as single,byval ymax as single,byval ymin as single,byval iix as long, _
                  byval iiy as long,byref numdat() as single,byval xtxt$,byval ytxt$, byref rct as rect, _
                  byref powerx as single, byref powery as single, byref xpixmax as long, _
                  byref ypixmax as long, byref logpixelsx as long, byref rowsnew as long)
          ' -
          dim start as single,stepsize as single, labels as long
          dim xstep as single,xlabels as long, xhigh as single
          dim ystep as single,ylabels as long, yhigh as single
          dim xlow as single, ylow as single
          dim lemarg as single, rimarg as single, upmarg as single, lomarg as single
          dim xconvfac as single, yconvfac as single
          local i as long, hpen as long
          local xpix as single,ypix as single, radius as single
          local ystart as single,yend as single,penwidth as single
          '
          fillrect hdc, rct, getstockobject(%white_brush)
          if abs(xmax) > abs(xmin) then
              powerx = xmax
          else
              powerx = xmin
          end if
          powerx = int(log10(abs(powerx) / 10))
          if abs(ymax) > abs(ymin) then
              powery = ymax
          else
              powery = ymin
          end if
          powery = int(log10(abs(powery) / 10))
          call findaxisdimandscale(xmax, xmin, xlow, xstep, xlabels)
          call findaxisdimandscale(ymax, ymin, ylow, ystep, ylabels)
          xhigh = xlow + (xlabels - 1) * xstep
          yhigh = ylow + (ylabels - 1) * ystep
          ' define wideness of "margins" for plot
          lemarg = xpixmax/9
          rimarg = xpixmax/15
          upmarg = ypixmax/9
          lomarg = ypixmax/6.5
          xconvfac = (xpixmax - lemarg - rimarg) / (xhigh - xlow)
          yconvfac = (ypixmax - upmarg - lomarg) / (yhigh - ylow)
          call makexandyaxiswithtext(hdc,lemarg, lomarg, rimarg, upmarg, xlow, xstep, xhigh, _
               ylow, ystep, yhigh, xconvfac, yconvfac, xtxt$, ytxt$, 0, rct, logpixelsx, _
               xpixmax, ypixmax, powerx, powery)
          '
          penwidth=logpixelsx/254*2.1
          hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(1))) ' blue
          ' draw curve
          xpix=round((numdat(1,1)-xlow)*xconvfac+lemarg,0)
          ypix=round(ypixmax-((numdat(1,2)-ylow)*yconvfac+lomarg),0)
          movetoex hdc, xpix, ypix, byval %null
          for i=2 to rowsnew
              xpix=round((numdat(i,1)-xlow)*xconvfac+lemarg,0)
              ypix=round(ypixmax-((numdat(i,2)-ylow)*yconvfac+lomarg),0)
              lineto hdc, xpix, ypix
          next
      end sub
      '
      sub findaxisdimandscale (byval maxval as single,byval minval as single, _
              byref start as single,byref stepsize as single,byref labels as long)
          '
          local range as double, eksp as double, bbbb as double, iii as long
          range = maxval - minval
          range = log10(range)
          eksp = ceil(range)
          range = 10 ^ (range - eksp)
          while range < 1
              range = range * 10
              eksp = eksp - 1
          wend
          if ceil(range) >= 5 then
              labels = ceil(range) + 1
              stepsize = 1 * 10 ^ eksp
          elseif ceil(range) >= 2 then
              labels = ceil(2 * range) + 1
              stepsize = .5 * 10 ^ eksp
          else
              labels = ceil(5 * range) + 1
              stepsize = .2 * 10 ^ eksp
          end if
          bbbb = 0
          if maxval > 0 then
              iii = 1
              do
                  iii = iii + 1
                  bbbb = bbbb + stepsize
              loop until bbbb > maxval
              if (iii - labels) * stepsize > minval then labels = labels + 1
                  start = (iii - labels) * stepsize
          else
              iii = 0
              do
                  iii =  iii -1
                  bbbb = bbbb - stepsize
              loop until bbbb < minval
              if (iii + labels - 1) * stepsize < maxval then labels = labels + 1
              start = iii * stepsize
          end if
      end sub
      '
      sub makexandyaxiswithtext (byval hdc as long, byval lemarg as single, byval lomarg as single, byval rimarg as single, _
          byval upmarg as single, byval xlow as single, byval xstep as single, byval xhigh as single, byval ylow as single, _
          byval ystep as single, byval yhigh as single, byval xconvfac as single, byval yconvfac as single, byval xtxt$, _
          byval ytxt$,byval ipat as long, byref rct as rect, byref logpixelsx as long, byref xpixmax as long, _
          byref ypixmax as long, byref powerx as single, byref powery as single)
          '-
          local lpsz as asciiz * 255
          local hpen as long, hfont as long
          local i as long, flag as long, kk as long, longtics as long
          local res as long
          local si as single, ex as string, xx1 as single
          local yy1 as single
          local xval as single, yval as single, penwidth as single
          local lpsize as sizel
          '-
          res=fillrect(hdc, rct, getstockobject(%white_brush))
          '
          hfont=makefont(18,400,0,0,0,"arial")
          selectobject hdc, hfont
          settextalign hdc,%ta_left
      
          penwidth=logpixelsx/254*2.1
          hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(0)))  ' black pen
          '
          '- draw x-axis and y-axis
          movetoex hdc, xpixmax-rimarg,ypixmax-lomarg, byval %null
          lineto hdc, lemarg,ypixmax-lomarg
          lineto hdc, lemarg,upmarg
          '
          ' check number of ciphers in tic labels on x-axis
          xval = xlow
          for si = lemarg to xpixmax - rimarg step xconvfac * xstep * .9999
              if abs(powerx)>=3 then
                  xx1 = int(xval / 10 ^ powerx + .5)
              else
                  xx1=round(xval,3)
              end if
              xval = xval + xstep
              if abs(xx1)>=10000 then longtics = 1
              incr kk
          next
      
          if longtics = 1 and kk >=8 then flag = 1 ' many long tic labels.
          '
          '- make tic intervals and labels on x-axis
          xval = xlow : kk = 0
          settextalign hdc,%ta_center
          for si = lemarg to xpixmax - rimarg step xconvfac * xstep * .9999
              if abs(powerx)>=3 then
                  xx1 = int(xval / 10 ^ powerx + .5)
              else
                  xx1=round(xval,3)
              end if
              lpsz = ltrim$(str$(xx1))
              res=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
              incr kk
              if flag = 1 then ' only show every other tic label
                  if kk mod 2 = 1 then textout hdc, si, ypixmax-lomarg+ypixmax/40, lpsz, byval len(lpsz)
                  if kk mod 2 = 0 then lpsize.cx = 0
              else             ' show every tic label
                  textout hdc, si, ypixmax-lomarg+ypixmax/40, lpsz, byval len(lpsz)
              end if
              movetoex hdc, si,ypixmax-lomarg, byval %null
              lineto hdc, si,ypixmax-lomarg+ypixmax/50
              xval = xval + xstep
          next
          '
          '- put name of x-variable on diagram
          if powerx >=3 then ex$ = " / 10^" + mid$(str$(-powerx), 2)
          if abs(powerx)<3 then ex$ = "
          if powerx <=-3 then ex$ = " x 10^" + mid$(str$(powerx), 2)
          xtxt$ = xtxt$ + ex$
          lpsz=xtxt$
          settextalign hdc,%ta_right
          textout hdc, xpixmax-rimarg+lpsize.cx*0.5, ypixmax-lomarg+ypixmax/13, lpsz, byval len(lpsz)
          '
          '- make tic intervals and labels on y-axis
          yval = ylow
          for si = ypixmax-lomarg to upmarg step -yconvfac * ystep * .9999
              if abs(powery)>=3 then
                  yy1 = int(yval / 10 ^ powery + .5)
              else
                  yy1=round(yval,3)
              end if
              lpsz = ltrim$(str$(yy1))
              res=gettextextentpoint32(hdc,lpsz,byval len(lpsz),lpsize)
              textout hdc, lemarg-xpixmax/48, si-lpsize.cy*0.5, lpsz, byval len(lpsz)
              yval = yval + ystep
              movetoex hdc,lemarg, si, byval %null
              lineto hdc, lemarg-xpixmax/70,si
          next
          '-put name of y-variable on diagram
          if powery >= 3 then ex$ = " / 10^" + mid$(str$(-powery), 2)
          if abs(powery) <3 then ex$ = "
          if powery < -3 then ex$ = " x 10^" + mid$(str$(powery), 2)
          ytxt$ = ytxt$ + ex$
          lpsz=ytxt$
          settextalign hdc,%ta_left
          textout hdc, lemarg-xpixmax/48-lpsize.cx,upmarg-ypixmax/13, lpsz, byval len(lpsz)
          deleteobject hfont
      end sub
      '
      ' ---------------------------------------------------------
      callback function form1_dlgproc
          local hemf as long,lpszfile as asciiz*80
          local hdcemf as long
          local hdc as long
          local res as long
          static grafcopyflag as long
          local i#,kk&,jj#
          local hdcref as long,iwidthmm as long,iheightmm as long,iwidthpels as long,iheightpels as long
          static hform1_menu0 as long
          static hform1_menu2 as long
          static hgraph as long      ' handle for graphics window - a label (or static) control
          static brush as long
          static rows as long        ' number of rows in array
          static rowsnew as long     ' number of rows with complete x,y values in a given analysis
          static logpixelsy as long  ' pixels per inch of screen height
          static logpixelsx as long  ' pixels per inch of screen width
          static numdat() as single  ' numerical data array
          static xmax as single, xmin as single, ymax as single, ymin as single
          static powerx as single, powery as single
          static xvar as long,yvar as long
          static grflag as long
          static xdialun as long,ydialun as long,xpixmax as long,ypixmax as long
          static rct as rect
          static ps as paintstruct   ' paint structure
          static xfact as single, yfact as single
          static xtext$,ytext$
          static labelstyle as long,labelstyle2 as long
          static n as long, ct as long, r as long
          '
          select case cbmsg
              '
              case %wm_initdialog
                  labelstyle = %ws_child or %ws_visible or %ss_center
                  xdialun = 334:ydialun = 245
                  dialog units cbhndl, xdialun, ydialun to pixels xpixmax, ypixmax
                  xfact=xpixmax/xdialun : yfact=ypixmax/ydialun  ' conversion factors from dialog units to pixels
                  ' the graphics routines use pixels. hence this conversion.
                  labelstyle2& = %ws_child or %ws_visible or %ss_grayframe or %ss_left
                  ' nb: the grayframe style must be included
                  control add label, cbhndl,  %form1_graphlabel,  ", 4, 2, xdialun,ydialun, labelstyle2 ',%ws_ex_clientedge
                  control handle cbhndl, %form1_graphlabel to hgraph ' handle for graphics window
                  menu new bar to hform1_menu0
                  menu new popup to hform1_menu2
                  menu add popup, hform1_menu0 ,"&copy", hform1_menu2, %mf_enabled
                  menu add string, hform1_menu2, "copy present &graph to clipboard", %form1_graphcopy, %mf_enabled       ' %mf_grayed
                  menu attach hform1_menu0, cbhndl
      
                  brush=createsolidbrush(rgb(255,255,255)) ' white
                  hdc = getdc(%hwnd_desktop)
                  logpixelsy  = getdevicecaps(hdc, %logpixelsy)
                  logpixelsx  = getdevicecaps(hdc, %logpixelsx)
                  releasedc %hwnd_desktop, hdc
                  redim numdat(1 to 5000,1 to 2)
                  grflag = 10
      
                  ' create curve points (x,y)
                  for i = 1 to 48*atn(1) step 0.05
                      incr kk
                      numdat(kk,1) = i                     ' x-value
                      numdat(kk,2) = 50#*1#/(2+sin(i))-20  ' function value y (you can replace with any other function you want to display)
                      xmax=max(xmax,numdat(kk,1))
                      xmin=min(xmin,numdat(kk,1))
                      ymax=max(ymax,numdat(kk,2))
                      ymin=min(ymin,numdat(kk,2))
                  next
                  xtext$ = "x-value"
                  ytext$ = "function value y"
                  rows = 2
                  grflag = 10
                  rowsnew = kk ' number of points used
      
              case %wm_paint
                  beginpaint cbhndl, ps
                  if grflag=10 then ' graph can be made
                      '
                      ' specify rectancle in 0.01 mm units for creation of metafile:
                      '
                      ' obtain a handle to a reference device context.
                      hdcref = getdc(cbhndl)
                      '
                      ' determine the picture frame dimensions.
                      ' iwidthmm is the display width in millimeters.
                      ' iheightmm is the display height in millimeters.
                      ' iwidthpels is the display width in pixels.
                      ' iheightpels is the display height in pixels
      
                      iwidthmm = getdevicecaps(hdcref, %horzsize)
                      iheightmm = getdevicecaps(hdcref, %vertsize)
                      iwidthpels = getdevicecaps(hdcref, %horzres)
                      iheightpels = getdevicecaps(hdcref, %vertres)
                      releasedc cbhndl, hdcref
      
                      ' retrieve the coordinates of the client
                      ' rectangle, in pixels.
                      getclientrect hgraph,rct
      
                      ' convert client coordinates to .01-mm units.
                      ' use iwidthmm, iwidthpels, iheightmm, and
                      ' iheightpels to determine the number of
                      ' .01-millimeter units per pixel in the x-
                      ' and y-directions.
      
                      rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
                      rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
                      rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
                      rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
                      '
                      hdcemf = createenhmetafile (%null, byval %null, rct, byval %null)
                      ' get rectangle in pixels to display diagram
                      getclientrect hgraph,rct
                      '
                      call prepareandmakegraph (hdcemf,2, rows, xmax, xmin, ymax, ymin, 1, 2, _
                          numdat(), xtext$, ytext$, rct, powerx, powery, xpixmax, ypixmax, _
                          logpixelsx, rowsnew)
                      '
                      hemf = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
                      ' handle to label where the diagram is to be drawn
                      hdc = getdc(getdlgitem(cbhndl, %form1_graphlabel))
                      call playenhmetafile (hdc, hemf, rct)
                      ' "plays" the metafile in the label window,
                      ' i.e. the graphics procedures are now being performed in
                      ' that window.
                      if grafcopyflag=3 then ' copy graphic enhanced metafile to clipboard
                          ' this code is due to peter stephensen:
                          %cf_enhmetafile = 14
                          if openclipboard(%null) then
                              emptyclipboard
                              setclipboarddata %cf_enhmetafile, hemf
                              closeclipboard
                          end if
                          grafcopyflag=0
                      end if
                  else
                      hdc = getdc(getdlgitem(cbhndl, %form1_graphlabel))
                      res=fillrect (hdc, rct, getstockobject(%white_brush))
                  end if
                  endpaint cbhndl, ps
                  releasedc getdlgitem(cbhndl,%form1_graphlabel), hdc
                  function = 1
              case %wm_destroy
                  deleteobject brush
                  postquitmessage 0
      
              case %wm_command
                  select case  cbctl
                      case  %form1_graphcopy
                          ' the following causes the metafile to be copied to the clipboard.
                          grafcopyflag=3   ' see case %wm_paint above
                          res=invalidaterect(cbhndl, byval %null, %true)
                      case else
                  end select
              case else
          end select
      end function
      '
      ' ------------------------------------------------
      function pbmain
          local count as long
          local style1 as long, hform1 as long
          style1 = %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
          dialog new 0, "curve drawing", 0, 0,  342,  264, style1, 0 to hform1
          dialog show modeless hform1 , call form1_dlgproc
          do
              dialog doevents to count
          loop until count=0
      end function
      ------------------


      [this message has been edited by erik christensen (edited july 13, 2007).]

      Comment


      • #4
        ' This updated version works with PBwin10. The graphic is made as an
        ' enhanced metafile. This can be copied to other programs like WORD.
        ' The enhanced metafile format allows the graphic to be edited after
        ' being copied.
        '
        ' Best regards,
        '
        ' Erik
        '
        Code:
        ' This updated version works with PBwin10. The graphic is made as an
        ' enhanced metafile. This can be copied to other programs like WORD.
        ' The enhanced metafile format allows the graphic to be edited after
        ' being copied. :)
        '
        ' Best regards,
        '
        ' Erik
        '
        #COMPILE EXE
        #REGISTER NONE
        #DIM ALL
        '
        #INCLUDE "win32api.inc"
        
        '%CF_ENHMETAFILE = 14
        
        %form1_graphcopy          = 100
        %form1_graphlabel         = 105
        ' --------------------------------------------------
        '
        FUNCTION gcolor(BYVAL i AS LONG) AS LONG
          SELECT CASE i
            ' common rgb colors:
            CASE 0 : FUNCTION = &h000000???  '%black - same as rgb(0,0,0)
            CASE 1 : FUNCTION = &hff0000???  '%blue
            CASE 2 : FUNCTION = &h00ff00???  '%green
            CASE 3 : FUNCTION = &hffff00???  '%cyan
            CASE 4 : FUNCTION = &h0000ff???  '%red
            CASE 5 : FUNCTION = &hff00ff???  '%magenta
            CASE 6 : FUNCTION = &h00ffff???  '%yellow
            CASE 7 : FUNCTION = &hffffff???  '%white - same as rgb(255,255,255)
            CASE 8 : FUNCTION = &h808080???  '%gray
            CASE 9 : FUNCTION = &hc0c0c0???  '%ltgray
            ' additional colors can be added e.g. using the rgb function,
            ' e.g. case 10: function = rgb(164,164,164)
            ' and so on.
            CASE ELSE : FUNCTION = &h000000???  '%black
          END SELECT
        END FUNCTION
        '
        FUNCTION penstyle(BYVAL i AS LONG) AS LONG
          SELECT CASE i
            ' pen styles
            CASE 0 :   FUNCTION = %ps_solid       ' _______
            CASE 1 :   FUNCTION = %ps_dash        ' -------
            CASE 2 :   FUNCTION = %ps_dot         ' .......
            CASE 3 :   FUNCTION = %ps_dashdot     ' _._._._
            CASE 4 :   FUNCTION = %ps_dashdotdot  ' _.._.._
            CASE ELSE: FUNCTION = %ps_solid
          END SELECT
        END FUNCTION
        '
        FUNCTION makefont(BYVAL fontheight AS LONG,BYVAL fontweight AS LONG, _
            BYVAL italic AS LONG, BYVAL underline AS LONG,BYVAL strikeout AS LONG, _
            BYVAL facename AS STRING) AS LONG
            LOCAL lffont AS logfont   ' logfont structure
        
        ' -----------------------
            'type logfont defines the attributes of a font.
            'see logfont in the win32 help file
            lffont.lfheight = fontheight            ' logical height of font
            lffont.lfwidth = 0                      ' logical average character width (if zero then windows sets the width using a standard aspect ratio)
            lffont.lfescapement = 0                 ' angle of escapement
            lffont.lforientation = 0                ' base-line orientation angle
            lffont.lfweight = fontweight            ' font weight
            lffont.lfitalic = italic                ' italic attribute flag    (0,1)
            lffont.lfunderline = underline          ' underline attribute flag (0,1)
            lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
            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
        '
        SUB prepareandmakegraph (BYVAL hdc AS LONG,BYVAL nv AS LONG,BYVAL  np AS LONG,BYVAL xmax AS SINGLE, _
                    BYVAL xmin AS SINGLE,BYVAL ymax AS SINGLE,BYVAL ymin AS SINGLE,BYVAL iix AS LONG, _
                    BYVAL iiy AS LONG,BYREF numdat() AS SINGLE,BYVAL xtxt$,BYVAL ytxt$, BYREF rct AS rect, _
                    BYREF powerx AS SINGLE, BYREF powery AS SINGLE, BYREF xpixmax AS LONG, _
                    BYREF ypixmax AS LONG, BYREF logpixelsx AS LONG, BYREF rowsnew AS LONG)
            ' -
            DIM start AS SINGLE,stepsize AS SINGLE, labels AS LONG
            DIM xstep AS SINGLE,xlabels AS LONG, xhigh AS SINGLE
            DIM ystep AS SINGLE,ylabels AS LONG, yhigh AS SINGLE
            DIM xlow AS SINGLE, ylow AS SINGLE
            DIM lemarg AS SINGLE, rimarg AS SINGLE, upmarg AS SINGLE, lomarg AS SINGLE
            DIM xconvfac AS SINGLE, yconvfac AS SINGLE
            LOCAL i AS LONG, hpen AS LONG
            LOCAL xpix AS SINGLE,ypix AS SINGLE, radius AS SINGLE
            LOCAL ystart AS SINGLE,yend AS SINGLE,penwidth AS SINGLE
            '
            fillrect hdc, rct, getstockobject(%white_brush)
            IF ABS(xmax) > ABS(xmin) THEN
                powerx = xmax
            ELSE
                powerx = xmin
            END IF
            powerx = INT(LOG10(ABS(powerx) / 10))
            IF ABS(ymax) > ABS(ymin) THEN
                powery = ymax
            ELSE
                powery = ymin
            END IF
            powery = INT(LOG10(ABS(powery) / 10))
            CALL findaxisdimandscale(xmax, xmin, xlow, xstep, xlabels)
            CALL findaxisdimandscale(ymax, ymin, ylow, ystep, ylabels)
            xhigh = xlow + (xlabels - 1) * xstep
            yhigh = ylow + (ylabels - 1) * ystep
            ' define wideness of "margins" for plot
            lemarg = xpixmax/9
            rimarg = xpixmax/15
            upmarg = ypixmax/9
            lomarg = ypixmax/6.5
            xconvfac = (xpixmax - lemarg - rimarg) / (xhigh - xlow)
            yconvfac = (ypixmax - upmarg - lomarg) / (yhigh - ylow)
            CALL makexandyaxiswithtext(hdc,lemarg, lomarg, rimarg, upmarg, xlow, xstep, xhigh, _
                 ylow, ystep, yhigh, xconvfac, yconvfac, xtxt$, ytxt$, 0, rct, logpixelsx, _
                 xpixmax, ypixmax, powerx, powery)
            '
            penwidth=logpixelsx/254*2.1
            hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(1))) ' blue
            ' draw curve
            xpix=ROUND((numdat(1,1)-xlow)*xconvfac+lemarg,0)
            ypix=ROUND(ypixmax-((numdat(1,2)-ylow)*yconvfac+lomarg),0)
            movetoex hdc, xpix, ypix, BYVAL %null
            FOR i=2 TO rowsnew
                xpix=ROUND((numdat(i,1)-xlow)*xconvfac+lemarg,0)
                ypix=ROUND(ypixmax-((numdat(i,2)-ylow)*yconvfac+lomarg),0)
                lineto hdc, xpix, ypix
            NEXT
        END SUB
        '
        SUB findaxisdimandscale (BYVAL maxval AS SINGLE,BYVAL minval AS SINGLE, _
                BYREF start AS SINGLE,BYREF stepsize AS SINGLE,BYREF labels AS LONG)
            '
            LOCAL RANGE AS DOUBLE, eksp AS DOUBLE, bbbb AS DOUBLE, iii AS LONG
            RANGE = maxval - minval
            RANGE = LOG10(RANGE)
            eksp = CEIL(RANGE)
            RANGE = 10 ^ (RANGE - eksp)
            WHILE RANGE < 1
                RANGE = RANGE * 10
                eksp = eksp - 1
            WEND
            IF CEIL(RANGE) >= 5 THEN
                labels = CEIL(RANGE) + 1
                stepsize = 1 * 10 ^ eksp
            ELSEIF CEIL(RANGE) >= 2 THEN
                labels = CEIL(2 * RANGE) + 1
                stepsize = .5 * 10 ^ eksp
            ELSE
                labels = CEIL(5 * RANGE) + 1
                stepsize = .2 * 10 ^ eksp
            END IF
            bbbb = 0
            IF maxval > 0 THEN
                iii = 1
                DO
                    iii = iii + 1
                    bbbb = bbbb + stepsize
                LOOP UNTIL bbbb > maxval
                IF (iii - labels) * stepsize > minval THEN labels = labels + 1
                    start = (iii - labels) * stepsize
            ELSE
                iii = 0
                DO
                    iii =  iii -1
                    bbbb = bbbb - stepsize
                LOOP UNTIL bbbb < minval
                IF (iii + labels - 1) * stepsize < maxval THEN labels = labels + 1
                start = iii * stepsize
            END IF
        END SUB
        '
        SUB makexandyaxiswithtext (BYVAL hdc AS LONG, BYVAL lemarg AS SINGLE, BYVAL lomarg AS SINGLE, BYVAL rimarg AS SINGLE, _
            BYVAL upmarg AS SINGLE, BYVAL xlow AS SINGLE, BYVAL xstep AS SINGLE, BYVAL xhigh AS SINGLE, BYVAL ylow AS SINGLE, _
            BYVAL ystep AS SINGLE, BYVAL yhigh AS SINGLE, BYVAL xconvfac AS SINGLE, BYVAL yconvfac AS SINGLE, BYVAL xtxt$, _
            BYVAL ytxt$,BYVAL ipat AS LONG, BYREF rct AS rect, BYREF logpixelsx AS LONG, BYREF xpixmax AS LONG, _
            BYREF ypixmax AS LONG, BYREF powerx AS SINGLE, BYREF powery AS SINGLE)
            '-
            LOCAL lpsz AS ASCIIZ * 255
            LOCAL hpen AS LONG, hfont AS LONG
            LOCAL i AS LONG, flag AS LONG, kk AS LONG, longtics AS LONG
            LOCAL res&
            LOCAL si AS SINGLE, ex AS STRING, xx1 AS SINGLE
            LOCAL yy1 AS SINGLE
            LOCAL xval AS SINGLE, yval AS SINGLE, penwidth AS SINGLE
            LOCAL lpsize AS sizel
            '-
            res&=fillrect(hdc, rct, getstockobject(%white_brush))
            '
            hfont=makefont(18,400,0,0,0,"arial")
            selectobject hdc, hfont
            settextalign hdc,%ta_left
        
            penwidth=logpixelsx/254*2.1
            hpen = selectobject(hdc, createpen(penstyle(0), penwidth, gcolor(0)))  ' black pen
            '
            '- draw x-axis and y-axis
            movetoex hdc, xpixmax-rimarg,ypixmax-lomarg, BYVAL %null
            lineto hdc, lemarg,ypixmax-lomarg
            lineto hdc, lemarg,upmarg
            '
            ' check number of ciphers in tic labels on x-axis
            xval = xlow
            FOR si = lemarg TO xpixmax - rimarg STEP xconvfac * xstep * .9999
                IF ABS(powerx)>=3 THEN
                    xx1 = INT(xval / 10 ^ powerx + .5)
                ELSE
                    xx1=ROUND(xval,3)
                END IF
                xval = xval + xstep
                IF ABS(xx1)>=10000 THEN longtics = 1
                INCR kk
            NEXT
        
            IF longtics = 1 AND kk >=8 THEN flag = 1 ' many long tic labels.
            '
            '- make tic intervals and labels on x-axis
            xval = xlow : kk = 0
            settextalign hdc,%ta_center
            FOR si = lemarg TO xpixmax - rimarg STEP xconvfac * xstep * .9999
                IF ABS(powerx)>=3 THEN
                    xx1 = INT(xval / 10 ^ powerx + .5)
                ELSE
                    xx1=ROUND(xval,3)
                END IF
                lpsz = LTRIM$(STR$(xx1))
                res&=gettextextentpoint32(hdc,lpsz,BYVAL LEN(lpsz),lpsize)
                INCR kk
                IF flag = 1 THEN ' only show every other tic label
                    IF kk MOD 2 = 1 THEN textout hdc, si, ypixmax-lomarg+ypixmax/40, lpsz, BYVAL LEN(lpsz)
                    IF kk MOD 2 = 0 THEN lpsize.cx = 0
                ELSE             ' show every tic label
                    textout hdc, si, ypixmax-lomarg+ypixmax/40, lpsz, BYVAL LEN(lpsz)
                END IF
                movetoex hdc, si,ypixmax-lomarg, BYVAL %null
                lineto hdc, si,ypixmax-lomarg+ypixmax/50
                xval = xval + xstep
            NEXT
            '
            '- put name of x-variable on diagram
            IF powerx >=3 THEN ex$ = " / 10^" + MID$(STR$(-powerx), 2)
            IF ABS(powerx)<3 THEN ex$ = "
            IF powerx <=-3 THEN ex$ = " x 10^" + MID$(STR$(powerx), 2)
            xtxt$ = xtxt$ + ex$
            lpsz=xtxt$
            settextalign hdc,%ta_right
            textout hdc, xpixmax-rimarg+lpsize.cx*0.5, ypixmax-lomarg+ypixmax/13, lpsz, BYVAL LEN(lpsz)
            '
            '- make tic intervals and labels on y-axis
            yval = ylow
            FOR si = ypixmax-lomarg TO upmarg STEP -yconvfac * ystep * .9999
                IF ABS(powery)>=3 THEN
                    yy1 = INT(yval / 10 ^ powery + .5)
                ELSE
                    yy1=ROUND(yval,3)
                END IF
                lpsz = LTRIM$(STR$(yy1))
                res&=gettextextentpoint32(hdc,lpsz,BYVAL LEN(lpsz),lpsize)
                textout hdc, lemarg-xpixmax/48, si-lpsize.cy*0.5, lpsz, BYVAL LEN(lpsz)
                yval = yval + ystep
                movetoex hdc,lemarg, si, BYVAL %null
                lineto hdc, lemarg-xpixmax/70,si
            NEXT
            '-put name of y-variable on diagram
            IF powery >= 3 THEN ex$ = " / 10^" + MID$(STR$(-powery), 2)
            IF ABS(powery) <3 THEN ex$ = "
            IF powery < -3 THEN ex$ = " x 10^" + MID$(STR$(powery), 2)
            ytxt$ = ytxt$ + ex$
            lpsz=ytxt$
            settextalign hdc,%ta_left
            textout hdc, lemarg-xpixmax/48-lpsize.cx,upmarg-ypixmax/13, lpsz, BYVAL LEN(lpsz)
            deleteobject hfont
        END SUB
        '
        ' ---------------------------------------------------------
        CALLBACK FUNCTION form1_dlgproc
            LOCAL hemf AS LONG,lpszfile AS ASCIIZ*80
            LOCAL hdcemf AS LONG
            LOCAL hdc AS LONG
            LOCAL res&
            STATIC grafcopyflag AS LONG
            LOCAL i#,kk&,jj#
            LOCAL hdcref AS LONG,iwidthmm AS LONG,iheightmm AS LONG,iwidthpels AS LONG,iheightpels AS LONG
            STATIC hform1_menu0 AS LONG
            STATIC hform1_menu2 AS LONG
            STATIC hgraph AS LONG      ' handle for graphics window - a label (or static) control
            STATIC brush AS LONG
            STATIC rows AS LONG        ' number of rows in array
            STATIC rowsnew AS LONG     ' number of rows with complete x,y values in a given analysis
            STATIC logpixelsy AS LONG  ' pixels per inch of screen height
            STATIC logpixelsx AS LONG  ' pixels per inch of screen width
            STATIC numdat() AS SINGLE  ' numerical data array
            STATIC xmax AS SINGLE, xmin AS SINGLE, ymax AS SINGLE, ymin AS SINGLE
            STATIC powerx AS SINGLE, powery AS SINGLE
            STATIC xvar AS LONG,yvar AS LONG
            STATIC grflag AS LONG
            STATIC xdialun AS LONG,ydialun AS LONG,xpixmax AS LONG,ypixmax AS LONG
            STATIC rct AS rect
            STATIC ps AS paintstruct   ' paint structure
            STATIC xfact AS SINGLE, yfact AS SINGLE
            STATIC xtext$,ytext$
            STATIC labelstyle AS LONG,labelstyle2 AS LONG
            STATIC n AS LONG, ct AS LONG, r AS LONG
            '
            SELECT CASE CBMSG
                '
                CASE %WM_INITDIALOG
                    labelstyle = %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER
                    xdialun = 334*2 : ydialun = 233*2
                    xpixmax = xdialun : ypixmax = ydialun
                    xfact = 1.0 : yfact = 1.0
                    labelstyle2& = %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME OR %SS_LEFT
                    ' nb: the grayframe style must be included
                    CONTROL ADD LABEL, CBHNDL,  %form1_graphlabel,  "", 8, 8, xdialun,ydialun, labelstyle2 ',%ws_ex_clientedge
                    CONTROL HANDLE CBHNDL, %form1_graphlabel TO hgraph ' handle for graphics window
                    MENU NEW BAR TO hform1_menu0
                    MENU NEW POPUP TO hform1_menu2
                    MENU ADD POPUP, hform1_menu0 ,"&Copy", hform1_menu2, %MF_ENABLED
                    MENU ADD STRING, hform1_menu2, "Copy present &Graph to Clipboard", %form1_graphcopy, %MF_ENABLED       ' %mf_grayed
                    MENU ATTACH hform1_menu0, CBHNDL
        
                    brush=createsolidbrush(RGB(255,255,255)) ' white
                    hdc = getdc(%HWND_DESKTOP)
                    logpixelsy  = getdevicecaps(hdc, %logpixelsy)
                    logpixelsx  = getdevicecaps(hdc, %logpixelsx)
                    releasedc %HWND_DESKTOP, hdc
                    REDIM numdat(1 TO 5000,1 TO 2)
                    grflag = 10
        
                    ' create curve points (x,y)
                    FOR i = 0.95 TO 18.7*ATN(1) STEP 0.02
                        INCR kk
                        numdat(kk,1) = i                     ' x-value
                        numdat(kk,2) = 50#*1#/(2+SIN(i))-20  ' function value y (you can replace with any other function you want to display)
                        xmax=MAX(xmax,numdat(kk,1))
                        xmin=MIN(xmin,numdat(kk,1))
                        ymax=MAX(ymax,numdat(kk,2))
                        ymin=MIN(ymin,numdat(kk,2))
                    NEXT
                    xtext$ = "x-value"
                    ytext$ = "function value y"
                    rows = 2
                    grflag = 10
                    rowsnew = kk ' number of points used
        
                CASE %WM_PAINT
                    beginpaint CBHNDL, ps
                    IF grflag=10 THEN ' graph can be made
                        '
                        ' specify rectancle in 0.01 mm units for creation of metafile:
                        '
                        ' obtain a handle to a reference device context.
                        hdcref = getdc(CBHNDL)
                        '
                        ' determine the picture frame dimensions.
                        ' iwidthmm is the display width in millimeters.
                        ' iheightmm is the display height in millimeters.
                        ' iwidthpels is the display width in pixels.
                        ' iheightpels is the display height in pixels
        
                        iwidthmm = getdevicecaps(hdcref, %horzsize)
                        iheightmm = getdevicecaps(hdcref, %vertsize)
                        iwidthpels = getdevicecaps(hdcref, %horzres)
                        iheightpels = getdevicecaps(hdcref, %vertres)
                        releasedc CBHNDL, hdcref
        
                        ' retrieve the coordinates of the client
                        ' rectangle, in pixels.
                        getclientrect hgraph,rct
        
                        ' convert client coordinates to .01-mm units.
                        ' use iwidthmm, iwidthpels, iheightmm, and
                        ' iheightpels to determine the number of
                        ' .01-millimeter units per pixel in the x-
                        ' and y-directions.
        
                        rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
                        rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
                        rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
                        rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
                        '
                        hdcemf = createenhmetafile (%null, BYVAL %null, rct, BYVAL %null)
                        ' get rectangle in pixels to display diagram
                        getclientrect hgraph,rct
                        '
                        CALL prepareandmakegraph (hdcemf,2, rows, xmax, xmin, ymax, ymin, 1, 2, _
                            numdat(), xtext$, ytext$, rct, powerx, powery, xpixmax, ypixmax, _
                            logpixelsx, rowsnew)
                        '
                        hemf = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
                        ' handle to label where the diagram is to be drawn
                        hdc = getdc(getdlgitem(CBHNDL, %form1_graphlabel))
                        CALL playenhmetafile (hdc, hemf, rct)
                        ' "plays" the metafile in the label window,
                        ' i.e. the graphics procedures are now being performed in
                        ' that window.
                        IF grafcopyflag=3 THEN ' copy graphic enhanced metafile to clipboard
                            ' this code is due to peter stephensen:
                            IF openclipboard(%null) THEN
                                emptyclipboard
                                setclipboarddata %CF_ENHMETAFILE, hemf
                                closeclipboard
                            END IF
                            grafcopyflag=0
                        END IF
                    ELSE
                        hdc = getdc(getdlgitem(CBHNDL, %form1_graphlabel))
                        res&=fillrect (hdc, rct, getstockobject(%white_brush))
                    END IF
                    endpaint CBHNDL, ps
                    releasedc getdlgitem(CBHNDL,%form1_graphlabel), hdc
                    FUNCTION = 1
                CASE %WM_DESTROY
                    deleteobject brush
                    postquitmessage 0
        
                CASE %WM_COMMAND
                    SELECT CASE  CBCTL
                        CASE  %form1_graphcopy
                            ' the following causes the metafile to be copied to the clipboard.
                            grafcopyflag=3   ' see case %wm_paint above
                            res&=invalidaterect(CBHNDL, BYVAL %null, %true)
                        CASE ELSE
                    END SELECT
                CASE ELSE
            END SELECT
        END FUNCTION
        '
        ' ------------------------------------------------
        FUNCTION PBMAIN
            LOCAL count&
            LOCAL style1 AS LONG, hform1 AS LONG
            style1 = %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
            DIALOG NEW PIXELS, 0, "Curve Drawing", 0, 0,  342*2,  250*2, style1, 0 TO hform1
            DIALOG SHOW MODELESS hform1 , CALL form1_dlgproc
            DO
                DIALOG DOEVENTS TO count&
            LOOP UNTIL count&=0
        END FUNCTION
        Attached Files

        Comment

        Working...
        X