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

3D-Graphics Using Enhanced Metafile

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

  • 3D-Graphics Using Enhanced Metafile

    ' 3D-Graphics Using Enhanced Metafile.
    '
    ' April 14, 2002
    '
    ' This version uses enhanced metafiles. You can save these to disk and insert
    ' them into Word document for editing. I have tried to implement copying
    ' to the clipboard, but it is not working. Can you figure out why? I would
    ' be grateful to know.
    '
    ' Best wishes
    '
    ' Erik Christensen ----- e.chr@email.dk
    '
    ' April 15: I am not satisfied with the working of the enhanced
    ' metafile. Suggestions for improvement are welcome. Thanks. Erik
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    '
    #INCLUDE "win32api.inc"
    #INCLUDE "COMDLG32.INC"
    ' ----------------------------------------------------------
    %Form1_FILE                                     = 500
    ' ----------------------------------------------------------
    %Form1_SAVEAS                                   = 515
    %Form1_SEPARATOR_520                            = 520
    %Form1_SAVE_CUR_GRAPH                           = 522
    %Form1_GRAPHCOPY                                = 524
    %Form1_EXIT                                     = 525
    ' ----------------------------------------------------------
    %Form1_EDIT                                     = 600
    ' ----------------------------------------------------------
    %Form1_HELP                                     = 700
    ' ----------------------------------------------------------
    %Form1_HELP1                                    = 705
    %Form1_ABOUT                                    = 710
    %FORM1_LABEL_VIEWPOINT       = 100
    %FORM1_LABEL_MOUSEINF        = 102
    %FORM1_GRAPHLABEL            = 105
    %FORM1_BUTTON_UP             = 110
    %FORM1_BUTTON_DOWN           = 115
    %FORM1_BUTTON_LEFT           = 120
    %FORM1_BUTTON_RIGHT          = 125
    %FORM1_BUTTON_CLOSER         = 130
    %FORM1_BUTTON_FARTHER        = 135
    %FORM1_BUTTON_MORE_PERSPEC   = 140
    %FORM1_BUTTON_LESS_PERSPEC   = 145
    %FORM1_BUTTON_ROT_LEFT       = 150
    %FORM1_BUTTON_ROT_RIGHT      = 155
    %FORM1_BUTTON_ROT_STOP       = 160
    
    ' --------------------------------------------------
    DECLARE SUB ShowDialog_Form1(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION Form1_DLGPROC
    DECLARE SUB Form1_HELP1_Select()
    DECLARE SUB Form1_ABOUT_Select()
    DECLARE FUNCTION MakeFont(BYVAL FontTypeSize AS LONG,BYVAL FontWeight AS LONG, _
        BYVAL Italic AS LONG, BYVAL Underline AS LONG,BYVAL StrikeOut AS LONG, _
        BYVAL FaceName AS STRING) AS LONG
    DECLARE FUNCTION CalculatePhi(EX AS SINGLE, EY AS SINGLE) AS SINGLE
    DECLARE FUNCTION FilNameSaveEMF() AS LONG
    DECLARE FUNCTION FilePath(BYVAL Src AS STRING) AS STRING
    DECLARE FUNCTION FileNam(BYVAL Src AS STRING) AS STRING
    DECLARE FUNCTION gColor(BYVAL I AS LONG) AS LONG
    DECLARE FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
    ' *************************************************************
    GLOBAL hForm1&    ' Dialog handle
    ' Global Handles for menus
    GLOBAL hForm1_Menu0&
    GLOBAL hForm1_Menu1&
    GLOBAL hForm1_Menu2&
    GLOBAL hForm1_Menu3&
    '
    GLOBAL hGraph AS LONG
    GLOBAL hDCg AS LONG
    GLOBAL memdc AS LONG
    GLOBAL hbit AS LONG
    GLOBAL hdcEMF AS LONG
    GLOBAL hemf AS LONG
    GLOBAL PAFUemf AS ASCIIZ * %MAX_PATH  ' path and file for enhanced metafile format graph
    '
    GLOBAL GrafCopyFlag AS LONG
    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 XDialUn&,YDialUn&
    GLOBAL Rct AS RECT
    GLOBAL Ps AS PAINTSTRUCT  ' Paint structure
    GLOBAL hPen AS LONG
    GLOBAL hBrush AS LONG
    GLOBAL BrushArray() AS LONG
    GLOBAL Font1 AS LONG, Font2 AS LONG
    GLOBAL EX AS SINGLE,EY AS SINGLE,EZ AS SINGLE
    GLOBAL PPD AS SINGLE
    '
    ' *************************************************************
    '
    FUNCTION PBMAIN
        LOCAL Count&,I&
        LOCAL hDC AS LONG
        'Retrieves a handle of a display device context (DC) for the
        'client area of the specified window (here the desktop).
        hDC = GetDC(%HWND_DESKTOP)
        '
        'Retrieves device-specific information about the number
        'of pixels per logical inch along the screen height and width
        '(depends on screen resolution setting).
        'This is important to define appropriate font sizes.
        LogPixelsY  = GetDeviceCaps(hDC, %LOGPIXELSY)
        LogPixelsX  = GetDeviceCaps(hDC, %LOGPIXELSX)
        '
        ReleaseDC %HWND_DESKTOP, hDC
    
        ShowDialog_Form1 0
    
        ' Create a virtual window
        GetClientRect hGraph,Rct
        hDCg = GetDC(hGraph)
        memdc = CreateCompatibleDC(hDCg)
        hbit = CreateCompatibleBitmap(hDCg, Rct.nRight, Rct.nBottom)
        SelectObject memdc, hbit
        hBrush = GetStockObject(%WHITE_BRUSH)
        SelectObject memdc, hBrush
        PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
    
        EX = 4:EY = 4: EZ = 30   ' Start position of eye (viewpoint)
        PPD = 12                 ' Projection plane distance
        REDIM BrushArray(24)
        FOR I&=0 TO 24
            BrushArray(I&)=CreateSolidBrush(gColor(I&))
        NEXT
        Font1=MakeFont(6,400,0,0,0,"Arial")
        Font2=MakeFont(8,400,0,0,0,"Arial")
        DO
            DIALOG DOEVENTS TO Count&
        LOOP UNTIL Count&=0
        FOR I&=0 TO 24
            DeleteObject BrushArray(I&)
        NEXT
        DeleteObject hBrush
        DeleteObject hPen
        DeleteObject Font1
        DeleteObject Font2
        DeleteDC memdc
        DeleteObject hbit
    END FUNCTION
    '
    ' *************************************************************
    SUB ShowDialog_Form1(BYVAL hParent&)
        LOCAL Style&, ExStyle& ,hCtl&
        LOCAL LabelStyle2&
        ' hParent& = 0 if no parent Dialog
        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
        XDialUn&=398 :YDialUn&=260
        DIALOG NEW hParent&, "3D-Graphics Using Enhanced Metafile", 0, 0,XDialUn&,YDialUn&, Style&, ExStyle& TO hForm1&
        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, "",2,0,298,210, LabelStyle2&
        CONTROL HANDLE hForm1&, %FORM1_GRAPHLABEL TO hGraph ' handle for graphics window
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LEFT, "Increase X (""&Left"")", 50, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_RIGHT, "Decrease X (""&Right"")", 50, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_UP, "Increase Y (""&Up"")", 135, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_DOWN, "Decrease Y (""&Down"")", 135, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_CLOSER, "Decrease Z (""&Forward"")", 220, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_FARTHER, "Increase Z (""&Backward"")", 220, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_MORE_PERSPEC, "I&ncrease Perspective", 305, 215, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_LESS_PERSPEC, "D&ecrease Perspective", 305, 232, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_LEFT, "Rotate Lef&t", 305, 162, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_RIGHT, "Rotate Ri&ght", 305, 179, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD BUTTON, hForm1&, %FORM1_BUTTON_ROT_STOP, "&Stop Rotation", 305, 196, 80, 14, _
        %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP
        CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_VIEWPOINT,"Change Eye Position (Viewpoint):",9,215,34,38, _
        %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
        CONTROL ADD LABEL, hForm1&,%FORM1_LABEL_MOUSEINF, _
        "Change Viewpoint easily:"+$CRLF+$CRLF+"Left Mouse Button Down:"+$CRLF+"   |  : Move Up and Down"+$CRLF+" --- : Rotate Right and Left"+$CRLF+$CRLF+ _
        "Right Mouse Button Down:"+$CRLF+"   |  : Change Distance"+$CRLF+" --- : Change Perspective",305,70,93,90, _
        %WS_CHILD OR %WS_VISIBLE OR %SS_LEFT
    
        ' ---------------------------
        MENU NEW BAR TO hForm1_Menu0&
        ' ---------------------------
        MENU NEW POPUP TO hForm1_Menu1&
        MENU ADD POPUP, hForm1_Menu0& ,"&File", hForm1_Menu1&, %MF_ENABLED
        ' - - - - - - - - - - - - - -
        MENU ADD STRING, hForm1_Menu1&, "Save Data File &As",  %Form1_SAVEAS, %MF_ENABLED
        MENU ADD STRING, hForm1_Menu1&, "-",  %Form1_SEPARATOR_520, %MF_ENABLED
        MENU ADD STRING, hForm1_Menu1&, "E&xit",  %Form1_EXIT, %MF_ENABLED
        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
        '
        MENU NEW POPUP TO hForm1_Menu3&
        MENU ADD POPUP, hForm1_Menu0& ,"&Help", hForm1_Menu3&, %MF_ENABLED
        ' - - - - - - - - - - - - - -
        MENU ADD STRING, hForm1_Menu3&, "&Description of program",  %Form1_HELP1, %MF_ENABLED
        MENU ADD STRING, hForm1_Menu3&, "&About",  %Form1_ABOUT, %MF_ENABLED
        MENU ATTACH hForm1_Menu0&, hForm1&
        DIALOG SHOW MODELESS hForm1& , CALL Form1_DLGPROC
    END SUB
    ' ---------------------------------------------------------
    CALLBACK FUNCTION Form1_DLGPROC
        LOCAL Res AS LONG, Dist AS SINGLE
        LOCAL lpsz AS ASCIIZ * 255
        LOCAL Phi AS SINGLE, Sign AS SINGLE
        LOCAL XM AS LONG, YM AS LONG
        STATIC XMPrev AS LONG, YMPrev AS LONG
        STATIC RotFlag AS LONG
        STATIC MouseXY AS LONG, MouseStartFlag AS LONG
        SELECT CASE CBMSG
            CASE %WM_PAINT
                '
                ' Create memory based enhanced metafile
                hdcEMF = CreateEnhMetafile (BYVAL %NULL, BYVAL %NULL, BYVAL %NULL, BYVAL %NULL)
    
                ' For making of graph, use the graph label window dimensions in pixels.
                GetClientRect memdc,Rct
                '
                CALL Make3Dstructure
                '
                SetTextAlign hdcEMF,%TA_CENTER
                SelectObject hdcEMF, Font1
                lpsz="La Grande Arche, La Défence, Paris - By Johan Otto von Spreckelsen"
                TextOut hdcEMF, Rct.nRight/2,Rct.nBottom-17, lpsz, BYVAL LEN(lpsz)
                '
                SetTextAlign hdcEMF,%TA_LEFT
                SelectObject hdcEMF, Font2
                lpsz="Viewpoint:  X:"+FORMAT$(EX,"* ###.#")
                TextOut hdcEMF,80,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Y:"+FORMAT$(EY,"* ###.#")
                TextOut hdcEMF,210,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Z:"+FORMAT$(EZ,"* ###.#")
                TextOut hdcEMF,270,2, lpsz, BYVAL LEN(lpsz)
                lpsz="Projection Plane Distance:"+FORMAT$(PPD,"* ##.#")
                TextOut hdcEMF,330,2, lpsz, BYVAL LEN(lpsz)
                '
                ' Now all drawing instructions are in the enhanced metafile
                hemf = CloseEnhMetafile (BYVAL hdcEMF) ' Done: get handle to enhanced metafile
                '
                BeginPaint CBHNDL, Ps
                '
                GetClientRect memdc,Rct
                '
                ' Perform the graphics instructions in the virtual window in memory
                CALL PlayEnhMetafile (BYVAL memdc, BYVAL hemf, Rct)
                '
                ' Get device context for graphics window
                hDCg = GetDC(hGraph)
                '
                ' Copy graphics from virtual window onto graphics window on screen.
                BitBlt hDCg,0,0, Rct.nRight, Rct.nBottom, memdc,0,0,%SRCCOPY
                '
                EndPaint CBHNDL, Ps
                '
                ' *******************************************************
                ' ******* Not working at present. Can you figure out why?
                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
                ' ********************************************************
                '
                IF GrafCopyFlag=2 THEN ' save graphic enhanced metafile to disk
                    IF FilNameSaveEMF() THEN
                        Res = CopyEnhMetaFile(BYVAL hemf,PAFUemf) ' save to disk
                    END IF
                    GrafCopyFlag=0
                END IF
                '
                ReleaseDC hGraph, hDCg
                '
                ' Liberate enhanced metafile from memory. Very Important!!
                DeleteEnhMetafile hemf
                '
                IF RotFlag <>0 THEN
                    IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
                    Dist=SQR(EX*EX + EZ*EZ)
                    Phi = CalculatePhi(EX,EY) + 0.01 * RotFlag
                    EX = Dist * COS(Phi)
                    EZ = Dist * SIN(Phi)
                    Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                END IF
                '
                FUNCTION = 1
                '
            CASE %WM_LBUTTONDOWN
                RotFlag = 0
                MouseXY = 1
                FUNCTION = 1
    
            CASE %WM_LBUTTONUP
                MouseXY = 0
                MouseStartFlag = 0
                FUNCTION = 1
    
            CASE %WM_RBUTTONDOWN
                RotFlag = 0
                MouseXY = 2
                FUNCTION = 1
    
            CASE %WM_RBUTTONUP
                MouseXY = 0
                MouseStartFlag = 0
                FUNCTION = 1
    
            CASE %WM_MOUSEMOVE
                '
                IF MouseXY = 1 THEN ' Left mouse button pressed
                    XM = LOWRD(CBLPARAM)
                    YM = HIWRD(CBLPARAM)
                    IF MouseStartFlag = 0 THEN
                        XMPrev = XM
                        YMPrev = YM
                        MouseStartFlag = 1
                    END IF
                    IF XM <> XMPrev THEN ' Mouse moved horizontally. Rotate object.
                        Dist=SQR(EX*EX + EZ*EZ)
                        Phi = CalculatePhi(EX,EY) + (XM-XMPrev) * 0.015
                        EX = Dist * COS(Phi)
                        EZ = Dist * SIN(Phi)
                        XMPrev = XM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                    IF YM <> YMPrev THEN ' Mouse moved vertically. Move object up or down
                        EY = EY - (YM-YMPrev) * 0.3
                        YMPrev = YM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                END IF
                '
                IF MouseXY = 2 THEN ' Right mouse button pressed
                    XM = LOWRD(CBLPARAM)
                    YM = HIWRD(CBLPARAM)
                    IF MouseStartFlag = 0 THEN
                        XMPrev = XM
                        YMPrev = YM
                        MouseStartFlag = 1
                    END IF
                    '
                    IF XM <> XMPrev THEN ' Mouse moved horizontally. Change degree of perspective
                        IF (PPD > 4 AND XM > XMPrev) OR (PPD < 100 AND XM < XMPrev) THEN
                            PPD = PPD * (1 + (XMPrev-XM)*0.01)
                            EX=EX * (1 + (XMPrev-XM)*0.01)
                            EY=EY * (1 + (XMPrev-XM)*0.01)
                            EZ=EZ * (1 + (XMPrev-XM)*0.01)
                        END IF
                        XMPrev = XM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                    '
                    IF YM <> YMPrev THEN ' Mouse moved vertically. Change distance to object
                        Dist=SQR(EX*EX+EY*EY+EZ*EZ)
                        IF (Dist/PPD > 2.5 AND YM > YMPrev) OR (Dist/PPD < 100 AND YM < YMPrev) THEN
                            EX=EX * (1 + (YMPrev-YM)*0.01)
                            EY=EY * (1 + (YMPrev-YM)*0.01)
                            EZ=EZ * (1 + (YMPrev-YM)*0.01)
                        END IF
                        YMPrev = YM
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    END IF
                END IF
                FUNCTION = 1
            CASE %WM_COMMAND
                ' Process Messages to Controls that have no Callback Function
                ' and Process Messages to Menu Items
                SELECT CASE CBCTL
                    CASE  %Form1_SAVEAS
                        GrafCopyFlag=2   ' see CASE %WM_PAINT above
                        res&=InvalidateRect(hForm1&,BYVAL %NULL,%FALSE)
                    CASE  %Form1_EXIT
                        res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"End?")
                        IF res&=%IDYES THEN DIALOG END hForm1&
                    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,%FALSE)
                    CASE  %Form1_HELP1
                        Form1_HELP1_Select
                    CASE %Form1_ABOUT
                        Form1_ABOUT_Select
                    CASE %FORM1_BUTTON_LEFT
                        IF EX < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EX=EX+ABS(EX)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_RIGHT
                        IF EX > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EX=EX-ABS(EX)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_UP
                        IF EY < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EY=EY+ABS(EY)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_DOWN
                        IF EY > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EY=EY-ABS(EY)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_CLOSER
                        IF EZ > -1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EZ=EZ-ABS(EZ)*.1-1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_FARTHER
                        IF EZ < 1000 THEN
                            DO UNTIL SQR(EX*EX+EY*EY+EZ*EZ)/PPD > 2.5
                                EX=EX+EX*.002 :EY=EY+EY*.002:EZ=EZ+EZ*.002
                            LOOP
                            EZ=EZ+ABS(EZ)*.1+1
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_MORE_PERSPEC
                        IF PPD > 4 THEN
                            PPD = PPD*.9
                            EX=EX*.9 : EY=EY*.9 : EZ=EZ*.9
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_LESS_PERSPEC
                        IF PPD < 100 THEN
                            PPD = PPD/.9
                            EX=EX/.9 : EY=EY/.9 : EZ=EZ/.9
                            Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                        END IF
                        RotFlag = 0
                    CASE %FORM1_BUTTON_ROT_LEFT
                        RotFlag = -1
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE %FORM1_BUTTON_ROT_RIGHT
                        RotFlag = 1
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE %FORM1_BUTTON_ROT_STOP
                        RotFlag = 0
                        Res& = InvalidateRect(hForm1&,BYVAL %NULL,%TRUE)
                    CASE ELSE
                END SELECT
            CASE ELSE
        END SELECT
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION CalculatePhi(EX AS SINGLE, EY AS SINGLE) AS SINGLE
        LOCAL Ph AS SINGLE
        IF ABS(EX)<0.00001 THEN EX=EX+SGN(EX)*0.00001
        IF EZ/EX < 0 THEN
            IF EZ > 0 THEN
                Ph = ATN(EZ/EX)+3.141593  ' These corrections are needed
            ELSE                          ' to make angle make a full circle
                Ph = ATN(EZ/EX)+6.283186  ' i.e. 360 degrees.
            END IF                        '
        ELSE                              ' Without the corrections the angle
            IF EZ > 0 THEN                ' will only vary 180 degrees
                Ph = ATN(EZ/EX)           ' (-90 to 90) corresponding to
            ELSE                          ' the range for arcus tangens (ATN).
                Ph = ATN(EZ/EX)+3.141593  '
            END IF
        END IF
        FUNCTION = Ph
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION FilNameSaveEMF() AS LONG
       LOCAL Path   AS STRING
       LOCAL f      AS STRING
       LOCAL Style  AS DWORD
       LOCAL curPath   AS ASCIIZ * %MAX_PATH
       ' Get path to where this program is located (proposed by Borje Hagsten):
       GetModuleFileName GetModuleHandle(""), curPath, SIZEOF(curPath)
       '
       Path = FilePath(curPath)
       f=FileNam(PAFUemf)
       Style = %OFN_HIDEREADONLY OR %OFN_LONGNAMES
       IF SaveFileDialog(0, "Provide File Name For Saving Of Enhanced Metafile", f, Path, _
           "Enhanced Metafiles|*.emf|All Files|*.*", "emf", Style) THEN
           PAFUemf=f
           FUNCTION = 1
       END IF
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION FileNam(BYVAL Src AS STRING) AS STRING
      LOCAL x AS LONG
      FOR x = LEN(Src) TO 1 STEP -1
        IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
      NEXT x
      FUNCTION = MID$(Src, x + 1)
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION FilePath(BYVAL Src AS STRING) AS STRING
      LOCAL x AS LONG
      FOR x = LEN(Src) TO 1 STEP -1
        IF (ASC(Src, x) = 92) OR (ASC(Src, x) = 58) THEN EXIT FOR
      NEXT x
      FUNCTION = LEFT$(Src, x)
    END FUNCTION
    ' ------------------------------------------------
    SUB Form1_HELP1_Select()
        LOCAL St AS STRING
        St ="3D-Graphics Demonstration Program Using Enhanced Metafile."+$CRLF+$CRLF+ _
        "This program illustrates the drawing of three-dimensional objects on "+ _
        "the screen. It includes routines for not displaying surfaces and "+ _
        "edges which cannot be seen from the eye or viewpoint position. "+ _
        "A key point in the program is the concept of surface orientation. "+ _
        "The vertices (corners) of each surface unit (facet) must follow a "+ _
        "counter-clockwise sequence when seen from the outer side of the "+ _
        "surface. The object must be composed of convex facets. If you want "+ _
        "to show objects with concave facets such must first be broken down "+ _
        "to two or more convex facets. The coordinate system used is left- "+ _
        "hand orientated. For further background information you should "+ _
        "consult textbooks on computer graphics."+$CRLF+$CRLF+ _
        "The program allows you to change the eye (viewpoint) position "+ _
        "coordinates and the degree of perspective. You are always looking "+ _
        "toward the center (0,0,0) of the coordinate system. So it is best "+ _
        "if you place the object in such a way that its center is at 0,0,0. "+ _
        "PowerBasic's handy matrix functions are being used for "+ _
        "transformation of coordinates. You can make the object rotate "+ _
        "continuously left or right. The flicker has been reduced by making the "+ _
        "drawing in a virtual window. Repainting is done by copying the virtual "+ _
        "window to the screen window. This updating has been inspired by the "+ _
        "very fine contributions by the many experts in the Forum, whom I thank "+ _
        "very much. This late version allows you to move the object using the mouse "+ _
        "as long as the left or right mouse button is held down. Thanks to Brad Byrne for "+ _
        "suggesting this feature and to Todd Wasson for his code on 3-D vector "+ _
        "graphics which demonstrates how the viewpoint can be controlled by the "+ _
        "mouse. Also thanks to Karl Lessmann for his comments. Further suggestions "+ _
        "for improvement are still welcome."+$CRLF+$CRLF+ _
        "Best wishes"+$CRLF+$CRLF+ _
        "Erik Christensen ---- e.chr@email.dk"
        MSGBOX St,%MB_ICONINFORMATION,"Information"
    END SUB
    ' ------------------------------------------------
    SUB Form1_ABOUT_Select
        LOCAL St AS STRING
        St="Three-dimensional graphics demonstration program using enhanced metafiles (version 1.0, April 14, 2002)"+$CRLF+$CRLF+ _
        "By Erik Christensen, Copenhagen, Denmark       e.chr@email.dk"+$CRLF+$CRLF+ _
        "The use of this Public Domain program and its consequences are your own responsibility. However, any comment you may have is welcome."+$CRLF+$CRLF+ _
        "Good Luck!"
        MSGBOX St,%MB_ICONINFORMATION,"About this program"
    END SUB
    ' ------------------------------------------------
    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
    ' ------------------------------------------------
    FUNCTION gColor(BYVAL I AS LONG) AS LONG
      SELECT CASE I
        ' Common RGB Colors:
        CASE 0 : FUNCTION = %Black       ' = &H000000??? (same as RGB(0,0,0))
        CASE 1 : FUNCTION = %Blue        ' = &HFF0000???
        CASE 2 : FUNCTION = %Green       ' = &H00FF00???
        CASE 3 : FUNCTION = %Cyan        ' = &HFFFF00???
        CASE 4 : FUNCTION = %Red         ' = &H0000FF???
        CASE 5 : FUNCTION = %Magenta     ' = &HFF00FF???
        CASE 6 : FUNCTION = %Yellow      ' = &H00FFFF???
        CASE 7 : FUNCTION = %White       ' = &HFFFFFF??? (same as RGB(255,255,255))
        CASE 8 : FUNCTION = &H101010???  '   Gray - very very dark
        CASE 9 : FUNCTION = &H202020???  '   Gray - very dark
        CASE 10: FUNCTION = &H303030???  '   Gray - moderately to very dark
        CASE 11: FUNCTION = &H404040???  '   Gray - moderately dark
        CASE 12: FUNCTION = &H505050???  '   Gray - slightly to moderately dark
        CASE 13: FUNCTION = &H606060???  '   Gray - slightly dark
        CASE 14: FUNCTION = &H707070???  '   Gray - slightly dark to normal
        CASE 15: FUNCTION = %Gray        ' = &H808080???  (normal gray)
        CASE 16: FUNCTION = &H909090???  '   Gray - slightly light to normal
        CASE 17: FUNCTION = &HA0A0A0???  '   Gray - slightly light
        CASE 18: FUNCTION = &HB0B0B0???  '   Gray - slightly to moderately light
        CASE 19: FUNCTION = %LtGray      ' = &HC0C0C0??? (moderately light gray)
        CASE 20: FUNCTION = &HD0D0D0???  '   Gray - moderately to very light
        CASE 21: FUNCTION = &HE0E0E0???  '   Gray - very light
        CASE 22: FUNCTION = &HF0F0F0???  '   Gray - very very light
        CASE 23: FUNCTION = &HF8F8F8???  '   Gray - nearly white
        CASE 24: FUNCTION = &HFCFCFC???  '   Gray - practically white
    
        ' Additional colors can be added e.g. using the RGB function,
        ' e.g. CASE 15: FUNCTION = RGB(X,Y,Z)
        ' and so on.
        CASE ELSE : FUNCTION = %Black
      END SELECT
    END FUNCTION
    ' ------------------------------------------------
    FUNCTION PenStyle(BYVAL I AS LONG) AS LONG
      SELECT CASE I
        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
    ' -------------------------------------------------------------------------
    ' The following routines have been heavily inspired by this very fine book:
    ' Ian. O. Angell. Advanced Graphics with the IBM Personal Computer.
    ' -------------------------------------------------------------------------
    SUB Make3Dstructure
        DIM X(16) AS SINGLE, Y(16) AS SINGLE, Z(16) AS SINGLE
        DIM XD(16) AS SINGLE, YD(16) AS SINGLE
        DIM Facet(4, 16) AS LONG, FacetColour(16) AS LONG, FacetCorners(16) AS LONG
        DIM A(1:4,1:4) AS SINGLE, R(1:4,1:4) AS SINGLE, Q(1:4,1:4) AS SINGLE
        DIM B(1:4,1:4) AS SINGLE
        LOCAL M&,I&,NOF&,NOV&,res&
        LOCAL XX AS SINGLE, YY AS SINGLE, ZZ AS SINGLE
    
        ' Make virtual window white.
        hBrush = GetStockObject(%WHITE_BRUSH)
        SelectObject hdcEMF, hBrush
        res&=FillRect (hdcEMF, Rct, hBrush)
        PatBlt memdc, 0, 0, Rct.nRight, Rct.nBottom, %PATCOPY
    
        NOF& = 16  ' Number of facets
        NOV& = 16  ' Number of vertices ("corners")
    
          ' Read x,y,z coordinates of each vertex ("corner") in the structure
          DATA   -2.138,-2.218,-2.24,  2.138,-2.218,-2.24,  2.138,2.218,-2.24,  -2.138,2.218,-2.24
          DATA   -2.138,-2.218,2.24,   2.138,-2.218,2.24,   2.138,2.218,2.24,   -2.138,2.218,2.24
          DATA   -1.487,-1.766,-1.3,   1.487,-1.766,-1.3,   1.487,1.766,-1.3,   -1.487,1.766,-1.3
          DATA   -1.487,-1.766,1.3,    1.487,-1.766,1.3,    1.487,1.766,1.3,    -1.487,1.766,1.3
    
          FOR I& = 1 TO NOV&
              INCR M&: X(I&)=VAL(READ$(M&))
              INCR M&: Y(I&)=VAL(READ$(M&))
              INCR M&: Z(I&)=VAL(READ$(M&))
          NEXT I&
    
          ' Read sequence of vertices of each facet.
          ' This sequence should be counter-clockwise
          ' when seen from the outside of the structure.
    
          DATA  4, 3, 7, 8,   1, 5, 6, 2,   2, 6, 7, 3,   5, 1, 4, 8
          DATA 11,12,16,15,   9,10,14,13,  10,11,15,14,  13,16,12, 9
          DATA  4,12,11, 3,   9, 1, 2,10,   2, 3,11,10,   1, 9,12, 4
          DATA 16, 8, 7,15,   5,13,14, 6,  15, 7, 6,14,   8,16,13, 5
    
          FOR I& = 1 TO NOF&
              INCR M&: Facet(1,I&)=VAL(READ$(M&))
              INCR M&: Facet(2,I&)=VAL(READ$(M&))
              INCR M&: Facet(3,I&)=VAL(READ$(M&))
              INCR M&: Facet(4,I&)=VAL(READ$(M&))
              FacetCorners(I&) = 4 ' Number of corners in facet
          NEXT I&
    
          ' Read color codes for facets
          DATA 24,16,23,23,18,22,20,20,21,23,22,22,21,23,22,22
    
          FOR I& = 1 TO NOF&
              INCR M&: FacetColour(I&)=VAL(READ$(M&))
          NEXT I&
    
         'move complete object into OBSERVED position.
         MAT R() = IDN
         CALL LookAtStructureFromViewpoint(A(),R(),B())
         'get screen coordinates.
         FOR M& = 1 TO NOV&
             XX = X(M&): YY = Y(M&): ZZ = Z(M&)
             X(M&) = R(1, 1) * XX + R(1, 2) * YY + R(1, 3) * ZZ + R(1, 4)
             Y(M&) = R(2, 1) * XX + R(2, 2) * YY + R(2, 3) * ZZ + R(2, 4)
             Z(M&) = R(3, 1) * XX + R(3, 2) * YY + R(3, 3) * ZZ + R(3, 4)
             XD(M&) = X(M&) * PPD / Z(M&)
             YD(M&) = Y(M&) * PPD / Z(M&)
         NEXT M&
    
         CALL DrawScreenPicture(NOF&,Facet(),XD(),YD(), _
                FacetCorners(),FacetColour(), _
                X(), Y(), Z(),PPD)
    END SUB
    ' ------------------------------------------------
    SUB LookAtStructureFromViewpoint(A() AS SINGLE,R() AS SINGLE,B() AS SINGLE)
         LOCAL DX AS SINGLE,DY AS SINGLE,DZ AS SINGLE
         LOCAL TX AS SINGLE,TY AS SINGLE,TZ AS SINGLE
         LOCAL FX AS SINGLE,FY AS SINGLE,FZ AS SINGLE
         LOCAL THETA AS SINGLE, AX AS SINGLE, AY AS SINGLE
         LOCAL AXIS&, DIST AS SINGLE
         LOCAL I&,J&,K&
         LOCAL t AS STRING,t2 AS STRING
         ' Eye position EX, EY, EZ - Global variables
         DX = 0: DY = 0: DZ = 0
         ' Move origin to (DX,DY,DZ).
         LET TX = -DX: LET TY = -DY: TZ = -DZ
         MAT A() = IDN : A(1, 4) = TX: A(2, 4) = TY: A(3, 4) = TZ
         MAT B() = A() * R() : MAT R() = B()
         ' Move eye onto negative z-axis, looking at origin.
         FX = EX - DX: FY = EY - DY: FZ = EZ - DZ
         AX = FX: AY = FY
         CALL ViewingAngle(AX, AY, THETA)
         THETA = -THETA:  AXIS& = 3
         CALL RotateSystem(THETA, AXIS,A())
         MAT B() = A() * R() : MAT R() = B()
         DIST = SQR(FX * FX + FY * FY)
         AX = FZ: AY = DIST
         CALL ViewingAngle(AX, AY, THETA)
         THETA = 3.141593 - THETA: AXIS& = 2
         CALL RotateSystem(THETA, AXIS,A())
         MAT B() = A() * R() : MAT R() = B()
         ' Maintain the vertical.
         TZ = SQR(DIST * DIST + FZ * FZ)
         AX = TZ * FX: AY = -FY * FZ
         CALL ViewingAngle(AX, AY, THETA)
         AXIS& = 3
         CALL RotateSystem(THETA, AXIS, A())
         MAT B() = A() * R() : MAT R() = B()
         ' Move the eye to the origin : space is now in OBSERVED position.
         R(3,4)=TZ
    END SUB
    ' ------------------------------------------------
    SUB RotateSystem(THETA AS SINGLE, AXIS AS LONG,A() AS SINGLE)
          LOCAL AX1&,AX2&,CT AS SINGLE, ST AS SINGLE
          MAT A() = ZER
          AX1& = (AXIS& MOD 3) + 1: AX2& = (AX1& MOD 3) + 1
          CT = COS(THETA): ST = SIN(THETA)
          A(AXIS&, AXIS&) = 1
          A(AX1&, AX1&) = CT: A(AX1&, AX2&) = -ST
          A(AX2&, AX1&) = ST: A(AX2&, AX2&) = CT
    END SUB
    ' ------------------------------------------------
    SUB ViewingAngle(AX AS SINGLE, AY AS SINGLE, THETA AS SINGLE)
           ' THETA is the angle that the line from origin to (AX,AY)
           ' makes with the positive x-axis.
           IF ABS(AX) > .000001 THEN ' Line is not vertical, so it has a finite tangent.
               THETA = ATN(AY / AX)
               IF AX < 0 THEN THETA = THETA + 3.141593
           ELSE ' Line is vertical.
               THETA = 3.141593 / 2
               IF AY < 0 THEN THETA = THETA + 3.141593
               IF ABS(AY) < .000001 THEN THETA = 0
           END IF
    END SUB
    ' ------------------------------------------------
    SUB DrawScreenPicture(NOF AS LONG,Facet() AS LONG,XD() AS SINGLE,YD() AS SINGLE, _
                FacetCorners() AS LONG,FacetColour() AS LONG, _
                X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
          LOCAL HSIZ&,FREE&,NFREE&,NVIS&,I&,I1&,I2&,I3&,FA&,FB&
          LOCAL OVER&,FRONT&,BACK&
          LOCAL X1 AS SINGLE,X2 AS SINGLE,X3 AS SINGLE
          LOCAL Y1 AS SINGLE,Y2 AS SINGLE,Y3 AS SINGLE
          LOCAL DX1 AS SINGLE,DX2 AS SINGLE
          LOCAL DY1 AS SINGLE,DY2 AS SINGLE
          HSIZ& = NOF& * 3  ' Defines size of stack. Must not be too small.
          ' StackArray&(I&) and PointerArray&(I&) are the storage and pointer
          ' locations available for the construction of linked lists.
          ' LIS&(I&) points to a list af indices of facets that lie
          ' in front af facet I&.
          DIM G(NOF&) AS LONG, LIS(NOF&) AS LONG, StackArray(HSIZ&) AS LONG, PointerArray(HSIZ&) AS LONG
          ' FREE& points to a list of free storage locations available
          ' in the StackArray& (and PointerArray&) arrays.
          ' NVIS& is the number of anticlockwise and potentially visible facets.
          FREE& = 1: NVIS& = 0
          ' Initialise the PointerArray& pointers for the linked lists. Initially all the storage in StackArray& is FREE&.
          FOR I& = 1 TO HSIZ&
              PointerArray&(I&) = I& + 1
          NEXT I&
          ' Orientate the projected facets:
          ' G&(I&)=-1 means projected facet I& is clockwise
          ' G&(I&)=0 means it is anticlockwise and potentially visible.
          FOR I& = 1 TO NOF&
              I1& = Facet(1, I&): X1 = XD(I1&): Y1 = YD(I1&)
              I2& = Facet(2, I&): X2 = XD(I2&): Y2 = YD(I2&)
              I3& = Facet(3, I&): X3 = XD(I3&): Y3 = YD(I3&)
              DX1 = X2 - X1: DY1 = Y2 - Y1
              DX2 = X3 - X2: DY2 = Y3 - Y2
              IF DX1 * DY2 - DX2 * DY1 > 0 THEN G&(I&) = 0: NVIS& = NVIS& + 1: LIS&(I&) = 0 ELSE G&(I&) = -1
          NEXT I&
          ' Compare visible facets : FA& with FB&.
          ' G&(FA&) will now hold the number of facets not already
          ' drawn that will lie behind facet FA&.
          FOR FA& = 1 TO NOF& - 1
              IF G&(FA&) <> -1 THEN
                  FOR FB& = FA& + 1 TO NOF&
                      IF G&(FB&) <> -1 THEN
                          CALL CheckOverlapOfFacets(XD(),YD(),FacetCorners(), _
                               Facet(),FA&,FB&,OVER&,FRONT&,BACK&, _
                               X(),Y(),Z(),PPD)
                             ' If facets overlap i.e. facet FRONT& in front of facet
                             ' BACK& then increment G&(FRONT&), and add FRONT& to the list
                             ' of facets in front of facet BACK&. Adjust the StackArray&.
                          IF OVER& <> 0 THEN
                              G&(FRONT&) = G&(FRONT&) + 1: NFREE& = PointerArray&(FREE&)
                              StackArray&(FREE&) = FRONT&: PointerArray&(FREE&) = LIS&(BACK&)
                              LIS&(BACK&) = FREE&: FREE& = NFREE&
                          END IF
                      END IF
                  NEXT FB&
              END IF
          NEXT FA&
          ' Sort the network of linked lists of facets to be displayed.
          CALL SortFacetsAccordingToDistance(NOF&,Facet(),FacetCorners(), _
               FacetColour(),G(),NVIS&, XD(), _
               YD(),LIS(),StackArray(),PointerArray(),FREE&)
    END SUB
    ' ------------------------------------------------
    SUB CheckOverlapOfFacets(XD() AS SINGLE,YD() AS SINGLE,FacetCorners() AS LONG, _
                Facet() AS LONG,FA AS LONG,FB AS LONG, _
                OVER AS LONG, FRONT AS LONG,BACK AS LONG, _
                X() AS SINGLE, Y() AS SINGLE, Z() AS SINGLE,PPD AS SINGLE)
         LOCAL P1&,P2&,NA&,NB&,NF&,K&,M&,V&,V1&,V2&,V3&,NC&,S1&,S2&
         LOCAL X1 AS SINGLE,X2 AS SINGLE,Y1 AS SINGLE, Y2 AS SINGLE
         LOCAL CC AS SINGLE, CA AS SINGLE,CB AS SINGLE
         LOCAL XI1 AS SINGLE, YI1 AS SINGLE,XI2 AS SINGLE, YI2 AS SINGLE
         LOCAL VAL1 AS SINGLE, VAL2 AS SINGLE, A1 AS SINGLE,A2 AS SINGLE
         LOCAL MU AS SINGLE, UM AS SINGLE, DENOM AS SINGLE
         LOCAL MU1 AS SINGLE, MU2 AS SINGLE
         LOCAL XMID AS SINGLE, YMID AS SINGLE
         LOCAL DX1 AS SINGLE, DX3 AS SINGLE
         LOCAL DY1 AS SINGLE, DY3 AS SINGLE
         LOCAL DZ1 AS SINGLE, DZ3 AS SINGLE
         LOCAL A AS SINGLE, B AS SINGLE,C AS SINGLE,D AS SINGLE
         '
         ' the NA& vertices af facet FA& and the NB& vertices of facet FB&
         ' are obtained from array Facet().
         ' Polygons are stored in anticlockwise orientation.
         ' Check if the view of facets FA& and FB& overlap.
         ' OVER& is set to 1 if they do, and to 0 if they do not.
         P1& = 1: NA& = FacetCorners(FA&): NB& = FacetCorners(FB&): NF& = NA&
         DIM XF(2, NA& + NB&) AS SINGLE, YF(2, NA& + NB&) AS SINGLE
         ' Place projected view of facet FA& in the arrays
         ' XF(1,...) and YF(1,...).
         FOR K& = 1 TO NA&
             V& = Facet(K&, FA&): XF(1, K&) = XD(V&): YF(1, K&) = YD(V&)
         NEXT K&
         ' Use each edge line of facet FB& to slice off part of
         ' the polygon stored in XF,YF.
         ' Line joins point (X1,Y1) to (X2,Y2).
         V1& = Facet(NB&, FB&): X1 = XD(V1&):  Y1 = YD(V1&)
         FOR K& = 1 TO NB&
             V2& = Facet(K&, FB&): X2 = XD(V2&):  Y2 = YD(V2&)
             ' The line is CA.Y+CB.X+CC=0.
             CA = X2 - X1: CB = Y1 - Y2: CC = -X1 * CB - Y1 * CA
             ' Go round the NF& vertices in XF,YF. If positive relative to
             ' the line, then add point to new XF,YF set. If negative
             ' then ignore.
             P2& = 3 - P1&: XI1 = XF(P1&, NF&): YI1 = YF(P1&, NF&)
             VAL1 = CA * YI1 + CB * XI1 + CC: A1 = ABS(VAL1): NC& = 0
             IF A1 < .000001 THEN S1& = 0 ELSE S1& = SGN(VAL1)
             FOR M& = 1 TO NF&
                 XI2 = XF(P1&, M&): YI2 = YF(P1&, M&)
                 VAL2 = CA * YI2 + CB * XI2 + CC: A2 = ABS(VAL2)
                 IF A2 < .000001 THEN S2& = 0 ELSE S2& = SGN(VAL2)
                 IF S1& >= 0 THEN NC& = NC& + 1: XF(P2&, NC&) = XI1: YF(P2&, NC&) = YI1
                 IF S1& <> S2& AND S1& <> 0 AND S2& <> 0 THEN
                     ' If there is an intersection then also add to new XF,YF arrays.
                     MU = A1: UM = A2: DENOM = A1 + A2: NC& = NC& + 1
                     XF(P2&, NC&) = (UM * XI1 + MU * XI2) / DENOM: YF(P2&, NC&) = (UM * YI1 + MU * YI2) / DENOM
                 END IF
                 VAL1 = VAL2: S1& = S2&: A1 = A2: XI1 = XI2: YI1 = YI2
             NEXT M&
             ' If facets do not overlap then OVER&=0.
             IF NC& < 3 THEN OVER& = 0: EXIT SUB
             NF& = NC&: P1& = P2&: X1 = X2: Y1 = Y2
         NEXT K&
         ' Find (XMID,YMID) common to both projected facets.
         XMID = (XF(P1&, 1) + XF(P1&, 2) + XF(P1&, 3)) / 3
         YMID = (YF(P1&, 1) + YF(P1&, 2) + YF(P1&, 3)) / 3
         V1& = Facet(1, FA&): V2& = Facet(2, FA&):  V3& = Facet(3, FA&)
         GOSUB Distance : MU1 = MU2 ' Get distance MU1
         ' MU1 is the distance of the eye from that point
         ' on facet FA& which is projected into (XMID,YMID).
         V1& = Facet(1, FB&): V2& = Facet(2, FB&): V3& = Facet(3, FB&)
         GOSUB Distance             ' Get distance MU2
         ' MU2 is the distance of the eye from that point
         ' on facet FB which is projected into (XMID,YMID).
         '
         ' Ff MU1>MU2 then facet FB& is closer to the eye, that is
         ' facet FB& is in front af facet FA&. Similarly if MU1<MU2.
         OVER& = 1
         IF MU1 > MU2 THEN FRONT& = FB&: BACK& = FA& ELSE FRONT& = FA&: BACK& = FB&
         EXIT SUB
         '
         Distance:
             DX1 = X(V1&) - X(V2&): DX3 = X(V3&) - X(V2&)
             DY1 = Y(V1&) - Y(V2&): DY3 = Y(V3&) - Y(V2&)
             DZ1 = Z(V1&) - Z(V2&): DZ3 = Z(V3&) - Z(V2&)
             A = DY1 * DZ3 - DY3 * DZ1: B = DZ1 * DX3 - DZ3 * DX1: C = DX1 * DY3 - DX3 * DY1
             D = A * X(V1&) + B * Y(V1&) + C * Z(V1&)
             MU2 = D / (A * XMID + B * YMID + C * PPD)
         RETURN
    END SUB
    ' ------------------------------------------------
    SUB SortFacetsAccordingToDistance(NOF AS LONG,Facet() AS LONG,FacetCorners() AS LONG, _
                FacetColour() AS LONG,G() AS LONG,NVIS AS LONG, XD() AS SINGLE, _
                YD() AS SINGLE,LIS() AS LONG,StackArray() AS LONG,PointerArray() AS LONG,FREE AS LONG)
           LOCAL StackPosition&,F&,ValueIn&,ValueOut&,NC&,COLFAC&,I&,V&,PT&,F2&
           StackPosition& = 0
           DIM XC(10) AS SINGLE, YC(10) AS SINGLE
           ' Create a stack. Push on it all facets F& that have
           ' no facets behind them i.e. G&(F&)=0
           FOR F& = 1 TO NOF&
               IF G&(F&) = 0 THEN ValueIn& = F&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
           NEXT F&
           ' Find an order for drawing all the visible facets
           ' so that hidden sections are obliterated. Draw
           ' facets that have no undrawn facets behind them.
           FOR F& = 1 TO NVIS&
               ' Pop a facet which has no undrawn facet behind it.
               CALL PopValueFromTopOfStack(ValueOut,FREE,StackPosition,PointerArray(),StackArray())
               ' If no facet is available, there is an error in the data.
               IF ValueOut& = 0 THEN MSGBOX "Error in the data - network has a cycle"': STOP
               ' Draw the facet.
               NC& = FacetCorners(ValueOut&): COLFAC& = FacetColour(ValueOut&)
               FOR I& = 1 TO NC&
                   V& = Facet(I&, ValueOut&): XC(I&) = XD(V&): YC(I&) = YD(V&)
               NEXT I&
               CALL DrawThisFacet(NC&,XC(),YC(),COLFAC&)
               ' After the facet is drawn, adjust the values of array G&.
               ' Use the list LIS& to find facets in front of last facet drawn.
               ' Now G&(F&) holds the number of undrawn facets behind facet F&
               PT& = LIS&(ValueOut&)
               DO UNTIL PT& = 0
                   F2& = StackArray&(PT&)
                   G&(F2&) = G&(F2&) - 1
                   ' If facet F2& has no undrawn facet behind it, push it on stack
                   IF G&(F2&) = 0 THEN ValueIn& = F2&: CALL PushValueOntoStack(ValueIn,FREE,StackPosition,PointerArray(),StackArray())
                   PT& = PointerArray&(PT&)
               LOOP
           NEXT F&
    END SUB
    ' ------------------------------------------------
    SUB DrawThisFacet(NC AS LONG,XC() AS SINGLE,YC() AS SINGLE,COLFAC AS LONG)
        DIM pxy(0:10) AS POINTAPI
        LOCAL Res&
        LOCAL V&
        ' Fill points array with data adapted for graphics window dimensions
        FOR V& = 1 TO NC&
            pxy(V&-1).x=XC(V&)*Rct.nRight*0.25 + Rct.nRight * 0.5
            pxy(V&-1).y=Rct.nBottom-(YC(V&)*Rct.nBottom*0.3+Rct.nBottom*0.5)
        NEXT V&
        pxy(NC&).x=XC(1)*Rct.nRight*0.25 + Rct.nRight * 0.5
        pxy(NC&).y=Rct.nBottom-(YC(1)*Rct.nBottom*0.3+Rct.nBottom * 0.5)
        '
        hBrush = SelectObject(hdcEMF,BrushArray(COLFAC&))
        ' Draw polygon in selected color
        Res&=Polygon(BYVAL hdcEMF,pxy(0),BYVAL NC&)
        ' hPen = SelectObject(hdcEMF, CreatePen(PenStyle(0), 0, gColor(0)))
        ' Draw outline of polygon in black. Uses default pen color and style: black and solid
        Res&=Polyline(BYVAL hdcEMF,pxy(0), BYVAL (NC&+1))
    END SUB
    ' ------------------------------------------------
    SUB PushValueOntoStack(ValueIn AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '&'8000  'push ' s 226
        LOCAL NF&
        NF& = FREE&                         ' Free position in stack.
        StackArray&(NF&) = ValueIn&         ' Put value onto stack in free position.
        FREE& = PointerArray&(FREE&)        ' New free position in stack.
        PointerArray&(NF&) = StackPosition& ' Update pointer array
        StackPosition& = NF&                ' New top position in stack
    END SUB
    ' ------------------------------------------------
    SUB PopValueFromTopOfStack(ValueOut AS LONG,FREE AS LONG,StackPosition AS LONG,PointerArray() AS LONG,StackArray() AS LONG) '8100  'pop ' s 226
        LOCAL NF&
        NF& = StackPosition&                ' Position of top item in stack.
        ValueOut& = StackArray&(NF&)        ' Get value out from this position.
        StackPosition& = PointerArray&(NF&) ' New top position in stack.
        PointerArray&(NF&) = FREE&          ' Update pointer array.
        FREE& = NF&                         ' New free position in stack.
    END SUB
    ' ------------------------------------------------


    [This message has been edited by Erik Christensen (edited April 15, 2002).]
Working...
X