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

PieChart (improved) to metafile

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

  • PieChart (improved) to metafile

    ' Enhanced metafile Graphics program using PowerBasic DDT.
    ' ********************************************************
    ' This graphics program bit can draw directly to enhanced metafiles
    ' which may be used directly as scalable diagrams in current Windows
    ' word processor programs like Word or WordPerfect for Windows.

    ' It is an improved version of my Graphics program kindly posted
    ' by Lance Edmonds to the PoverBasic Source Code Forum November 7, 2000.

    ' A label control is used as the graphics window. This was inspired
    ' by Forum notes by Lance Edmonds.

    ' The purpose is to illustrate how graphics may be made quite easily.

    ' This version applies enhanced metafiles. Metafiles are made up of
    ' the graphics instructions needed to make the diagram. Because
    ' they are not using bitmaps, the metafiles are very small.

    ' The instructions in the metafile can be read and understood by
    ' Windows while using other Windows programs. In particular they can
    ' be inserted in the text in word processors, and there they can be
    ' rescaled, enlarged or diminished to fit the particular area to be
    ' used without loss of resolution or sharpness.

    ' As it now stands the program will save the enhanced metafile in the
    ' current directory with the filename "EMF00.EMF".

    ' This file can then be included anywhere in the text in your word
    ' processor program. By clicking on the upper or lower border, handles
    ' will be provided to resize and rescale the diagram. You should try
    ' this out. You can print your text with the diagram on your printer.

    ' I hope this may inspire further progress and improvement. I am sure
    ' many of you will have suggestions to make.

    ' One feature I have not yet been able to provide is copying the
    ' enhanced metafile to the clipboard. If anybody knows how to do
    ' that, I would be grateful to know.

    ' Any comments and suggestions are welcome.
    ' Erik Christensen, Copenhagen, Denmark
    ' e.chr@email.dk
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    
    #INCLUDE "win32api.inc"
    
    DECLARE FUNCTION gColor(BYVAL I AS LONG) AS LONG
    DECLARE FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
    DECLARE FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
    DECLARE SUB ShowForm(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION DLGPROC
    
    %graphlabel = 100
    
    GLOBAL hForm&
    GLOBAL X&,Y&,X1&,Y1&
    GLOBAL Rct AS RECT
    GLOBAL Ps AS PAINTSTRUCT
    GLOBAL hPen AS LONG
    GLOBAL hBrush AS LONG
    
    FUNCTION PBMAIN
        LOCAL Count&
        ShowForm 0
        DO
          DIALOG DOEVENTS TO Count&
        LOOP UNTIL Count&=0
    END FUNCTION
    
    SUB ShowForm(BYVAL hParent&)
        LOCAL Style&, ExStyle&
        Style& = %DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
        ' NB: The clipchildren style must be included
        ExStyle& = 0
        X&=240:Y&=180
        DIALOG NEW hParent&, "Graphics Window", 0, 0,  X&, Y&, Style&, ExStyle& TO hForm&
        DIALOG UNITS hForm&, X&, Y& TO PIXELS X1&, Y1&
        ' The graphics routines use pixels. Hence this conversion.
        CONTROL ADD LABEL, hForm&,  %graphlabel,  "", 0, 0, X&,Y&, _
            %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME
        ' NB: The grayframe style must be included
        DIALOG SHOW MODELESS hForm& , CALL DLGPROC
    END SUB
    
    CALLBACK FUNCTION DLGPROC
    
        LOCAL hemf     AS LONG
        LOCAL szFile   AS ASCIIZ*80
        LOCAL szDesc   AS ASCIIZ*80
        LOCAL cNull    AS STRING*1
        LOCAL hDC AS LONG
        LOCAL hdcEMF AS LONG
        LOCAL Re AS LONG
    
    
        %DiskMetafile = %TRUE ' when set to true the enhanced metafile
                               ' is saved on disk
    
        '%DiskMetafile = %FALSE ' when set to false the enhanced metafile
                               ' is only in memory
        SELECT CASE CBMSG
    
            CASE %WM_PAINT
              IF %DiskMetafile THEN
                 cNull = CHR$(0)
                 szFile = "EMF00.EMF"  ' file name of enhanced metafile
                 ' you may include the relevant path here to place the
                 ' graphics file where it would be most convenient
                 ' e.g. "C:\WINWORD\EMF0.EMF"
                 ' otherwise it will be placed in the current directory
    
                 szDesc = "EMFfile" + cNull + "PieChart no. 0" + cNull
                 ' description of enhanced metafile. The description should
                 ' follow the above structure.
                 ' I am not sure of the significance of this description.
    
                 hdcEMF = CreateEnhMetafile (%NULL, szFile, BYVAL %NULL, szDesc)
                 ' Create metafile device context
              ELSE
                 hdcEMF = CreateEnhMetafile (%NULL, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
              END IF
    
              CALL PieChart(hdcEMF) ' put graphics in an enhanced metafile
    
              hemf = CloseEnhMetafile (hdcEMF) ' get handle to enhanced metafile
    
              BeginPaint CBHNDL, Ps
    
              hDC = GetDC(GetDlgItem(CBHNDL, %graphlabel))
              ' handle to label where the diagram is to be drawn
    
              GetClientRect CBHNDL, Rct
    
              IF %DiskMetafile THEN hemf = GetEnhMetafile (szFile)
    
              CALL PlayEnhMetafile (hDC, hemf, Rct)
              ' "plays" the metafile in the label window,
              ' i.e. the graphics procedures are now being performed in
              ' that window.
    
              EndPaint CBHNDL, Ps
    
              IF %DiskMetafile THEN CALL DeleteEnhMetafile (hemf)       'Deletes metafile handle
              ReleaseDC GetDlgItem(CBHNDL, %graphlabel), hDC
              DeleteObject SelectObject(hDC, hPen)
              DeleteObject SelectObject(hDC, hBrush)
    
            FUNCTION = 0
    
          CASE ELSE
        END SELECT
    END FUNCTION
    
    SUB PieChart(hDC AS LONG)
        DIM DA(10) AS SINGLE
        DIM gText(10) AS ASCIIZ * 200
        LOCAL gTex AS ASCIIZ * 200
        LOCAL I AS LONG
        LOCAL TOTAL AS SINGLE
        LOCAL CUMUL AS SINGLE
        LOCAL pi2 AS SINGLE
        LOCAL pct AS LONG, Radius AS LONG
        LOCAL recstart AS LONG
        LOCAL RC AS RECT
        LOCAL Font AS LONG
        LOCAL FontSize AS LONG
        LOCAL FontName AS STRING
        LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
        LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
        LOCAL xText AS LONG, yText AS LONG, korr AS LONG
    
        hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(7)))
            ' white pen
    
        Rectangle hDC,0,0,X1&,Y1&
        ' Invisible delineation of graphics area.
        ' This seems to be important to define the area explicitly
        ' for the enhanced metafile
    
        FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
    
        hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(0))) ' black pen
    
        ' Make frame to illustrate line-drawing
        ' This can easily be deleted. It is not very artistic.
        FOR I=3 TO 15 STEP 3
    
          ' CreatePen(PenStyle,PenWidth,PenColor)
          ' PenWidth is in logical units, but zero always
          ' corresponds to 1 pixel.
          hPen = SelectObject(hDC, CreatePen(PenStyle(I/3-1), 0, gColor(I/3-1)))
    
          MoveToEx hDC, I,I, BYVAL %NULL
          LineTo hDC, X1&-I,I
          LineTo hDC, X1&-I,Y1&-I
          LineTo hDC, I,Y1&-I
          LineTo hDC, I,I
        NEXT
    
        Radius = Y1&/3.6
    
    
        xLeft  = X1&/2 - Radius : xRight =  X1&/2 + Radius
        yTop   = Y1&/2 - Radius : yBottom = Y1&/2 + Radius
    
        'This is how a circle can be drawn in the middle of the diagram:
        'Ellipse hDC, xLeft,yTop,xRight,yBottom
        'This is not necessary at this stage
    
        DATA Andersen, Kierkegaard, Bohr, Borge, Hein
        ' these names are quite arbitrary
        FOR I=1 TO 5
           gText(I)=READ$(I)
        NEXT
    
        DATA 5.6,  7.2,  5.2,  3.3,  8.9
        ' these numbers are arbitrary without any relation to the names above
        TOTAL=0
    
        FOR I=1 TO 5
          DA(I) = VAL(READ$(I+5))
          TOTAL = TOTAL + DA(I)
        NEXT
    
    
        FontSize=10 ' sizes between 8 and 10 are most suitable here
        ' FontSize=8
        ' FontSize=9
    
        FontName = "Arial"
        ' Other FontNames you can immediately use instead are:
        ' FontName = "Courier New"
        ' FontName = "Times New Roman"
        Font = MakeFont(FontName,FontSize)
        SelectObject hDC, Font
    
        pi2=8*ATN(1)
        CUMUL=0
        korr=-11 ' empiric correction for height of characters. This may be improved.
        FOR I=1 TO 5
          CUMUL = CUMUL + DA(I)
          pct=INT(100*DA(I)/TOTAL+0.5)
          xText = INT(X1&/2+(Radius-korr)*COS(pi2 * (CUMUL - DA(I)/2) / TOTAL)+0.5)
          yText = INT(Y1&/2-(Radius-korr)*SIN(pi2 * (CUMUL - DA(I)/2) / TOTAL)+0.5)
          IF COS(pi2 * (CUMUL - DA(I)/2) / TOTAL) >= 0 THEN
            SetTextAlign hDC,%TA_LEFT ' text on right side of diagram
          ELSE
            SetTextAlign hDC,%TA_RIGHT ' text on left side of diagram
          END IF
          gTex=gText(I)+" ("+LTRIM$(STR$(pct))+"%)"
          TextOut hDC, xText, yText+korr, gTex, BYVAL LEN(gTex)
        NEXT
    
        xStart=X1&/2+Radius: yStart=Y1&/2 ' select starting point for pie pieces
        CUMUL=0
    
        FOR I=1 TO 5
          CUMUL = CUMUL + DA(I)
          xEnd  = INT(X1&/2+Radius*COS(pi2 * CUMUL / TOTAL)+0.5)
          yEnd  = INT(Y1&/2-Radius*SIN(pi2 * CUMUL / TOTAL)+0.5)
    
          hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(I)))
          hBrush = SelectObject(hDC, CreateSolidBrush (gColor(I)))
    
          Pie hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
    
          xStart=xEnd: yStart=yEnd
        NEXT
    
    'These are other graphic features you may want to use in your application:
    'RoundRect hDC, xLeft,yTop,xRight,yBottom, xCornerEllipse, yCornerEllipse
    'Arc hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
    'Chord hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
    
    END SUB
    
    
    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
        ' Other colors can be defined 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 = 0 '%PS_SOLID       _______
        CASE 1 :   FUNCTION = 1 '%PS_DASH        -------
        CASE 2 :   FUNCTION = 2 '%PS_DOT         .......
        CASE 3 :   FUNCTION = 3 '%PS_DASHDOT     _._._._
        CASE 4 :   FUNCTION = 4 '%PS_DASHDOTDOT  _.._.._
        CASE ELSE: FUNCTION = 0 '%PS_SOLID
      END SELECT
    END FUNCTION
    
    
    FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
       ' this is a modification of a function provided to
       ' the PoverBasic Forum by Timm Motl
       LOCAL hDC AS LONG
       LOCAL CyPixels AS LONG
    
       hDC = GetDC(%HWND_DESKTOP)
       CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
       ReleaseDC %HWND_DESKTOP, hDC
       PointSize = (PointSize * CyPixels) \ 72
    
       ' Define variables for the Window's CreateFont function which
       ' provides a number of options which can be very interesting for
       ' graphic diagrams.
    
       ' See Win32api help file: Win32 Programmer's Reference for details
       ' ****************************************************************
       LOCAL Height AS LONG            ' logical height of font
       LOCAL Width1 AS LONG            ' logical average character width
       LOCAL Escapement AS LONG        ' angle of escapement
       LOCAL Orientation AS LONG       ' base-line orientation angle
       LOCAL Weight AS LONG            ' font weight
       LOCAL Italic AS LONG            ' italic attribute flag
       LOCAL Underline AS LONG         ' underline attribute flag
       LOCAL StrikeOut AS LONG         ' strikeout attribute flag
       LOCAL CharSet AS LONG           ' character set identifier
       LOCAL OutputPrecision AS LONG   ' output precision
       LOCAL ClipPrecision AS LONG     ' clipping precision
       LOCAL Quality AS LONG           ' output quality
       LOCAL PitchAndFamily AS LONG    ' pitch and family
       LOCAL TypeFaceName AS ASCIIZ*50 ' typeface name string
    
     ' from win32api.inc file:
     ' DECLARE FUNCTION CreateFont LIB "GDI32.DLL" ALIAS "CreateFontA" _
     ' (BYVAL Height AS LONG, BYVAL Width1 AS LONG, BYVAL Escapement AS LONG, _
     ' BYVAL Orientation AS LONG, BYVAL Weight AS LONG, BYVAL Italic AS LONG,_
     ' BYVAL Underline AS LONG, BYVAL StrikeOut AS LONG, _
     ' BYVAL CharSet AS LONG, BYVAL OutputPrecision AS LONG, _
     ' BYVAL ClipPrecision AS LONG, BYVAL Quality AS LONG, _
     ' BYVAL PitchAndFamily AS LONG, TypeFaceName AS ASCIIZ) AS LONG
    
       Height = 0 - PointSize            ' logical height of font
       Width1 = 0                        ' logical average character width
       Escapement = 0                    ' angle of escapement
       Orientation = 0                   ' base-line orientation angle
       Weight = %FW_NORMAL               ' font weight (various degrees
                                         '     of thin or bold types
                                         '     can be defined)
       Italic = 0                        ' italic attribute flag (0,1)
       Underline = 0                     ' underline attribute flag (0,1)
       StrikeOut = 0                     ' strikeout attribute flag (0,1)
       CharSet = %ANSI_CHARSET           ' character set identifier
       OutputPrecision = %OUT_TT_PRECIS  ' output precision
       ClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
       Quality = %DEFAULT_QUALITY        ' output quality
       PitchAndFamily = %FF_DONTCARE     ' pitch and family
       TypeFaceName = FontName           ' typeface name string
    
       FUNCTION = CreateFont(Height,Width1,Escapement,Orientation,Weight, _
                             Italic,Underline,StrikeOut,CharSet, _
                             OutputPrecision,ClipPrecision,Quality, _
                             PitchAndFamily,BYCOPY TypeFaceName)
    END FUNCTION

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


    [This message has been edited by Erik Christensen (edited December 20, 2000).]

  • #2
    Hej Erik,

    Nice code.
    To copy to the clipboard, try the following:
    set
    Code:
    %DiskMetafile = %FALSE
    Paste the following code right after "CALL PlayEnhMetafile (hDC, hemf, Rct)"
    Code:
    %CF_ENHMETAFILE = 14
     
    if OpenClipboard(%NULL) then
        EmptyClipboard
        SetClipboardData %CF_ENHMETAFILE, hemf
        CloseClipboard
    end if
    Run your program.
    Go to Excel or Word and press Ctrl+V.

    Regards
    Peter (psp.dst.dk)

    P.S. Hyggeligt at møde en dansker her.
    Sæt (code)...(/code) rundt om din kode (med kantede paranteser).
    Så bliver den meget pænere.



    [This message has been edited by Peter P Stephensen (edited November 12, 2000).]
    psp@dreammodel.dk
    www.dreammodel.dk

    Comment


    • #3
      Hi Peter

      Thank you very much for your tip. I tried it out. It works perfectly. It is very easy to implement in the program.

      Regards,
      Erik



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

      Comment


      • #4
        ' This version draws clockwise starting from 12:00.
        '
        ' The graph is drawn using the enhanced metafiles format. In this
        ' version the graph is copied immediately to the clipboard from
        ' where you can paste it immediately to other programs like Word.
        '
        ' Good Luck!
        '
        ' Erik ---- e.chr@email.dk
        Code:
        #COMPILE EXE
        #REGISTER NONE
        #DIM ALL
        
        #INCLUDE "win32api.inc"
        
        DECLARE FUNCTION gColor(BYVAL I AS LONG) AS LONG
        DECLARE FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
        DECLARE FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
        DECLARE SUB ShowForm(BYVAL hParent&)
        DECLARE CALLBACK FUNCTION DLGPROC
        
        %graphlabel = 100
        
        GLOBAL hForm&
        GLOBAL X&,Y&,X1&,Y1&
        GLOBAL Rct AS RECT
        GLOBAL Ps AS PAINTSTRUCT
        GLOBAL hPen AS LONG
        GLOBAL hBrush AS LONG
        
        FUNCTION PBMAIN
            LOCAL Count&
            ShowForm 0
            DO
              DIALOG DOEVENTS TO Count&
            LOOP UNTIL Count&=0
        END FUNCTION
        
        SUB ShowForm(BYVAL hParent&)
            LOCAL Style&, ExStyle&
            Style& = %DS_MODALFRAME OR %WS_CAPTION OR %WS_SYSMENU OR %DS_CENTER OR %WS_CLIPCHILDREN
            ' NB: The clipchildren style must be included
            ExStyle& = 0
            X&=240:Y&=180
            DIALOG NEW hParent&, "Graphics Window", 0, 0,  X&, Y&, Style&, ExStyle& TO hForm&
            DIALOG UNITS hForm&, X&, Y& TO PIXELS X1&, Y1&
            ' The graphics routines use pixels. Hence this conversion.
            CONTROL ADD LABEL, hForm&,  %graphlabel,  "", 0, 0, X&,Y&, _
                %WS_CHILD OR %WS_VISIBLE OR %SS_GRAYFRAME 'OR %WS_VSCROLL OR %WS_HSCROLL
            ' NB: The grayframe style must be included
            DIALOG SHOW MODELESS hForm& , CALL DLGPROC
        END SUB
        
        CALLBACK FUNCTION DLGPROC
        
            LOCAL hemf     AS LONG
            LOCAL szFile   AS ASCIIZ*80
            LOCAL szDesc   AS ASCIIZ*80
            LOCAL cNull    AS STRING*1
            LOCAL hDC AS LONG
            LOCAL hdcEMF AS LONG
            LOCAL Re AS LONG
        
        
            '%DiskMetafile = %TRUE ' when set to true the enhanced metafile
                                   ' is saved on disk
        
            %DiskMetafile = %FALSE ' when set to false the enhanced metafile
                                   ' is only in memory
            SELECT CASE CBMSG
        
                CASE %WM_PAINT
                  IF %DiskMetafile THEN
                     cNull = CHR$(0)
                     szFile = "EMF00.EMF"  ' file name of enhanced metafile
                     ' you may include the relevant path here to place the
                     ' graphics file where it would be most convenient
                     ' e.g. "C:\WINWORD\EMF00.EMF"
                     ' otherwise it will be placed in the current directory
        
                     szDesc = "EMFfile" + cNull + "PieChart no. 0" + cNull
                     ' description of enhanced metafile. The description should
                     ' follow the above structure.
                     ' I am not sure of the significance of this description.
        
                     hdcEMF = CreateEnhMetafile (%NULL, szFile, BYVAL %NULL, szDesc)
                     ' Create metafile device context
                  ELSE
                     hdcEMF = CreateEnhMetafile (%NULL, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
                  END IF
        
                  CALL PieChart(hdcEMF) ' put graphics in an enhanced metafile
        
                  hemf = CloseEnhMetafile (hdcEMF) ' get handle to enhanced metafile
        
                  BeginPaint CBHNDL, Ps
        
                  hDC = GetDC(GetDlgItem(CBHNDL, %graphlabel))
                  ' handle to label where the diagram is to be drawn
        
                  GetClientRect CBHNDL, Rct
        
                  IF %DiskMetafile THEN hemf = GetEnhMetafile (szFile)
        
                  CALL PlayEnhMetafile (hDC, hemf, Rct)
                  ' "plays" the metafile in the label window,
                  ' i.e. the graphics procedures are now being performed in
                  ' that window.
        
                  '%DiskMetafile = %FALSE
        
                  %CF_ENHMETAFILE = 14
        
                  IF OpenClipboard(%NULL) THEN
                      EmptyClipboard
                      SetClipboardData %CF_ENHMETAFILE, hemf
                      CloseClipboard
                  END IF
        
                  EndPaint CBHNDL, Ps
        
                  IF %DiskMetafile THEN CALL DeleteEnhMetafile (hemf)       'Deletes metafile handle
                  ReleaseDC GetDlgItem(CBHNDL, %graphlabel), hDC
                  DeleteObject SelectObject(hDC, hPen)
                  DeleteObject SelectObject(hDC, hBrush)
        
                FUNCTION = 1
        
              CASE ELSE
            END SELECT
        END FUNCTION
        
        SUB PieChart(BYVAL hDC AS LONG)
            DIM DA(10) AS SINGLE
            DIM gText(10) AS ASCIIZ * 200
            LOCAL gTex AS ASCIIZ * 200
            LOCAL I AS LONG
            LOCAL TOTAL AS SINGLE
            LOCAL CUMUL AS SINGLE
            LOCAL pi2 AS SINGLE
            LOCAL pct AS LONG, Radius AS LONG
            LOCAL recstart AS LONG
            LOCAL RC AS RECT
            LOCAL Fontt AS LONG
            LOCAL FontSize AS LONG
            LOCAL FontName AS STRING
            LOCAL xLeft AS LONG, yTop AS LONG, xRight AS LONG, yBottom AS LONG
            LOCAL xStart AS LONG, yStart AS LONG, xEnd AS LONG, yEnd AS LONG
            LOCAL xText AS LONG, yText AS LONG, korr AS LONG
        
            hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(7)))
                ' white pen
        
            Rectangle hDC,0,0,X1&,Y1&
            ' Invisible delineation of graphics area.
            ' This seems to be important to define the area explicitly
            ' for the enhanced metafile
        
            FillRect hDC, Rct, GetStockObject(%WHITE_BRUSH)
        
            hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(0))) ' black pen
        
            ' Make frame to illustrate line-drawing
            ' This can easily be deleted. It is not very artistic.
            FOR I=3 TO 15 STEP 3
        
              ' CreatePen(PenStyle,PenWidth,PenColor)
              ' PenWidth is in logical units, but zero always
              ' corresponds to 1 pixel.
              hPen = SelectObject(hDC, CreatePen(PenStyle(I/3-1), 0, gColor(I/3-1)))
        
              MoveToEx hDC, I,I, BYVAL %NULL
              LineTo hDC, X1&-I,I
              LineTo hDC, X1&-I,Y1&-I
              LineTo hDC, I,Y1&-I
              LineTo hDC, I,I
            NEXT
        
            Radius = Y1&/3.6
        
        
            xLeft  = X1&/2 - Radius : xRight =  X1&/2 + Radius
            yTop   = Y1&/2 - Radius : yBottom = Y1&/2 + Radius
        
            'This is how a circle can be drawn in the middle of the diagram:
            'Ellipse hDC, xLeft,yTop,xRight,yBottom
            'This is not necessary at this stage
        
            DATA Andersen, Kierkegaard, Bohr, Borge, Hein
            ' these names are quite arbitrary
            FOR I=1 TO 5
               gText(I)=READ$(I)
            NEXT
        
            DATA 5.6,  7.2,  5.2,  3.3,  8.9
            ' these numbers are arbitrary without any relation to the names above
            TOTAL=0
        
            FOR I=1 TO 5
              DA(I) = VAL(READ$(I+5))
              TOTAL = TOTAL + DA(I)
            NEXT
        
        
            FontSize=9 ' sizes between 8 and 10 are most suitable here
            ' FontSize=8
            ' FontSize=10
        
            FontName = "Arial"
            ' Other FontNames you can immediately use instead are:
            ' FontName = "Courier New"
            ' FontName = "Times New Roman"
            Fontt = MakeFont(FontName,FontSize)
            SelectObject hDC, Fontt
        
            pi2=8*ATN(1)
            CUMUL=0
            korr=-11 ' empiric correction for height of characters. This may be improved.
            FOR I=1 TO 5
              CUMUL = CUMUL - DA(I)
              pct=INT(100*DA(I)/TOTAL+0.5)
              xText = INT(X1&/2+(Radius-korr)*COS(pi2*.25 + pi2 * (CUMUL + DA(I)/2) / TOTAL)+0.5)
              yText = INT(Y1&/2-(Radius-korr)*SIN(pi2*.25 + pi2 * (CUMUL + DA(I)/2) / TOTAL)+0.5)
              IF COS(pi2*.25 + pi2 * (CUMUL + DA(I)/2) / TOTAL) >= 0 THEN
                SetTextAlign hDC,%TA_LEFT ' text on right side of diagram
              ELSE
                SetTextAlign hDC,%TA_RIGHT ' text on left side of diagram
              END IF
              gTex=gText(I)+" ("+LTRIM$(STR$(pct))+"%)"
              TextOut hDC, xText, yText+korr, gTex, BYVAL LEN(gTex)
            NEXT
        
            xEnd=X1&/2: yEnd=Y1&/2-Radius ' select starting point for pie pieces
            CUMUL=0
        
            FOR I=1 TO 5
              CUMUL = CUMUL - DA(I)
              xStart  = INT(X1&/2+Radius*COS(pi2*.25 + pi2 * CUMUL / TOTAL)+0.5)
              yStart  = INT(Y1&/2-Radius*SIN(pi2*.25 + pi2 * CUMUL / TOTAL)+0.5)
        
              hPen = SelectObject(hDC, CreatePen(PenStyle(0), 0, gColor(I)))
              hBrush = SelectObject(hDC, CreateSolidBrush (gColor(I)))
        
              Pie hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
        
              xEnd = xStart: yEnd = yStart
            NEXT
        
        'These are other graphic features you may want to use in your application:
        'RoundRect hDC, xLeft,yTop,xRight,yBottom, xCornerEllipse, yCornerEllipse
        'Arc hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
        'Chord hDC, xLeft,yTop,xRight,yBottom, xStart, yStart, xEnd, yEnd
        
        END SUB
        
        
        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
            ' Other colors can be defined 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 = 0 '%PS_SOLID       _______
            CASE 1 :   FUNCTION = 1 '%PS_DASH        -------
            CASE 2 :   FUNCTION = 2 '%PS_DOT         .......
            CASE 3 :   FUNCTION = 3 '%PS_DASHDOT     _._._._
            CASE 4 :   FUNCTION = 4 '%PS_DASHDOTDOT  _.._.._
            CASE ELSE: FUNCTION = 0 '%PS_SOLID
          END SELECT
        END FUNCTION
        
        
        FUNCTION MakeFont(BYVAL FontName AS STRING, BYVAL PointSize AS LONG) AS LONG
           ' this is a modification of a function provided to
           ' the PoverBasic Forum by Timm Motl
           LOCAL hDC AS LONG
           LOCAL CyPixels AS LONG
        
           hDC = GetDC(%HWND_DESKTOP)
           CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
           ReleaseDC %HWND_DESKTOP, hDC
           PointSize = (PointSize * CyPixels) \ 72
        
           ' Define variables for the Window's CreateFont function which
           ' provides a number of options which can be very interesting for
           ' graphic diagrams.
        
           ' See Win32api help file: Win32 Programmer's Reference for details
           ' ****************************************************************
           LOCAL Height AS LONG            ' logical height of font
           LOCAL Width1 AS LONG            ' logical average character width
           LOCAL Escapement AS LONG        ' angle of escapement
           LOCAL Orientation AS LONG       ' base-line orientation angle
           LOCAL Weight AS LONG            ' font weight
           LOCAL Italic AS LONG            ' italic attribute flag
           LOCAL Underline AS LONG         ' underline attribute flag
           LOCAL StrikeOut AS LONG         ' strikeout attribute flag
           LOCAL CharSet AS LONG           ' character set identifier
           LOCAL OutputPrecision AS LONG   ' output precision
           LOCAL ClipPrecision AS LONG     ' clipping precision
           LOCAL Quality AS LONG           ' output quality
           LOCAL PitchAndFamily AS LONG    ' pitch and family
           LOCAL TypeFaceName AS ASCIIZ*50 ' typeface name string
        
         ' from win32api.inc file:
         ' DECLARE FUNCTION CreateFont LIB "GDI32.DLL" ALIAS "CreateFontA" _
         ' (BYVAL Height AS LONG, BYVAL Width1 AS LONG, BYVAL Escapement AS LONG, _
         ' BYVAL Orientation AS LONG, BYVAL Weight AS LONG, BYVAL Italic AS LONG,_
         ' BYVAL Underline AS LONG, BYVAL StrikeOut AS LONG, _
         ' BYVAL CharSet AS LONG, BYVAL OutputPrecision AS LONG, _
         ' BYVAL ClipPrecision AS LONG, BYVAL Quality AS LONG, _
         ' BYVAL PitchAndFamily AS LONG, TypeFaceName AS ASCIIZ) AS LONG
        
           Height = 0 - PointSize            ' logical height of font
           Width1 = 0                        ' logical average character width
           Escapement = 0                    ' angle of escapement
           Orientation = 0                   ' base-line orientation angle
           Weight = %FW_NORMAL               ' font weight (various degrees
                                             '     of thin or bold types
                                             '     can be defined)
           Italic = 0                        ' italic attribute flag (0,1)
           Underline = 0                     ' underline attribute flag (0,1)
           StrikeOut = 0                     ' strikeout attribute flag (0,1)
           CharSet = %ANSI_CHARSET           ' character set identifier
           OutputPrecision = %OUT_TT_PRECIS  ' output precision
           ClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
           Quality = %DEFAULT_QUALITY        ' output quality
           PitchAndFamily = %FF_DONTCARE     ' pitch and family
           TypeFaceName = FontName           ' typeface name string
        
           FUNCTION = CreateFont(Height,Width1,Escapement,Orientation,Weight, _
                                 Italic,Underline,StrikeOut,CharSet, _
                                 OutputPrecision,ClipPrecision,Quality, _
                                 PitchAndFamily,BYCOPY TypeFaceName)
        END FUNCTION
        ------------------

        Comment

        Working...
        X