Drawing perpendicular lines

[AstroNout]

Hi guys,

 

I'm new at this, so forgive my stupidity if you find it annoying.

 

So here's the problem. I'm currently working at making maps for the flemish government. As you aspect, there are some things that keep returning over and over again, so I would like to make the whole process a bit faster.

 

I have to draw two perpendicular lines on an existing line like so:

 

_____ ---> l_____l

 

When i click the points from left to right:

______

| |

So the other way around.

 

The lines are of constant lenght, being 0.3m

 

So far I have the following, but it doesn't work because of different array types and I'ld like to use the "GetPoint" procedure.

 

 

Dim p0 as AcadPoint
Dim p1 as AcadPoint
Dim p2(1) as double
Dim p3(1) as Double

'The following only seems to work when I Dim p0 and p1 as variant
Set p0 = ThisDrawing.Utility.GetPoint()
Set p1 = ThisDrawing.Utility.GetPoint()

'Calculate the first point
p2(0) = p0(0) - 0.3 * (p0(1) - p1(1))/((p0(0)-p1(0))^2+(p0(1)-p1(1))^2)^0.5

'And so on for the other coördinates
'Then draw the lines

Dim pLine1 as AcadPolyLine
Set pLine1 = Thisdrawing.Application.ActiveDocument.Modelspade.Addline(p0, p2)
'Dito for the second line

 

 

Programming, it's been a while, so it's frustrating if you can't even get this simple thing to work.

 

Thanks for the help!

Arnout

[Joro--]

I think you are trying to get something like:

 

 

Sub TestDrawLines()
   Dim p0 As Variant
   Dim p1 As Variant
   Dim p2(2) As Double
   Dim p3(2) As Double

   On Error GoTo ErrorTrapping

   'The following only seems to work when I Dim p0 and p1 as variant
   p0 = ThisDrawing.Utility.GetPoint()
   p1 = ThisDrawing.Utility.GetPoint(p0)

   'Calculate the first point
   p2(0) = p0(0) - 0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5

   'And so on for the other coordinates
   'Then draw the lines

   Dim Line1 As AcadLine
   Set Line1 = ThisDrawing.ModelSpace.AddLine(p0, p2)
   'Dito for the second line

   Exit Sub
ErrorTrapping:
   MsgBox "Program ends due to error!"
End Sub

[AstroNout]

Hi Joro

 

That seems to be it! Thanks! hopefully i get the calculations right

 

Thanks!

[fixo]

Try this code for multiple input as well

 
Option Explicit
'' ---> request check "Break on Unhandled Errors" in  Tools-> Options -> General tab  <---
Public Sub DrawTicks()
Dim stPt As Variant, endPt As Variant
Dim intOsm As Integer
intOsm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 0
Dim Pi As Double
Pi = Atn(1#) * 4
Do
On Error Resume Next
stPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "First point (ENTER or Right click to exit): ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
endPt = ThisDrawing.Utility.GetPoint(stPt, vbCrLf & "End point: ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
Dim ang As Double
ang = ThisDrawing.Utility.AngleFromXAxis(stPt, endPt)
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(stPt, ang + Pi / 2, 0.3)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, endPt)
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, tmp)
tmp = ThisDrawing.Utility.PolarPoint(endPt, ang + Pi / 2, 0.3)
Set oLine = ThisDrawing.ModelSpace.AddLine(endPt, tmp)
Loop
On Error GoTo 0
ThisDrawing.SetVariable "OSMODE", intOsm
End Sub

[AstroNout]

Allright! It works just fine, I made it all work with cartesian coordinates. Now, i'ld like to put the created lines in an existing (or not yet existing, when it's a new file) layer "N_WLI2". But can't seem to manage that just yet. Like I said, it's been a while... Grmbl...

 

Grtz!

[fixo]

I will try it tomorrow, it's nap time on my side now

ZZZzzzzz

[BIGAL]

Just a dumb question why not use a line type ? All linetypes are created with known dimensions and when used at correct scale reflect the true dimension.

 

This a 9m spacing with 3m gap

*LANE1000,____ _____ ____

A,3.00,-9.00

[fixo]

Allright! It works just fine, I made it all work with cartesian coordinates. Now, i'ld like to put the created lines in an existing (or not yet existing, when it's a new file) layer "N_WLI2". But can't seem to manage that just yet. Like I said, it's been a while... Grmbl...

 

Grtz!

Here is two procedures you sked for

try again

 
Option Explicit
'' request check "Break on Unhandled Errors" in General options
' 1. draw lines by picking points
Public Sub DrawTicks()
Dim stPt As Variant, endPt As Variant
Dim intOsm As Integer
intOsm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 0
Dim PI As Double
PI = Atn(1#) * 4
'create layer if this does not exists
If Not LayerExists("N_WLI2") Then AddLayer ("N_WLI2")
Do
On Error Resume Next
stPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "First point (ENTER or Right click to exit): ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
endPt = ThisDrawing.Utility.GetPoint(stPt, vbCrLf & "End point: ")
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0
Dim ang As Double
ang = ThisDrawing.Utility.AngleFromXAxis(stPt, endPt)
Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(stPt, ang + PI / 2, 0.3)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, endPt)
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, tmp)
tmp = ThisDrawing.Utility.PolarPoint(endPt, ang + PI / 2, 0.3)
Set oLine = ThisDrawing.ModelSpace.AddLine(endPt, tmp)
Loop
On Error GoTo 0
ThisDrawing.SetVariable "OSMODE", intOsm
End Sub

'2.0 for existing lines
Public Sub AddTicks()
Dim sset As AcadSelectionSet
Dim dxfCode, dxfValue
Dim ftype(1) As Integer
Dim fdata(1) As Variant
ftype(0) = 0: fdata(0) = "LINE"
ftype(1) = 8: fdata(1) = "N_WLI2" '<-- layer name
dxfCode = ftype: dxfValue = fdata
Dim lineObj As Object
Dim oEnt As AcadEntity
Dim stPt As Variant
Dim endPt As Variant
Dim movePt As Variant
Dim perpAng As Double
Dim rotAng As Double
Dim PI As Double
PI = Atn(1) * 4
' Define the new selection set object
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set sset = .Add("$Lines$")
End With
sset.SelectOnScreen dxfCode, dxfValue
If sset.Count = 0 Then
MsgBox ("No lines selected on layer ""N_WLI2""")
Exit Sub
End If
For Each oEnt In sset
' get the line object
Set lineObj = oEnt
stPt = lineObj.StartPoint
endPt = lineObj.EndPoint
Dim dblAng As Double
' get line angle
dblAng = lineObj.Angle
' here you need to use your own algorithm don't understand your explanation:
If dblAng >= PI / 2 And dblAng <= PI * 1.5 Then
dblAng = dblAng + PI
End If
'calculate perpendicular angle
'ticks more on right direction:
perpAng = dblAng + PI / 2

Dim tmp As Variant
tmp = ThisDrawing.Utility.PolarPoint(stPt, perpAng, 0.3)
Dim oLine As AcadLine
Set oLine = ThisDrawing.ModelSpace.AddLine(stPt, tmp)
tmp = ThisDrawing.Utility.PolarPoint(endPt, perpAng, 0.3)
Set oLine = ThisDrawing.ModelSpace.AddLine(endPt, tmp)

Next
End Sub

' Frank Oquendo's / Dick Kusleika's technic
Public Function LayerExists(layerName As String) As Boolean
Dim layerObj As AcadLayer
On Error Resume Next
Set layerObj = ThisDrawing.Layers(layerName)
LayerExists = (Err.Number = 0)
End Function
' -------------------------------------------------------------------
Public Function AddLayer(strLayName) As String
' Создать слой с именем strLayName, если такого нет
' и сделать его текущим, в него и будем записывать нашу работу
Dim objLayer As AcadLayer
Dim strActive As String
Dim found_Name As Integer
found_Name = 0
Dim iCount As Integer

iCount = 1
For Each objLayer In ThisDrawing.Layers
' если слоя с таким именем нет
If objLayer.Name <> strLayName Then
iCount = iCount + 1
ElseIf objLayer.Name = strLayName Then
found_Name = 1
Exit For
End If
Next
' если слоя с таким именем нет, то создадим и установим его текущим
If found_Name = 0 Then
Set objLayer = ThisDrawing.Layers.Add(strLayName)
ThisDrawing.ActiveLayer = objLayer
End If
' определим имя текущего активного слоя
strActive = ThisDrawing.ActiveLayer.Name
' если слой с таким именем есть и он уже активный, то проверим его статус
' активный слой заморожен быть не может!
If found_Name = 1 And objLayer.Name = strActive Then
' если его видимость уже включена
' установить его разблокированным
If objLayer.LayerOn = True Then
objLayer.Lock = False
End If
' если его видимость не включена
' установить его видимым, разблокированным
If objLayer.LayerOn = False Then
objLayer.LayerOn = True
objLayer.Lock = False
End If
' если же слой с таким именем есть и он неактивный, то проверим его статус
ElseIf found_Name = 1 And objLayer.Name <> strActive Then
' если его видимость уже включена
' установить его размороженым, разблокированным
If objLayer.LayerOn = True Then
objLayer.Lock = False
objLayer.Freeze = False
End If
' если его видимость не включена
' установить его видимым, размороженым, разблокированным
If objLayer.LayerOn = False Then
objLayer.LayerOn = True
objLayer.Lock = False
objLayer.Freeze = False
End If
' и установим его текущим активным
ThisDrawing.ActiveLayer = objLayer
End If
' и выйти из процедуры
End Function
' -------------------------------------------------------------------
' After you have determine the linetype library and the name of a specific linetype
' that you'd like to load, the following code can be used to load it.
' -------------------------------------------------------------------
' author unknown
Public Sub LoadLinetype()
Dim ltname As String
Dim oLtype As AcadLineType
Dim existFlag As Boolean

ltname = InputBox("Enter a linetype name" & _
" to load from ACAD.LIN: ")
If "" = ltname Then Exit Sub ' exit if no name entered

On Error Resume Next ' handle exceptions inline
existFlag = IsLtypeExist(ltname)
If existFlag = False Then
Err.Clear

If ThisDrawing.GetVariable("measureinit") = 0 Then
ThisDrawing.Linetypes.Load ltname, "acad.lin"
Else
ThisDrawing.Linetypes.Load ltname, "acadiso.lin"
End If

If Err Then ' check if err was thrown
MsgBox "Error loading '" & ltname & "'" & vbCr & _
Err.Description
Else
MsgBox "Loaded Linetype '" & ltname & "'"
End If
End If
End Sub

[AstroNout]

Hi guys,

 

Right, i've had a bit of sleep and got on it straight away. The following is the end-product, and works just fine!

 

Sub Kop3()
   Dim p0 As Variant
   Dim p1 As Variant
   Dim p2(2) As Double
   Dim p3(2) As Double
   Dim pLine1, pLine2 As AcadLine
   
   On Error GoTo ErrorTrapping
       
   p0 = ThisDrawing.Utility.GetPoint(, "Eerste punt (ENTER of Rechtse klik om te verlaten):")
   p1 = ThisDrawing.Utility.GetPoint(p0, "Eindpunt (ENTER of Rechtse klik om te verlaten):")
   
   p2(0) = p0(0) - (0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)
   p2(1) = p0(1) + (0.3 * (p0(0) - p1(0)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)
   
   p3(0) = p1(0) - (0.3 * (p0(1) - p1(1)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)
   p3(1) = p1(1) + (0.3 * (p0(0) - p1(0)) / ((p0(0) - p1(0)) ^ 2 + (p0(1) - p1(1)) ^ 2) ^ 0.5)

   Set pLine1 = ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine(p0, p2)
   Set pLine2 = ThisDrawing.Application.ActiveDocument.ModelSpace.AddLine(p1, p3)
   
   Dim Layer As AcadLayer
   Set Layer = ThisDrawing.Application.ActiveDocument.Layers.Add("N_WLI2")
   pLine1.Layer = "N_WLI2"
   pLine2.Layer = "N_WLI2"
   
   Exit Sub
   
ErrorTrapping:
   MsgBox "Fout bij het aanduiden!"
End Sub

 

Thanks for the help!

[fixo]

Time to start new stuffs:

http://docs.autodesk.com/ACD/2010/ENU/AutoCAD%20.NET%20Developer's%20Guide/index.html?url=WS1a9193826455f5ff2566ffd511ff6f8c7ca-4875.htm,topicNumber=d0e51

In my opinion

Cheers