Any free macros / VBA for Solving Arc, chord, radius & angle, then output as text?

I am constantly doing layouts that involve using Arc, radius, chord & angle, where two of those are known, and the other two are unknown (needs to be either layout or manually calculated).    I already have an excel spread sheet to doing something similar.    I was just curious if there are any programs out there that do any kind of arc, chord & angle type of manipulation.   For example, where it prompts you for a radius (the user would either input a radius on the number keypad or could measure/select two point in the drawing as input radius).   then it would prompt you for either a chord or angle in the same manner.    Then it would generate the solution as a text.  

It's a lot quicker to input arc or angle, with a click of a mouse, then inputting into excel (and possibly making a typing mistake);  and having to measure radius, or angle, then transcribing it to excel into the appropriate cell to solve the unknowns variable.    Then having to copy the results, back to microstationas text.   I am sure, I am not the only one that has ever needed such a program, and was just curious if there was one already written by someone (or something similar relating to solving for arc, chord, radius or angle).    Thanks

Parents
  • If you can write the forumulæ in Excel, then you (or someone) can reproduce them using VBA.

     

    Regards, Jon Summers
    LA Solutions

     
    Regards, Jon Summers
    LA Solutions

  • This is code for a macro that will do bearing and arcs, it is over a decade old but still works. I have be meaning to change it to a vba for years, but is low on my list.  You can either copy into a macro, or use the  concept in a vba.

     

    ' Places bearing on a line or arc

    '--------------------------------------------------------------------

    '   Created:    Larry Wilson

    '   Workfile:  Bearing.bas

    '   Revision:   1.0     

    '   Date:       3/1998

    '   Rev:1A      LWilson-Change seperator and from dbl '' to " 

    '   Notes:      

    '--------------------------------------------------------------------

    Sub DegMinSec (Iangle#,Angle$)

     

        Dim Degrees As Integer

        Dim Minutes As Integer

        Dim Seconds As Integer

        Dim TempDouble as Double

        Dim Sec as String

        Sec=CHR$(34)

               TempDouble = IAngle

               Degrees = IAngle

               TempDouble = TempDouble - Degrees

               If TempDouble < 0 Then

                  TempDouble = Abs(1 - Abs(TempDouble))

                  Degrees = Degrees - 1

               End If

     

               TempDouble = TempDouble * 60

               Minutes = TempDouble

               TempDouble = TempDouble - Minutes

     

               If TempDouble < 0 Then

                  TempDouble = Abs(1 - Abs(TempDouble))

                  Minutes = Minutes - 1

               End If

     

               TempDouble = TempDouble * 60

               Seconds = TempDouble

     

               if Seconds > 59.5 then

                 Minutes = Minutes + 1

                 Seconds = Seconds - 60

               End if  

               if Minutes > 59 then

                 Degrees = Degrees + 1

                 Minutes = Minutes - 60

               End If

               Degrees = Abs(Degrees)

               Minutes = Abs(Minutes)

               Seconds = Abs(Seconds)

     

     

               Angle$ = Format$(Degrees,"General Number") + "^" 

               Angle$ = Angle$ + Format$(Minutes,"General Number") + "'" 

               Angle$ = Angle$ + Format$(Seconds,"General Number") + Sec

     

    End Sub

     

    Sub Main

        MbeSendCommand "Null"

    '    MbeSendCommand "set parseall off"

     

        Dim accepted As Integer 

        Dim elem As New MbeElement  'defines an object called elem in which we 

                                    'will keep our element

        Dim filePos As Long

        Dim status As Integer

        Dim Label as String

        Dim IAngle as Double

        Dim Radius as Double

        Dim element as New MbeElement

     

        Dim Angle As String

        Dim ArcLength as Double

        Dim TempDouble as Double 

        Dim StartPoint as MbePoint

        Dim EndPoint as MbePoint

     

        Dim ChLength as Double

        Dim ChAngle as Double

        Dim ChBearing as String

        Dim NS as String

        Dim EW as String

        Dim endOfFilePos as Long

        Dim Sp as String

        Dim RotAngle as Double

        Sp = " "

     

     

     

    '    MbeSendCommand "NOECHO"

        MbeWriteCommand "MACRO Label Bearing"

        MbeWritePrompt "Select Element"

     

        accepted = FALSE

        While NOT accepted

            MbeStartLocate

            MbeWritePrompt "Select element..."

     

            MbeGetInput MBE_DataPointInput, _

                        MBE_ResetInput,  _

                        MBE_CommandInput, _

                        MBE_KeyInInput

    Start:

            Lablel$ = "" 

            Select Case MbeState.InputType

              Case MBE_CommandInput 

                MbeSendLastInput

                Exit Sub

              Case MBE_KeyinInput 

                MbeSendLastInput

                Exit Sub

            End Select 

     

            MbeSendLastInput

            filePos = element.fromLocate()

     

           'While we've found an element that we haven't yet accepted

            While MbeState.CmdResult = MBE_AcceptQuery AND _

                  NOT  accepted

     

                MbeWritePrompt "Accept/Reject"

                MbeGetInput MBE_DataPointInput, _

                            MBE_ResetInput, _

                            MBE_CommandInput, _

                            MBE_KeyInInput

     

     

                MbeSendLastInput

     

                Select Case  MbeState.InputType

                  Case MBE_ResetInput  

                    filePos = elem.fromLocate()

                    'Because MbeStartLocate automatically finds another

                    'element if there is one at the same place.

                  Case MBE_DataPointInput

                    accepted = TRUE

                  Case MBE_CommandInput 

                    MbeSendLastInput

                    Exit Sub

                  Case MBE_KeyinInput 

                    MbeSendLastInput

                    Exit Sub

                End Select

             Wend

     

           Wend

     

         MbeSendCommand "Null"

         Dim Tang as Double

         Select Case element.type

            Case Mbe_Arc

               Radius = Element.primaryAxis

               Label$ = "R=" + Format$(Radius, "Fixed") + "'"

               IAngle = Element.SweepAngle

               IAngle = Abs(IAngle)

               IAngle = IAngle*180/PI

               tang=iangle/2

               tang=Tan(Tang/180*pi)

               Tang=(Radius * Tang)

               Call DegMinSec (IAngle#, Angle$)

               Label$ = Label$ + chr$(10)

               Label$ = Label$ + "23/64 ="

               Label$ = Label$ + Angle$

               Label$ = Label$ + chr$(10)

               Label$ =Label$+"T="+Format$(tang, "Fixed")

               Label$ = Label$ + chr$(10)

               Label$ = Label$ + "ARC ="

               ArcLength = IAngle / 360

               ArcLength = ArcLength * PI * Radius * 2

               Label$ = Label$ + Format$(ArcLength, "Fixed") + "'"

     

     

            Case Mbe_Line

            Case Else

     

         End Select

     

    DistBear:

        Status=Element.getEndPoints(StartPoint,EndPoint)

        TempDouble = (StartPoint.x - EndPoint.x) 

        Chlength = (StartPoint.y - EndPoint.y)

        TempDouble = TempDouble * TempDouble

        ChLength = ChLength * ChLength

        ChLength = ChLength + TempDouble

        ChLength = Sqr(ChLength) 

     

    MbeSendCommand "Null"

     

        MbeSendKeyin "dv=TEMP01"

        MbeSendKeyin "sv=TEMP01"

        MbeSendDataPoint startpoint, 1%

     

        MbeSendKeyin "vi=top"

        MbeSendDataPoint startpoint, 1%

     

     

     

     

     

        MbeSendCommand "act an pt3"

        MbeSendDataPoint Startpoint

        MbeSendKeyin "dx=,-5"

        MbeSendKeyin "di=5,n0^e"

        RotAngle = MbeSettings.angle * 180 / PI

     

     

     

        MbeSendCommand "act an pt2"

        MbeSendDataPoint Startpoint

        MbeSendDataPoint EndPoint

     

        MbeSendCommand "Null"

     

     

        MbeSendKeyin "vi=TEMP01"

        MbeSendDataPoint startpoint, 1%

        MbeSendKeyin "dv=TEMP01"

     

     

        ChAngle = MbeSettings.angle * 180 / PI

        ChAngle = Changle - RotAngle

        if ChAngle < 0 Then

          ChAngle = 360 + ChAngle

        End If

        Select Case ChAngle

          Case 0 to 90

           NS = "N"

           EW = "E" 

           ChAngle = 90 - Changle

          Case  90 to 180

           NS = "N"

           EW = "W" 

           ChAngle = ChAngle - 90

     

          Case  180 to 270

           NS = "S"

           EW = "W" 

           ChAngle = 90 - (ChAngle - 180)

     

          Case  270 to 360

           NS = "S"

           EW = "E"

           ChAngle = ChAngle - 270

          Case Else

        End Select  

        IAngle = ChAngle

        Call DegMinSec (IAngle#, Angle$)

     

     

        If element.type = mbe_Arc Then

          Label$ = Label$ + chr$(10) + "Ch=" + NS + Sp + Angle$ + EW 

          Label$ = Label$ + "-" +  Format$(ChLength,"Fixed") + "'"

          MbeSettings.angle = 0

     

        ElseIf element.type = mbe_Line Then

          Label$ =  NS + Sp + Angle$ + EW 

          Label$ = Label$ + Sp + "- " +  Format$(ChLength,"Fixed") + "'"

          MbeSendCommand "act an pt2"

          MbeSendDataPoint Startpoint

          MbeSendDataPoint EndPoint

          TempDouble = MbeSettings.angle/PI

          If (MbeSettings.angle/PI) > .5 and (MbeSettings.angle/PI) < 1.5 Then

            MbeSettings.angle = MbeSettings.angle - PI

          End If

        End If  

     

     

    PlaceText:

        MbeSettings.textjustification = MBE_LeftTop

        MbeSettings.nodejustification = MBE_LeftTop

     

        MbeSendCommand "set parseall off"

     

        MbeSendCommand "Place Text "

        MbeSendKeyin Label

     

        MbeGetInput MBE_DataPointInput, _

                    MBE_ResetInput,  _

                    MBE_CommandInput, _

                    MBE_KeyInInput

     

        MbeSendCommand "set parseall on"

     

     

        Select Case MbeState.InputType

          Case MBE_DataPointInput

            MbeSendLastInput

            MbeSendCommand "Null"

     

          Case MBE_CommandInput 

            MbeSendLastInput

            Exit Sub

          Case MBE_ResetInput 

            Exit Sub

          Case MBE_KeyinInput 

            MbeSendLastInput

            Exit Sub

        End Select 

            MbeWriteCommand ""

            'MbeWritePrompt ""

    '        MbeWriteStatus "Pick Next Line <D> Exit <R>"

     

    '    MbeGetInput MBE_DataPointInput, _

    '                MBE_ResetInput,  _

    '                MBE_CommandInput, _

    '                MBE_KeyInInput

     

     

     

        Select Case MbeState.InputType

          Case MBE_DataPointInput

           Main

          Case MBE_ResetInput 

             GOTO EndMacro

        End Select 

     

     

    EndMacro:

    '   Turn Parse All back on

        MbeSendCommand "set Parseall on"

        MbeSendCommand "Null"

     

     

        MbeSendCommand "ECHO on"

        MbeWriteCommand ""

        MbeWritePrompt ""

        MbeWriteStatus "Finished MACRO LABEL ARC"

     

     

     

     

    End Sub

    Larry Wilson
    LWilson@LJBinc.com
     

  • Also the macro is setup where the user just picks the line or arc and the bearing of the line or information of the arc is put on the end of the cursor at active text format.

    Larry Wilson
    LWilson@LJBinc.com
     

  • Thanks for the Macro.   I tried using it but I am getting an error "complication failed at line 21

    syntax error".    Basically I opened the macro dialog box and selected "new"  blank macro.    Then I pasted your macro lines and saved it as aaa.bas macro.   When I run the macro, I get an error.   Also tried adding  "Sub main" to the beginning of the macro routine.      Is this the way to do it?   Or would it be easier to to just post the Bearing.bas file as an attachment to this thread?   Thanks

  • Hi

    xxx.bas is a Microstation BASIC file extension...  This is old and out-dated.  xxx.mvba is a vba extension.  Please double check that you are pasting this into a vba module.

    --Robert

  • ball888 said:
    I tried using it but I am getting an error " complication failed

    Well, programming MicroStation may seem complicated, but you are more likely to have seen a ' compilation error' 8-)

    The copied BASIC text inadvertently introduced a number of blank lines. Usually a blank line doesn't matter, but here some occur after a BASIC continuation character ('_'). The BASIC compiler doesn't understand a blank line after a continuation character.

    The attached Bearing.bas has extra lines removed and compiles & runs on V8i.

    Prefer VBA to BASIC

    Heed Robert's advice and prefer VBA to BASIC.

    Regards, Jon Summers
    LA Solutions

     
    Regards, Jon Summers
    LA Solutions

    Bearing.bas
  • How much work would it be to convert this macro to vba?  If  you had to guess, how many house range?  Thanks  

  • Best guess with an experienced programmer maybe 4 hours including debuging

    Larry Wilson
    LWilson@LJBinc.com
     

  • thanks, and how long did it take you to write it from scratch?

  • Bearing Annotator VBA

    ball888 said:
    How much work would it be to convert this macro to vba?

    Some.

    Attached is a ZIP archive that contains a DGN file and a VBA project file BearingAnnotator.mvba. The DGN shows a 'star' of annotated vectors. The annotations in blue are obtained from Larry's original BASIC macro. The annotations in green are created by the VBA project.

    In order to try out the VBA macro …

    1. Unzip Bearing.ZIP
    2. Copy BearingAnnotator.mvba to one of MicroStation's know VBA folders. For example, \Bentley\Workspace\Standards\VBA
    3. Start MicroStation and keyin vba run [BearingAnnotator]modMain.Main
    4. Select a line to annotate and place the annotation

    Note: I've not written the code to annotate an arc. This version only annotates lines.

    Please feel free to provide comments.

    Regards, Jon Summers
    LA Solutions

     
    Regards, Jon Summers
    LA Solutions

    Bearing.zip
Reply
  • Bearing Annotator VBA

    ball888 said:
    How much work would it be to convert this macro to vba?

    Some.

    Attached is a ZIP archive that contains a DGN file and a VBA project file BearingAnnotator.mvba. The DGN shows a 'star' of annotated vectors. The annotations in blue are obtained from Larry's original BASIC macro. The annotations in green are created by the VBA project.

    In order to try out the VBA macro …

    1. Unzip Bearing.ZIP
    2. Copy BearingAnnotator.mvba to one of MicroStation's know VBA folders. For example, \Bentley\Workspace\Standards\VBA
    3. Start MicroStation and keyin vba run [BearingAnnotator]modMain.Main
    4. Select a line to annotate and place the annotation

    Note: I've not written the code to annotate an arc. This version only annotates lines.

    Please feel free to provide comments.

    Regards, Jon Summers
    LA Solutions

     
    Regards, Jon Summers
    LA Solutions

    Bearing.zip
Children