VBA
Discuss AutoCAD ActiveX and VBA (Visual Basic for Applications) questions here.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

draw line perpendicular to line

6 REPLIES 6
SOLVED
Reply
Message 1 of 7
ramanusu
1143 Views, 6 Replies

draw line perpendicular to line

Hi all,

                I like to draw line perpendicular to line using vba. Anyone have sample code?

 

Thanks

Ramanusu

6 REPLIES 6
Message 2 of 7
Hallex
in reply to: ramanusu

Try this code

Option Explicit

'' based on code written by Tony Tanzillo
'' request check "Break on Unhandled Errors" in  General options
Public Sub LoopExample()
Dim ptColl As Collection
Set ptColl = New Collection
Dim intOsm As Integer
intOsm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 35
Dim Msg As String
Msg = vbCrLf & "First point: "
Dim MyPoint As Variant

Do
On Error Resume Next
MyPoint = ThisDrawing.Utility.GetPoint(, Msg)
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0

ptColl.Add MyPoint
Msg = vbCrLf & "Next point [ or ENTER to exit ]: "
Loop
On Error GoTo 0

Dim oEntity As AcadEntity
Dim varPt As Variant
ThisDrawing.Utility.GetEntity oEntity, varPt, vbCr & "Select a projection oLine >> "
If Not oEntity Is Nothing Then
If TypeOf oEntity Is AcadLine Then
Dim oLine As AcadLine
Set oLine = oEntity
Dim stPt As Variant, endPt As Variant
stPt = oLine.StartPoint: endPt = oLine.EndPoint
End If
End If

Dim Pi As Double
Pi = Atn(1#) * 4
Dim ang As Double
ang = ThisDrawing.Utility.AngleFromXAxis(stPt, endPt)
Dim outColl As Collection
Set outColl = New Collection

Dim itm As Variant
Dim num As Integer

For num = 1 To ptColl.Count
itm = ptColl.Item(num)
Dim tmpPt1(2) As Double
tmpPt1(0) = itm(0): tmpPt1(1) = itm(1): tmpPt1(2) = itm(2):
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(tmpPt1, ang - Pi / 2, 1)
Dim tmpPt2(2) As Double
tmpPt2(0) = tmp(0): tmpPt2(1) = tmp(1): tmpPt2(2) = tmp(2):
Dim oXLine As AcadXline
Set oXLine = ThisDrawing.ModelSpace.AddXline(tmpPt1, tmpPt2)
Dim intPt As Variant
intPt = oXLine.IntersectWith(oLine, acExtendNone)
outColl.Add intPt
oXLine.Delete
Next num

Dim i As Integer
Dim j As Integer
Dim dblDist As Double

For i = 1 To outColl.Count

Set oLine = ThisDrawing.ModelSpace.AddLine(outColl.Item(i), ptColl.Item(i))

Next i

ThisDrawing.SetVariable "OSMODE", intOsm

Set outColl = Nothing

Set ptColl = Nothing

End Sub

 

 

_____________________________________
C6309D9E0751D165D0934D0621DFF27919
Message 3 of 7
RICVBA
in reply to: ramanusu

thank you Hallex for the code you posted

 

and, since I can't help doing it, here's my optimization or, better, what I think it is

Option Explicit

'' based on code written by Tony Tanzillo
'' request check "Break on Unhandled Errors" in  General options

''' revised by RICVBA 22_02_2014
Public Sub LoopExample() Dim ptColl As Collection, outColl As Collection Dim intOsm As Integer, i As Integer Dim Msg As String Dim oEntity As AcadEntity Dim varPt As Variant, Pt1 As Variant, Pt2 As Variant Dim oLine As AcadLine, oXLine As AcadXline Dim Pi As Double, ang As Double intOsm = ThisDrawing.GetVariable("OSMODE") ThisDrawing.SetVariable "OSMODE", 35 Set ptColl = New Collection Msg = vbCrLf & "First point: " Do On Error Resume Next varPt = ThisDrawing.Utility.GetPoint(, Msg) If Err Then Err.Clear Exit Do End If On Error GoTo 0 ptColl.Add varPt Msg = vbCrLf & "Next point [ or ENTER to exit ]: " Loop On Error GoTo 0 ThisDrawing.Utility.GetEntity oEntity, varPt, vbCr & "Select a projection line >> " If Not oEntity Is Nothing Then If TypeOf oEntity Is AcadLine Then Set oLine = oEntity Pt1 = oLine.StartPoint: Pt2 = oLine.EndPoint Pi = Atn(1#) * 4 ang = ThisDrawing.Utility.AngleFromXAxis(Pt1, Pt2) Set outColl = New Collection For i = 1 To ptColl.Count Pt1 = ptColl.Item(i) Pt2 = ThisDrawing.Utility.PolarPoint(Pt1, ang - Pi / 2, 1) Set oXLine = ThisDrawing.ModelSpace.AddXline(Pt1, Pt2) outColl.Add oXLine.IntersectWith(oLine, acExtendNone) oXLine.Delete Next i For i = 1 To outColl.Count Set oLine = ThisDrawing.ModelSpace.AddLine(outColl.Item(i), ptColl.Item(i)) Next i Set outColl = Nothing End If End If ThisDrawing.SetVariable "OSMODE", intOsm Set ptColl = Nothing End Sub

 

I minimized variables number and made the code core run only If Not oEntity Is Nothing and TypeOf oEntity Is AcadLine

 

nothing you couldn't live without.

 

bye

 

Message 4 of 7
RICVBA
in reply to: ramanusu

a furtherly shorter (and presumibly faster) version

 

'' based on code written by Tony Tanzillo
'' request check "Break on Unhandled Errors" in  General options

''' revised by RICVBA 23_02_2014
Option Explicit

Public Sub LoopExample()

Dim intOsm As Integer
Dim Msg As String
Dim oEntity As AcadEntity
Dim Pt1 As Variant, Pt2 As Variant
Dim RefLine As AcadLine, oLine As AcadLine, oXLine As AcadXline
Dim Pi As Double, ang As Double

ThisDrawing.Utility.GetEntity oEntity, Pt1, vbCr & "Select a projection line >> "
If Not oEntity Is Nothing Then

    If TypeOf oEntity Is AcadLine Then
    
        intOsm = ThisDrawing.GetVariable("OSMODE")
        ThisDrawing.SetVariable "OSMODE", 35

        Set RefLine = oEntity
        Pt1 = RefLine.StartPoint: Pt2 = RefLine.EndPoint

        Pi = Atn(1#) * 4
        ang = ThisDrawing.Utility.AngleFromXAxis(Pt1, Pt2)
        
        Msg = vbCrLf & "First point: "
        Do
            On Error Resume Next
            Pt1 = ThisDrawing.Utility.GetPoint(, Msg)
            If Err Then
                Err.Clear
                Exit Do
            End If
            On Error GoTo 0
           
            Set oXLine = ThisDrawing.ModelSpace.AddXline(Pt1, ThisDrawing.Utility.PolarPoint(Pt1, ang - Pi / 2, 1))
            Set oLine = ThisDrawing.ModelSpace.AddLine(Pt1, oXLine.IntersectWith(RefLine, acExtendNone))
            oXLine.Delete
            
            Msg = vbCrLf & "Next point [ or ENTER to exit ]: "
        Loop
        On Error GoTo 0
        
        ThisDrawing.SetVariable "OSMODE", intOsm
        
    End If

End If

End Sub

 just for "research" purposes

Message 5 of 7
ramanusu
in reply to: RICVBA

Thanks a lot Hallex  & Ricvba’s . quick replay. I will check and let you know, if I have any queries.

 

Bye

Ramanusu  

Message 6 of 7
Hallex
in reply to: RICVBA

Nice changes, thanks 🙂
_____________________________________
C6309D9E0751D165D0934D0621DFF27919
Message 7 of 7
ramanusu
in reply to: Hallex

It's working perfect. i tolk both codes. I have one more query posted. If you have time. Please have look. Thank you very much.

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost