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

VBA shortening lines

18 REPLIES 18
SOLVED
Reply
Message 1 of 19
eljoseppo
1920 Views, 18 Replies

VBA shortening lines

Hi,

I need some macro to shorten and cut every line on one layer (always yellow).

bend_lines.png

 

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?

 

18 REPLIES 18
Message 2 of 19
kasperwuyts
in reply to: eljoseppo

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

 


Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
Message 3 of 19
eljoseppo
in reply to: kasperwuyts

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

Message 4 of 19
eljoseppo
in reply to: eljoseppo

Here is the my testing file. Please advise were is my mistake. 

Message 5 of 19
kasperwuyts
in reply to: eljoseppo

Your problem might be that you are deleting and creating lines instead of modifying them. The code is looping through all objects in the layout, based on their index number. Every item on an autocad layout has a unique index number (0 for the first object, 1 for the next item, etc...). If you delete an item, all the next items shift their index number. So you can imagine this is asking for trouble. So instead of doing that, just modify them using the .startpoint and .endpoint properties as I did.

Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
Message 6 of 19
eljoseppo
in reply to: kasperwuyts

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.

 

 

Message 7 of 19
kasperwuyts
in reply to: eljoseppo

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

 


Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
Message 8 of 19
eljoseppo
in reply to: eljoseppo

ok, I will try to make it work in my case. Thx a lot.

Message 9 of 19
kasperwuyts
in reply to: eljoseppo

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.


Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
Message 10 of 19
RICVBA
in reply to: kasperwuyts

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.

 

 

Message 11 of 19
eljoseppo
in reply to: RICVBA

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.

 

AutoCAD - trim error.png

 

Thanks for your work!

Message 12 of 19
RICVBA
in reply to: eljoseppo

it was a copy/past error of mine

that code line should be

ssetLinesInLayers.Delete

 that way should work

Message 13 of 19
kasperwuyts
in reply to: RICVBA

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.


Best regards
Kasper Wuyts
_______________________________________________________________________________
If this post solves your problem, clicking the 'accept as solution' button would be greatly appreciated.
Message 14 of 19
eljoseppo
in reply to: kasperwuyts

kasper, If you can post your solution too I'll be happy to test it in my environment.
Message 15 of 19
eljoseppo
in reply to: RICVBA

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.

Message 16 of 19
RICVBA
in reply to: kasperwuyts

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

 

Message 17 of 19
eljoseppo
in reply to: RICVBA

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.

Message 18 of 19
eljoseppo
in reply to: eljoseppo

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

 

Message 19 of 19
eljoseppo
in reply to: eljoseppo

the last lines in bold should be after Else not End if.

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

Post to forums  

Autodesk Design & Make Report

”Boost