Hi,
I need some macro to shorten and cut every line on one layer (always yellow).
I'm new in Autocad but I wrote some macros in VBA for Inventor. So I have some ideas but don't know the suntax.
Algorythm:
for every line
if line is on layer.name "Etch"
shorten length by 2mm on each end (select one end go with it to the other 2mm?)
leave 10mm on each side and delete rest
end if
next line
done
the line is not always vertical..
any ideas?
Solved! Go to Solution.
Solved by RICVBA. Go to Solution.
Here is a sub that trims all lines on one layer
To access it from another routine
just type
cutlines 20, "0"
This will trim all lines on layer '0' by 10 units on every side (so 20 in total)
Sub cutlines(Trim As Integer, Layername As String) Dim CurrentLine As AcadLine Dim Oldstartpoint() As Double Dim NewStartpoint(0 To 2) As Double Dim Oldendpoint() As Double Dim Newendpoint(0 To 2) As Double 'loops through every object in the current layout For a = 0 To (ThisDrawing.ActiveLayout.Block.Count - 1) 'checks whether object is a line If ThisDrawing.ActiveLayout.Block.Item(a).ObjectName = "AcDbLine" Then 'puts the current line in an object variable for easy writing Set CurrentLine = ThisDrawing.ActiveLayout.Block.Item(a) 'checks whether line is in correct layer If CurrentLine.Layer = Layername Then Oldstartpoint = CurrentLine.StartPoint Oldendpoint = CurrentLine.Endpoint 'formulae that determine the new startpoints and endpoints of the line For i = 0 To 2 NewStartpoint(i) = Oldstartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Newendpoint(i) = Oldendpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next CurrentLine.StartPoint = NewStartpoint CurrentLine.Endpoint = Newendpoint End If End If Next End Sub
Wow Kasper, thx a lot I wouldn't know where to start.
I made some updates ot suite my needs:
Private Sub cutlines() '(Trim As Integer, Layername As String) Dim CurrentLine As AcadLine Dim OldStartpoint() As Double Dim NewStartpoint(0 To 2) As Double Dim OldEndpoint() As Double Dim NewEndpoint(0 To 2) As Double Dim changes As Integer Dim Layername As String Dim Trim_global As Double Dim Trim As Double Layername = "Etch" Trim_global = 20 'loops through every object in the current layout total_lines = 0 'counting all lines changes = 0 'counting lines on proper layer For a = 0 To (ThisDrawing.ActiveLayout.Block.Count - 1) 'checks whether object is a line If ThisDrawing.ActiveLayout.Block.Item(a).ObjectName = "AcDbLine" Then total_lines = total_lines + 1 'counting all lines 'puts the current line in an object variable for easy writing Set CurrentLine = ThisDrawing.ActiveLayout.Block.Item(a) 'checks whether line is in correct layer If CurrentLine.Layer = Layername Then Trim = Trim_global changes = changes + 1 'counting lines on proper layer OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint Length = CurrentLine.Length lmin = False Do Until lmin = True If Length < 2 * Trim Then Trim = Trim / 2 Else lmin = True End If Loop 'formula that determine the new startpoints and endpoints of the line For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.Length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.Length) Next CurrentLine.StartPoint = NewStartpoint CurrentLine.EndPoint = NewEndpoint
' ============ START OF 2ND PART OF CODE =============== ' If Length > Trim * 3 Then 'if it is to long cut it ' OldStartpoint = CurrentLine.StartPoint ' OldEndpoint = CurrentLine.EndPoint ' For i = 0 To 2 ' NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.Length) ' NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.Length) ' Next ' ' Set lineObj = ThisDrawing.ModelSpace.AddLine(NewStartpoint, OldStartpoint) ' lineObj.Color = acYellow ' 'new layer? ' Set lineObj = ThisDrawing.ModelSpace.AddLine(NewEndpoint, OldEndpoint) ' lineObj.Color = acYellow ' ' CurrentLine.Delete ' End If
' ============ START OF 2ND PART OF CODE ===============
End If
End If
Next
'MsgBox ("Bending lines found / total lines " & changes & "/" & total_lines)
'Author: http://forums.autodesk.com/t5/visual-basic-customization/vba-shortening-lines/m-p/5400683#M97949 End Sub
I had to comment my second part od code 😞 When I uncomment the macro does not loop every line in my layer. Do you know why? It does loop only bigger half if u know what I mean (if I have 9 lines on my layer it will trim only 5, then two the one and one, I have to run this rule few times)
BR
Thx, this was my gues too. But I cannot just modify the lines - in the end I want to have two short lines per one long.
Anyway I thought I can:
1. loop trough all of lines,
2. if the line in on my layer trim the edges and collect 4 points in some kind of list,
end of loop
3. create new lines (on a new layer), 4 points (2 lines) for each "primary" line
4. delete everything from the old layer.
just tell me please how to declare the list of points? What is point really? iteration for i=0 to 2 is for XYZ?
thanks for helping, I know I'm AutoCAD newbie.
I think the most elegant solution would be to use a collection, so the procedure would be like this.
1) Loop through all objects. If objects are lines on the right layer, add them to a collection.
2) Loop through the collection and trim and change everything you want without worrying about indexes.
For part one you change the code like this:
Dim LinesCollection as new Collection
'loops through every object in the current layout For a = 0 To (ThisDrawing.ActiveLayout.Block.Count - 1) 'checks whether object is a line If ThisDrawing.ActiveLayout.Block.Item(a).ObjectName = "AcDbLine" Then 'puts the current line in an object variable for easy writing Set CurrentLine = ThisDrawing.ActiveLayout.Block.Item(a) 'checks whether line is in correct layer If CurrentLine.Layer = Layername Then Linescollection.Add CurrentLine End If End If Next
The second part something like this:
For Each CurrentLine In Linescollection 'this is where the magic happens Next
And by the way, yes, a coordinate in Autocad is declared using an array containg 3 doubles, with 0, 1, 2 respectively being x, y, and z.
I guess that using collections could not yet fix it since they also would suffer from deletion of an element inside a for each loop
while selectionset should do
here's how I'd use them
Option Explicit Private Sub cutlines_2() '(Trim As Integer, Layername As String) Dim linesToChange As Integer Dim totalLines As Long Dim layerName As String Dim Trim_global As Double Dim a As Integer layerName = "Etch" Trim_global = 20 Dim ssetLines As AcadSelectionSet Dim ssetLinesInLayers As AcadSelectionSet Set ssetLines = Sset("SsetLines") Set ssetLinesInLayers = Sset("SsetLinesInLayer", layerName) totalLines = ssetLines.Count 'counting all lines linesToChange = ssetLinesInLayers.Count 'counting lines on proper layer 'loops through every selected line and trims it For a = 0 To (linesToChange - 1) Call TrimLines(ssetLinesInLayers.Item(a), Trim_global) Next a 'MsgBox ("Bending lines found / total lines " & changes & "/" & total_lines)
ssetLines.Delete
ssetLinesInLayers
End Sub Sub TrimLines(CurrentLine As AcadLine, Trim As Double) Dim OldStartpoint() As Double Dim NewStartpoint(0 To 2) As Double Dim OldEndpoint() As Double Dim NewEndpoint(0 To 2) As Double Dim i As Integer Dim length As Double Dim lmin As Boolean Dim lineObj As AcadLine OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint length = CurrentLine.length lmin = False Do Until lmin = True If length < 2 * Trim Then Trim = Trim / 2 Else lmin = True End If Loop 'formula that determine the new startpoints and endpoints of the line For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next CurrentLine.StartPoint = NewStartpoint CurrentLine.EndPoint = NewEndpoint If length > Trim * 3 Then 'if it is to long cut it OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next Set lineObj = ThisDrawing.ModelSpace.AddLine(NewStartpoint, OldStartpoint) lineObj.color = acYellow Set lineObj = ThisDrawing.ModelSpace.AddLine(NewEndpoint, OldEndpoint) lineObj.color = acYellow CurrentLine.Delete End If End Sub Function Sset(SsetName As String, Optional layerName As Variant) As AcadSelectionSet Dim gpCode(0 To 1) As Integer Dim dataValue(0 To 1) As Variant Dim ssetObj As AcadSelectionSet If IsMissing(layerName) Then layerName = "*" ' if no layerName is passed then select all layers 'selecting Line objects in the active drawing in the proper layer gpCode(0) = 0: dataValue(0) = "LINE" gpCode(1) = 8: dataValue(1) = layerName On Error Resume Next Set ssetObj = ThisDrawing.SelectionSets.Item(SsetName) If Err <> 0 Then Set ssetObj = ThisDrawing.SelectionSets.Add(SsetName) Else ssetObj.Clear End If On Error GoTo 0 ZoomExtents ssetObj.Select acSelectionSetAll, , , gpCode, dataValue Set Sset = ssetObj End Function
let me know
bye
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
THX, that look nice, it will take me a while before I'll understand what you are doing. Meanwhile please let me know why ny VBA is returning error?
Working on AutoCAD 2015 (SP1?)/WIN7/HP Z420 WorkStation if this is relevant.
Thanks for your work!
Are you sure a collection would not work, RIC? I did some experimenting with deleting lines and the 'for each' loop seems to work fine.
Hi guys,
I made some minor changes and my code is doing what I want:
Private Sub cutlines_2() '(Trim As Integer, Layername As String) Dim linesToChange As Integer Dim totalLines As Long Dim layerName As String Dim Trim_global As Double Dim a As Integer layerName = "Etch" Trim_global = 20 Dim ssetLines As AcadSelectionSet Dim ssetLinesInLayers As AcadSelectionSet Set ssetLines = Sset("SsetLines") Set ssetLinesInLayers = Sset("SsetLinesInLayer", layerName) totalLines = ssetLines.Count 'counting all lines linesToChange = ssetLinesInLayers.Count 'counting lines on proper layer 'loops through every selected line and trims it For a = 0 To (linesToChange - 1) Call TrimLines(ssetLinesInLayers.Item(a), Trim_global) Next a 'MsgBox ("Bending lines found / total lines " & changes & "/" & total_lines) ssetLines.Delete ssetLinesInLayers.Delete End Sub Sub TrimLines(CurrentLine As AcadLine, ByVal Trim As Double) Dim OldStartpoint() As Double Dim NewStartpoint(0 To 2) As Double Dim OldEndpoint() As Double Dim NewEndpoint(0 To 2) As Double Dim i As Integer Dim length As Double Dim lmin As Boolean Dim lineObj As AcadLine Dim Trim_global As Double Trim_global = Trim OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint length = CurrentLine.length lmin = False Do Until lmin = True If length < 2 * Trim Then Trim = Trim / 2 Else lmin = True End If Loop 'formula that determine the new startpoints and endpoints of the line For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next CurrentLine.StartPoint = NewStartpoint CurrentLine.EndPoint = NewEndpoint If length > Trim_global * 3 Then 'if it is to long cut it OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next Set lineObj = ThisDrawing.ModelSpace.AddLine(NewStartpoint, OldStartpoint) lineObj.Color = acYellow Set lineObj = ThisDrawing.ModelSpace.AddLine(NewEndpoint, OldEndpoint) lineObj.Color = acYellow CurrentLine.Delete Else CurrentLine.Layer = "0" CurrentLine.Color = acYellow
End if End Sub Function Sset(SsetName As String, Optional layerName As Variant) As AcadSelectionSet Dim gpCode(0 To 1) As Integer Dim dataValue(0 To 1) As Variant Dim ssetObj As AcadSelectionSet If IsMissing(layerName) Then layerName = "*" ' if no layerName is passed then select all layers 'selecting Line objects in the active drawing in the proper layer gpCode(0) = 0: dataValue(0) = "LINE" gpCode(1) = 8: dataValue(1) = layerName On Error Resume Next Set ssetObj = ThisDrawing.SelectionSets.Item(SsetName) If Err <> 0 Then Set ssetObj = ThisDrawing.SelectionSets.Add(SsetName) Else ssetObj.Clear End If On Error GoTo 0 ZoomExtents ssetObj.Select acSelectionSetAll, , , gpCode, dataValue Set Sset = ssetObj End Function
Once again thank you both for your efford! I'm very suprised how guys from my company are happy to work with this code. You can imagine how timesaving is this.
Kasper
that was actually just a safety guessing of mine
I very often hear or read about the warning concerning looping through collection inside a for-each loop, so I avoid them anyway
It may very well be collection would do it. my knowlwdge isn't as deep as it should be for handling this issue all the way
No doubt the "Collection" way is an elegant way, as you properly pointed out.
Actually, the safest way is collecting all to-be-removed objects in a temporary container (a SelectionSet, a Collection) during the main loop through the first SelectionSet/Collection and then erase them after exiting that loop
as for instance
Option Explicit ' same as cutlines_2 but erasing object collecting them in a temporary selectionset ' it should be the safest way Private Sub cutlines_3() Dim linesToChange As Integer Dim totalLines As Long Dim layerName As String Dim Trim_global As Double Dim a As Integer Dim ssobjs(0) As AcadEntity ' necessary for adding items to selectionset layerName = "Etch" Trim_global = 20 Dim ssetLinesToRemove As AcadSelectionSet Dim ssetLinesInLayers As AcadSelectionSet Set ssetLinesToRemove = Sset("SsetLinesToRemove", False) Set ssetLinesInLayers = Sset("SsetLinesInLayer", True, layerName) linesToChange = ssetLinesInLayers.Count 'counting lines on proper layer 'loops through every selected line and trims it. thne it adds that item to the selectionset for future erasing For a = 0 To (linesToChange - 1) Call TrimLines(ssetLinesInLayers.Item(a), Trim_global) Set ssobjs(0) = ssetLinesInLayers.Item(a) ssetLinesToRemove.AddItems (ssobjs) Next a ssetLinesToRemove.Erase 'delete objects from SelectionSet and from the drawing ssetLinesToRemove.Delete ssetLinesInLayers.Delete 'MsgBox ("Bending lines found / total lines " & changes & "/" & total_lines) End Sub
along with this mian sub revision I had to make some minor modifications to the other two subs, as follows
Function Sset(SsetName As String, Optional okSelect As Variant, Optional layerName As Variant) As AcadSelectionSet Dim gpCode(0 To 1) As Integer Dim dataValue(0 To 1) As Variant Dim ssetObj As AcadSelectionSet If IsMissing(okSelect) Then okSelect = False ' if not specified, do not select any lines If IsMissing(layerName) Then layerName = "*" ' if no layerName is passed then select all layers On Error Resume Next Set ssetObj = ThisDrawing.SelectionSets.Item(SsetName) If Err <> 0 Then Set ssetObj = ThisDrawing.SelectionSets.Add(SsetName) Else ssetObj.Clear End If On Error GoTo 0 If okSelect Then ZoomExtents 'selecting Line objects in the active drawing in the proper layer gpCode(0) = 0: dataValue(0) = "LINE" gpCode(1) = 8: dataValue(1) = layerName ssetObj.Select acSelectionSetAll, , , gpCode, dataValue End If Set Sset = ssetObj End Function
while in "TrimLines" you just have to comment out the following line (which is at the very bottom)
'CurrentLine.Delete
may be eljoseppo can test all these options to find out the quickest and the safest
Hi,
I've tested cutlines3 on bunch of 20 different files. In one case I have different output than I've expected: the lines were removed and nothing was created instead. While cutlines2 did job very well (I keep previous versions of Sset).
So if line is quite short, to short to cut it cutlines2 is ok while cutlines3 does not do what I want. In other case when the line is long and we want to cut it it two halfs the cutline3 is ok and cutlines2 return error sometimes. I don't know why.. In the same file one day it's ok and another is not. Strange.
I'll give feedback when I push out bigger number of DXF's.
I modyfied Trim Sub, now everything seems to work fine:
Sub TrimLines(CurrentLine As AcadLine, ByVal Trim As Double)'ByVal is essential, to keep the global trim value unchanged Dim OldStartpoint() As Double Dim NewStartpoint(0 To 2) As Double Dim OldEndpoint() As Double Dim NewEndpoint(0 To 2) As Double Dim i As Integer Dim length As Double Dim lmin As Boolean Dim lineObj As AcadLine Dim Trim_global As Double Trim_global = Trim OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint length = CurrentLine.length lmin = False Do Until lmin = True If length < 2 * Trim Then Trim = Trim / 2 Else lmin = True End If Loop 'formula that determine the new startpoints and endpoints of the line For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next CurrentLine.StartPoint = NewStartpoint CurrentLine.EndPoint = NewEndpoint If length > Trim_global * 3 Then 'if it is to long cut it OldStartpoint = CurrentLine.StartPoint OldEndpoint = CurrentLine.EndPoint For i = 0 To 2 NewStartpoint(i) = OldStartpoint(i) + (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) NewEndpoint(i) = OldEndpoint(i) - (CurrentLine.Delta(i) * (Trim / 2) / CurrentLine.length) Next Set lineObj = ThisDrawing.ModelSpace.AddLine(NewStartpoint, OldStartpoint) lineObj.Color = acYellow Set lineObj = ThisDrawing.ModelSpace.AddLine(NewEndpoint, OldEndpoint) lineObj.Color = acYellow 'CurrentLine.Delete End If Set lineObj = ThisDrawing.ModelSpace.AddLine(NewStartpoint, NewEndpoint) lineObj.Color = acYellow End Sub