BUG 11/BUGCD1998_02.ISO/aplic/turbocad/tcw.z/virtpnt.bas

BASIC Source File | 1997-05-05 | 22KB | 979 lines

'******************************************************************
'*                                                                *
'*                      TurboCAD for Windows                      *
'*                   Copyright (c) 1993 - 1996                    *
'*             International Microcomputer Software, Inc.         *
'*                            (IMSI)                              *
'*                      All rights reserved.                      *
'*                                                                *
'******************************************************************
'
' Filename: FNDINTRS.BAS
'
' Author:    Pat Garner
'
' Date:        1/14/97
'
'
' Scriptname:    Find Intersection
'
' Version:        1.0
'
' Description:    Script inserts a point graphic
'                at the point where two non
'                intersecting lines meet.
'
'
'
' Revision History:
'
'              - 1.0    User must select two line graphics and then run script.
'            Script will check that there are only two single lines
'            currently part of the selection.
'            Script then:
'                        1) gets handle of selected lines
'                        2) gets handle of both vertices
'                        3) gets all vertices coordinates
'                        4) determine which end of lines is closer
'                        5) calculate angle of lines
'                        6) calcutate coordinates of intersect
'                        7) insert point object at coordinates
'
'
' Tcadapi Functions used:
'                            -
'
'
' TODO:
'        - Put App in select dragger mode.
'        - Prompt user for selection, first graphic
'            - Msgbox
'            - Status Bar Prompt
'        - Wait until the user clicks
'        - Check selected graphic to be sure it's a single line.(function?)
'            - Get graphics handle
'            - TCWVertexCount: more than two?
'                - Yes    - Inform user that graphic is incorrect
'                            - Ding, MsgBox "Please ...
'                            - Ding, Status Bar Prompt "Wrong Graphic Type...
'                        - Deselect graphic
'                        - Return Null (zero)
'                - No    - Return handle of graphic
'        - Prompt user for selection, seccond graphic
'            - Msgbox
'            - Status Bar Prompt
'        - Wait until the user clicks
'        - Check selected graphic to be sure it's a single line.(function?)
'            - Get graphics handle
'            - TCWVertexCount: more than two?
'                - Yes    - Inform user that graphic is incorrect
'                            - Ding, MsgBox "Please ...
'                            - Ding, Status Bar Prompt "Wrong Graphic Type...
'                        - Deselect graphic
'                        - Return Null (zero)
'                - No    - Return handle of graphic
'        - Query for vertex handles
'        - Query for vertex coordinates
'        - Determine closer end of lines
'        - Calculate angle relative to that end
'        - Calculate intersection of lines
'        - Insert point object at intersection
'        - Deselect two line graphics
'        - TCWViewportRedraw
'        - TCWViewportExtents
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' * General Script Constants
Global Const MAX_LINES = 2                    ' * Maximum number of line graphics
'
Global Const MAX_VERTICES = 2                ' * Maximum number of vertices that a
'                                            ' * line graphic may contain.
'
Global Const MAX_COORDS = 2                    ' * Maximum number of coordinate values
'
'
' * Error Reporting Constants
'
Global Const SILENT        = 1                    ' * Write err message info to error file
Global Const MSG_BOX    = 2                    ' * Diplay err message info in a message box
Global Const ALL        = 3                    ' * Use error both methods
Global Const NONE        = 0                    ' * Don't do any error reporting
Global Const ERR_FILE    = "C:\VIRPNT.ERR"    ' * Error file name
Global Const SCRIPT_FILE = "VIRTPNT.BAS"    ' * Script file name
Global Const ERR_SET    = 0                    ' * Error file does not exit if 0
Global Const ERR_METHOD = MSG_BOX            ' * Set ERR_METHOD behavior
Global Const ERR_TRUE    = 1                    ' * For ERR_STOP ending script execution
Global Const ERR_FALSE    = 0                    ' * For ERR_STOP not ending script exection
Global Const ERR_STOP    = ERR_TRUE            ' * Set ERR_STOP behavior
'
Global Const NULL        = 0
Global Const MY_TRUE    = 1                    ' * For use with TCWPenDown
Global Const MY_FALSE    = 0                    ' * For use with TCWPenDown
Global Const GK_GRAPHIC    = &H0B                ' * TurboCAD graphic kind - generic graphic
Global Const GK_ARC        = &H02                ' * TurboCAD graphic kind - arc graphic
'
'
' * This constant should be
' *  set to 1 to display the
' *  splash dialog or 0 to
' *  not display it.
'
Global Const DISPLAY_SPLASH = 1
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: MAIN'''''''''''''''''''''''''''''''''''''''''''''
'
' * Parameters: None
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        Main is the conductor of the program
' *         and like a music conductor, tells
' *         the other parts of the program when
' *         it's time to do their thing.
' *
' *
Sub main ()

    Dim hDrawing        As Long        ' * Handle to active drawing
    Dim hG                As Long        ' * Handle to graphic
    Dim counter            As Long        ' * Generic loop counter
    Dim gNum            As Integer    ' * Number of graphics in the current drawing
    Dim lNum            As Integer    ' * Number of line graphics in current drawing
    Dim vNum            As Integer    ' * Number vertices to a graphic
    Dim hGraphic(2)        As Long        ' * Array for line graphic's handles
    Dim hVertex(2,2)    As Long        ' * Array for line graphic's vertices' handles
    Dim vCoor(2,2,2)    As Double    ' * Array for vertices' coordinates
    Dim vCoorPoint(2)    As Double    ' * Array for point object's coordinates


    InitializeScript

    if DISPLAY_SPLASH = 1 then

        DoUI

    end if


    hDrawing = TCWDrawingActive
    gNum = TCWGraphicCount ( hDrawing )


    if gNum < 2 then

        MsgBox "Must have at least two line graphics in current drawing!"
        END

    end if


    for counter = 0 to gNum-1

        hG = TCWGraphicAt ( hDrawing, ( counter ) )
        vNum = TCWVertexCount ( hG )
        if vNum = 2 then lNum = lNum + 1

    next



    if lNum < 2 then

        MsgBox "Must have at least two line graphics in current drawing!"
        END

    end if


    GetGraphicsHandles hGraphic
    GetVertexHandles hGraphic, hVertex


    GetVertexCoordinates hVertex, vCoor
    CalculateIntersectCoordinates vCoor, vCoorPoint


    InsertPointObject vCoorPoint, hDrawing

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: InitializeScript'''''''''''''''''''''''''''''''''
'
' * Parameters: None
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        Script Setup Stuff
' *
' *
Sub InitializeScript ()

    TCWClearError    ' * Clear any error out of the error buffer.


    if ERR_SET = 1 then DoErrSetValue


    ' * ADD YOUR CODE HERE *

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''FUNCTION: GetLineHandle''''''''''''''''''''''''''''''''''''''
'
' * Parameters: ByVal strPrompt As String    -    String containing the
' *                                                 status bar message.
' *
' *
' * Return Value:    Long
' *
' *
' * Description:
' *
' *        This subroutine uses TCWGetPoint to
' *         get the user to select a point on
' *         the current drawing.  The function
' *         then checks to see if there is a
' *         line graphic at that point.  If so,
' *         function returns lines graphic's
' *         handle.  If there is not a line
' *         graphic present at the user's
' *         selected point, the function
' *         displays a message box alerting
' *         the user of this and then asks
' *         the user to select another point.
' *
' *
Function GetLineHandle ( ByVal strPrompt As String ) As Long

    Dim hVertex        As Long
    Dim hGraphic    As Long
    Dim rVal        As Long


    hVertex = TCWVertexCreate(0,0,0)


    while rVal = 0

        tcwgetpoint hVertex, strPrompt, NULL, NULL, &H0040, 1
        hGraphic = TCWVertexFindGraphic (hVertex)

        vNum = TCWVertexCount (hGraphic)
        if vNum = 2 then rVal = hGraphic

    wend

    GetLineHandle = rVal

End Function
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



''SUBROUTINE: GetGraphicsHandles'''''''''''''''''''''''''''''''
'
' * Parameters: ByRef GraphicHandleArray() As Long
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine cycles through the selected
' *         graphics and loads each grahic's handle
' *         into an array which will be used later to
' *         retrieve other values for the script.
' *
' *
Sub GetGraphicsHandles ( ByRef GraphicHandleArray() As Long )

    Dim counter            As Long
    Dim strPrompt(2)    As String

    strPrompt(1) = "Please select first line"
    strPrompt(2) = "Please select second line"


    for counter = 1 to MAX_LINES

        GraphicHandleArray( counter - 1 ) = GetLineHandle ( strPrompt( counter ) )

    next

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: GetVertexHandles'''''''''''''''''''''''''''''''''
'
' * Parameters:    ByRef GraphicHandleArray() As Long
' *                ByRef VertexHandleArray() As Long
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine uses the graphics handles
' *         stored in GraphicHandleArray() to
' *         the handles for each graphic's vertices
' *         then store them in VertexHandleArray().
' *
' *
Sub GetVertexHandles (    ByRef GraphicHandleArray() As Long, _
                        ByRef VertexHandleArray() As Long )

    dim gCounter as long
    dim vCounter as long


    for gCounter = 0 to (MAX_LINES - 1)


        for vCounter = 0 to MAX_VERTICES-1


            VertexHandleArray( gCounter, ( vCounter ) ) = _
             TCWVertexAt ( GraphicHandleArray( gCounter ), vCounter )

            CheckReturnValue "GetVertexHandles: TCWVertexAt", _
             VertexHandleArray( gCounter, ( vCounter ) )


        next


    next

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: GetVertexCoordinates'''''''''''''''''''''''''''''
'
' * Parameters: ByRef VertexHandleArray() As Long
' *                ByRef VertexCoordArray() As Double
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine takes the vertex handles
' *         stored in the VertexHandleArray to
' *         retrieve the vertex coordinates for the
' *         two selected line graphics and store
' *         then in VertexCoordArray().
' *
' *
Sub GetVertexCoordinates (    ByRef VertexHandleArray() As Long, _
                            ByRef VertexCoordArray() As Double )

    dim gCounter as long
    dim vCounter as long
    dim cCounter as long

    for gCounter = 0 to MAX_LINES

        for vCounter = 0 to MAX_VERTICES

            for cCounter = 0 to MAX_COORDS

                if cCounter = 0 then

                    VertexCoordArray(gCounter, vCounter, cCounter) _
                                    = TCWGetX(VertexHandleArray(gCounter, vCounter))

                    CheckReturnValue "GetVertexCoordinates: TCWGetX ", _
                                    VertexCoordArray(gCounter, vCounter, cCounter)
                end if


                if cCounter = 1 then


                    VertexCoordArray(gCounter, vCounter, cCounter) _
                                    = TCWGetY(VertexHandleArray(gCounter, vCounter))

                    CheckReturnValue "GetVertexCoordinates: TCWGetX ", _
                                    VertexCoordArray(gCounter, vCounter, cCounter)


                end if


            next


        next


    next

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: CalculateIntersectCoordinates''''''''''''''''''''
'
' * Parameters: ByRef VCA() As Double - Vertex Coordinate Array
' *                ByRef PCA() As Double - Point Coordinate Array
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine takes the vertex coordinates
' *         that's been gathered from the selected line
' *         graphics and calculates the x and y values
' *         for the 'virtual' intersection of the two
' *         lines.  The resulting x and y values are
' *         then stored in PCA() (point coordinate array)
' *         for use in the point insertion subroutine.
' *
' *
' * Note:
' *
' *        When using the vertex coordinate array VCA()
' *         each value is indexed with a base of 0.  The
' *         first line graphic is 0, the second 1.  The
' *         first vertex is 0,0 and the second is 0,1.
' *         The vertex x/y gets a little more confusing:
' *         x of the first vertex of the first line would
' *         be 0,0,0 and y, 0,0,1.
' *
' *
Sub CalculateIntersectCoordinates ( ByRef VCA() As Double, _
                                    ByRef PCA() As Double )

    Dim a11 As Double
    Dim a12 As Double

    Dim b1     As Double
    Dim b2    As Double

    Dim a21 As Double
    Dim a22 As Double

    Dim x11 As Double
    Dim x12 As Double

    Dim x21 As Double
    Dim x22 As Double

    Dim y11    As Double
    Dim y12 As Double

    Dim y21 As Double
    Dim y22 As Double

    Dim x    As Double
    Dim y    As Double
    Dim d    As Double

            '''''''''''
            '  L  V  C
            '  i  e  o
            '  n  r  o
            '  e  t  r
            '     e  d
            '     x  s
            '
            ' -1 -1 -1
            '
    x11 = VCA( 0, 0, 0 )
    x12 = VCA( 0, 1, 0 )

    x21 = VCA( 1, 0, 0 )
    x22 = VCA( 1, 1, 0 )

    y11 = VCA( 0, 0, 1 )
    y12 = VCA( 0, 1, 1 )

    y21 = VCA( 1, 0, 1 )
    y22 = VCA( 1, 1, 1 )


    a11    = ( y12 - y11 )
    a12    = - ( x12 - x11 )

    a21    = ( y22 - y21 )
    a22    = - ( x22 - x21 )

    b1    = ( ( y12 - y11 ) * x11 ) - ( ( x12 - x11 ) * y11 )
    b2    = ( ( y22 - y21 ) * x21 ) - ( ( x22 - x21 ) * y21 )

    d    = ( ( a11 * a22 ) - ( a21 * a12 ) )


    if d = 0 then

        MsgBox "No virtual intersection possible!"
        END

    end if


    x = ( ( a22 * b1 ) - ( a12 * b2 ) ) / d
    y = ( ( a11 * b2 ) - ( a21 * b1 ) ) / d

    PCA( 0 ) = x
    PCA( 1 ) = y

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: InsertPointObject''''''''''''''''''''''''''''''''
'
' * Parameters:    ByRef PCA() As Double
' *                ByVal hDrawing As Long
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine uses the x and  y
' *         values stored in PCA() to insert
' *         a new point graphic at the 'virtual'
' *         intersection of the two selected
' *         line graphics.
' *
' *
Sub InsertPointObject ( ByRef PCA() As Double, ByVal hDrawing As Long )

    Dim hParentGraphic    As Long
    Dim hCircleGraphic    As Long
    Dim hCrossGraphic    As Long
    Dim hVertex1        As Long
    Dim hVertex2        As Long
    Dim hVertex3        As Long
    Dim hVertex4        As Long


    hParentGraphic    = TCWGraphicCreate ( GK_GRAPHIC, "" )

        hTempGraphic = TCWCircleCenterAndPoint ( _
                                                    PCA#( 0 ), _
                                                    PCA#( 1 ), _
                                                    0#,    _
                                                    ( PCA#( 0 ) + .05# ), _
                                                    ( PCA#( 1 ) + .05# ), _
                                                    0# _
                                                 )

            hCircleGraphic = TCWGraphicCopy ( hTempGraphic )
            TCWGraphicDispose hTempGraphic

        TCWGraphicAppend hParentGraphic, hCircleGraphic


        hCrossGraphic    = TCWGraphicCreate ( GK_GRAPHIC, "" )

            hVertex1 = TCWVertexCreate ( PCA#( 0 ) - .15#,    PCA#( 1 ),            0# )
            hVertex2 = TCWVertexCreate ( PCA#( 0 ) + .15#,    PCA#( 1 ),            0# )
            hVertex3 = TCWVertexCreate ( PCA#( 0 ),            PCA#( 1 ) - .15,    0# )
            hVertex4 = TCWVertexCreate ( PCA#( 0 ),            PCA#( 1 ) + .15,    0# )

            TCWPenDown hVertex1, MY_FALSE
            TCWPenDown hVertex2, MY_TRUE
            TCWPenDown hVertex3, MY_FALSE
            TCWPenDown hVertex4, MY_TRUE

            TCWGraphicVertexAdd hCrossGraphic, hVertex1
            TCWGraphicVertexAdd hCrossGraphic, hVertex2
            TCWGraphicVertexAdd hCrossGraphic, hVertex3
            TCWGraphicVertexAdd hCrossGraphic, hVertex4

        TCWGraphicAppend hParentGraphic, hCrossGraphic


    TCWGraphicAppend NULL, hParentGraphic


    TCWGraphicDraw hParentGraphic, 0


    TCWUndoRecordStart hDrawing, "Virtual Point"

        TCWUndoRecordAddGraphic hDrawing, hParentGraphic

    TCWUndoRecordEnd hDrawing


End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: CheckReturnValue'''''''''''''''''''''''''''''''''
'
' * Parameters: None
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine is used to check the return
' *         value from API calls that return a value
' *         such as a handle to a graphic when called.
' *         If the value returned is NULL(0), then the
' *         for some reason the function was not able
' *         to complete successfully so another function
' *         is then called from another subroutine to
' *         grab the current error string reported from
' *         the last function called.
' *
' *
Sub CheckReturnValue (    ByVal FunctionString as String, _
                        ByVal ReturnValue As Long )

    if ReturnValue = 0 then

        CheckForTCWError FunctionString & " = " & ReturnValue & " "

    end if

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''





''SUBROUTINE: ErrAction''''''''''''''''''''''''''''''''''''''''
'
' * Parameters: ByVal ErrString As String
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This function report errors using the
' *         method specified by the ERR_METHOD
' *         constant value which is set in this
' *         script's constant section.
' *
' *
Sub ErrAction ( ByVal ErrString As String )

    select case ERR_METHOD

        case SILENT

            open ERR_FILE for append as # 10

                print # 10, ErrString

            close

            if ERR_SET = 0 then    ToggleErrSet

        case MSG_BOX

            MsgBox ErrString & Chr$( 10 ) & "Please press OK to terminate script", _
                                             MB_OK, "Find Intersection Error"

            if ERR_STOP = ERR_TRUE then    STOP

        case ALL

            open ERR_FILE for append as # 10

                print # 10, ErrString

            close


            MsgBox ErrString & Chr$( 10 ) & "Please press OK to terminate script", _
                                             MB_OK, "Find Intersection Error"


            if ERR_SET = 0 then    ToggleErrSet
            if ERR_STOP = ERR_TRUE then    STOP


        case NONE

            ' * No error reporting method active

    end select

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: CheckForTCWError'''''''''''''''''''''''''''''''''
'
' * Parameters: ByVal errString As String
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This subroutine checks to see
' *         if a Tcadapi call generated
' *         an error.
' *
' *
Sub CheckForTCWError ( ByVal errString As String )

    dim errCurrent    as string

    errCurrent = TCWLastErrorGet


    if errCurrent <> "" then

        ErrAction errString & " " & errCurrent

    end if

    TCWClearError

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: DoErrSetValue''''''''''''''''''''''''''''''''''''
'
' * Parameters: None
' *
' * Return Value: None
' *
' * Description:
' *
' *        This subroutine removes the current
' *         log file from the drive and then
' *         calls the subroutine to reset the
' *         constant value in this script's
' *         source file.
' *
' *
Sub DoErrSetValue ()

    kill ERR_FILE
    Toggle "ERR_SET"

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: Toggle'''''''''''''''''''''''''''''''''''''''''''
'
' * Parameters: ByVal strConstant As String
' *
' * Return Value: None
' *
' * Description:
' *
' *        This subroutine toggles the current
' *         value of the constant in this
' *         script's source file specified
' *         by strConstant.
' *
' *
Sub Toggle ( ByVal strConstant As String )

    Dim sLength        As Long
    Dim cString        As String
    Dim cResult        As Long
    Dim mResult        As Long
    Dim writeval    As Integer
    Dim counter        As Long


    fLength = filelen ( SCRIPT_FILE )
    sLength = (len ( strConstant ) )


    open SCRIPT_FILE for input as #1


        for counter = 0 to fLength


            seek #1, counter
            cString = input ( sLength, #1 )

            if cString = strConstant then

                msgbox cString

                counter = counter + sLength
                seek #1, counter

                cString = input ( 1, #1 )
                msgbox cString

                exit for

            end if


        next


    close #1


    if cString = "0" then

        writeval = 1

    else

        writeval = 0

    end if


    open SCRIPT_FILE for output as #1

        seek #1, counter
        write #1, writeval

    close #1

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




''SUBROUTINE: DoUI'''''''''''''''''''''''''''''''''''''''''''''
'
' * Parameters: None
' *
' *
' * Return Value: None
' *
' *
' * Description:
' *
' *        This is the script's user interface subroutine.
' *         It's actually a dialog box definition that serves
' *         as a "template" for later creating a variable of
' *         of this type and them using the enable function
' *        'Dialog' to display it and return values.  The
' *         dialog definition is done in a manner very similar
' *         to creating user defined variables with the type
' *         function in basic or the struct function in C.
' *         By utilizing several of the UI objects available
' *         you can actually create quite a useful interface
' *         for setting script values and options as well as
' *         guiding the user through script setup with a
' *         "wizard" like interface.
' *
' *
Sub DoUI ()

    Begin Dialog UI 60, 60, 240, 184, "Virtual Intersection Finder"

        Text        30,    30,    200, 200,    "The Virtual Intersection Finder script allows you to choose two lines and will then place a point graphic at the 'virtual' intersection of the two lines."

        CheckBox    30, 100, 200, 10, "&Display this dialog every time this script is run?", .chkDisplay

        OKbutton     80, 170, 40, 12
        CancelButton 120, 170, 40, 12

    End Dialog


    Dim UIDlg As UI
    UIDlg.chkDisplay = 1
    button = Dialog ( UIDlg )


    if button = 0 then

        END

    else

        if UIDlg.chkDisplay = 0 then

            Toggle "Global Const DISPLAY_SPLASH = "

        end if

    end if

End Sub
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''