http://screencast.com/t/4Cgvv5Tq
I work for a stainless steel manufacturing company where we use Inventor to model up our poducts, then export the sheetmetal parts using a flat pattern extracting tool which converts the flat patterns to a dxf file format that can be read by our CAM software. Right now we have to manually modify the dxf files to adjust the bend lines in order to be etched on the parts by our laser. I found a routine on the forum that I was able to use and modify to fit our needs to reduce this process to only a couple of steps. I would like to further modify the code to move the bend line to the center of the original line before it was modified. You would think that this would be an easy routine to write and it probably is to a more advanced coding gurus, however, I have very little experience writing VB code and no experience with VB in AutoCAD. I have spent about 8hrs trying to solve this problem to no avail. So if anyone can share some sample code that would point me in the right direction, I would greatly appreciate it. I have attached a link to a video that I created to show you what the code does right now and what I would like it to do.
Public Sub TrimBendLines()
'-------------------------------------------ADD MARK LAYER----------------------------------------------------
LayerName = "MARK"
Set MARK = ThisDrawing.Layers.Add(LayerName)
MARK.color = acRed
'---------------------------------------BEND UP LINES----------------------------------------------------
'Change the following line to match your layer names
Dim BendLineLayer As String: BendLineLayer = "IV_BEND"
'Change the following line to adjust how much line is left
Dim Remnant As Double: Remnant = 0.5
'Variable to hold PI for angle calculations
Const PI As Double = 3.14159265358979
'Need to declare a selection set in AutoCAD to store bend lines for trimming
Dim SelSet As AcadSelectionSet
On Error Resume Next
ThisDrawing.SelectionSets.Add ("BendLines")
Set SelSet = ThisDrawing.SelectionSets.Item("BendLines")
SelSet.Clear
On Error GoTo 0
Dim FilterType(1) As Integer
Dim FilterData(1) As Variant
'Create filters so that we only select line objects on the bend line layer
FilterType(0) = 8: FilterData(0) = BendLineLayer
FilterType(1) = 0: FilterData(1) = "Line"
'Select the objects (if any exist)
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'If no bend lines are found then exit the sub routine
If SelSet.Count = 0 Then
GoTo BendDown
'Exit Sub
End If
'Set the active layer to the bend line layer for newly created lines
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer)
'Enumerate the selection set and shorten the exiting bend line
'Next we create a new bend line existing at the endpoint.
Dim L As AcadLine
For Each L In SelSet
Dim EndPoint As Variant: EndPoint = L.EndPoint
L.EndPoint = ThisDrawing.Utility.PolarPoint(L.StartPoint, L.Angle, Remnant)
Call ThisDrawing.ModelSpace.AddLine(ThisDrawing.Utility.PolarPoint(EndPoint, L.Angle - PI, Remnant), EndPoint)
L.Layer = "MARK"
'L.TrueColor = acBlue
Next
'-------------------------------------------------CONVERT NEW LINES TO MARK LAYER ----------------------------------------
BendLineLayer = "IV_BEND"
On Error Resume Next
ThisDrawing.SelectionSets.Add ("BendLines")
Set SelSet = ThisDrawing.SelectionSets.Item("BendLines")
SelSet.Clear
On Error GoTo 0
'Create filters so that we only select line objects on the bend line layer
FilterType(0) = 8: FilterData(0) = BendLineLayer
FilterType(1) = 0: FilterData(1) = "Line"
'Select the objects (if any exist)
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'If no bend lines are found then exit the sub routine
If SelSet.Count = 0 Then
Exit Sub
End If
'Set the active layer to the bend line layer for newly created lines
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer)
For Each L In SelSet
L.Layer = "MARK"
Next
'--------------------------------------------------------BEND DOWN LINES----------------------------------------
BendDown:
'Change the following line to match your layer names
BendLineLayer = "IV_BEND_DOWN"
'Need to declare a selection set in AutoCAD to store bend lines for trimming
On Error Resume Next
ThisDrawing.SelectionSets.Add ("BendLines")
Set SelSet = ThisDrawing.SelectionSets.Item("BendLines")
SelSet.Clear
On Error GoTo 0
'Create filters so that we only select line objects on the bend line layer
FilterType(0) = 8: FilterData(0) = BendLineLayer
FilterType(1) = 0: FilterData(1) = "Line"
'Select the objects (if any exist)
SelSet.Select acSelectionSetAll, , , FilterType, FilterData
'If no bend lines are found then exit the sub routine
If SelSet.Count = 0 Then
Exit Sub
End If
'Set the active layer to the bend line layer for newly created lines
ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer)
'Enumerate the selection set and shorten the exiting bend line
'Next we create a new bend line existing at the endpoint.
Dim x As Double
Dim y As Double
Dim MP(0 To 2) As Double
Dim EP(0 To 2) As Double
For Each L In SelSet
x = L.Delta(0) / 2
y = L.Delta(1) / 2
'EP(0) = L.EndPoint(0): EP(1) = L.EndPoint(1)
'MP(0) = L.Delta(0) / 2: MP(1) = L.Delta(1) / 2
L.EndPoint = ThisDrawing.Utility.PolarPoint(L.StartPoint, L.Angle, Remnant)
L.Layer = "MARK"
'L.EndPoint(0) = x: L.EndPoint(1) = y
'MP = L.Length / 2:
'L.Move EP, MP
'If L.StartPoint(0) = L.EndPoint(0) The
'LA = L.Angle
'EP(0) = L.EndPoint(0)
'SP(0) = L.StartPoint(0)
'LN = L.Length
'End If
Next
End Sub
Solved! Go to Solution.
Solved by RICVBA. Go to Solution.
following your declaration (i.e.: "...to move the bend line to the center of the original line before it was modified") I'd use the "move" method as follows (see added lines marked with "'<--- by RICVBA" comment
'Set the active layer to the bend line layer for newly created lines ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer) 'Enumerate the selection set and shorten the exiting bend line 'Next we create a new bend line existing at the endpoint. Dim x As Double Dim y As Double Dim z As Double Dim StartMovingPoint(0 To 2) As Double '<---- by RICVBA Dim EndMovingPoint(0 To 2) As Double '<---- by RICVBA 'Dim MP(0 To 2) As Double 'Dim EP(0 To 2) As Double For Each L In SelSet x = L.Delta(0) / 2 y = L.Delta(1) / 2 z = L.Delta(2) / 2 EndMovingPoint(0) = (L.StartPoint(0) + L.EndPoint(0)) / 2 '<---- by RICVBA EndMovingPoint(1) = (L.StartPoint(1) + L.EndPoint(1)) / 2 '<---- by RICVBA EndMovingPoint(2) = (L.StartPoint(2) + L.EndPoint(2)) / 2 '<---- by RICVBA 'EP(0) = L.EndPoint(0): EP(1) = L.EndPoint(1) 'MP(0) = L.Delta(0) / 2: MP(1) = L.Delta(1) / 2 L.EndPoint = ThisDrawing.Utility.PolarPoint(L.StartPoint, L.Angle, Remnant) L.Layer = "MARK" StartMovingPoint(0) = (L.StartPoint(0) + L.EndPoint(0)) / 2 '<---- by RICVBA StartMovingPoint(1) = (L.StartPoint(1) + L.EndPoint(1)) / 2 '<---- by RICVBA StartMovingPoint(2) = (L.StartPoint(2) + L.EndPoint(2)) / 2 '<---- by RICVBA L.Move StartMovingPoint, EndMovingPoint '<---- by RICVBA
'L.EndPoint(0) = x: L.EndPoint(1) = y 'MP = L.Length / 2: 'L.Move EP, MP 'If L.StartPoint(0) = L.EndPoint(0) The 'LA = L.Angle 'EP(0) = L.EndPoint(0) 'SP(0) = L.StartPoint(0) 'LN = L.Length 'End If Next
I must point out that this does exactly what announced, while it's conceptually different from what you recorded in your video, where you're moving "mark" lines with reference to xLines that you draw using "border" lines centerlines. It's all the same if "cut"lines always are orthogonal to border lines and centered with respect to them.
you're welcome
hope you don't mind if I hereafter propose your code with what I'd consider some coding optimization
they're not necessary for this very job, but they may help you if you go with more complex VBA programs
Option Explicit '<--- by RICVBA - comment: I'd always use this option, to have tha maximum control over what I write Public Sub TrimBendLines() Dim LayerName As String '<--- by RICVBA - comment: consequence of "Option Explicit" Dim MARK As AcadLayer '<--- by RICVBA - comment: consequence of "Option Explicit" '-------------------------------------------ADD MARK LAYER---------------------------------------------?------- LayerName = "MARK" Set MARK = ThisDrawing.Layers.Add(LayerName) MARK.color = acRed '---------------------------------------BEND UP LINES---------------------------------------------?------- 'Change the following line to match your layer names Dim BendLineLayer As String: BendLineLayer = "IV_BEND" 'Change the following line to adjust how much line is left Dim Remnant As Double: Remnant = 0.5 'Variable to hold PI for angle calculations Const Pi As Double = 3.14159265358979 'Need to declare a selection set in AutoCAD to store bend lines for trimming Dim SelSet As AcadSelectionSet On Error Resume Next ThisDrawing.SelectionSets.Add ("BendLines") On Error GoTo 0 '<--- by RICVBA - comment: I'd place this here, just to leave as few "error free " code lines as you need them Set SelSet = ThisDrawing.SelectionSets.Item("BendLines") SelSet.Clear Dim FilterType(1) As Integer Dim FilterData(1) As Variant 'Create filters so that we only select line objects on the bend line layer FilterType(0) = 8: FilterData(0) = BendLineLayer FilterType(1) = 0: FilterData(1) = "Line" 'Select the objects (if any exist) SelSet.Select acSelectionSetAll, , , FilterType, FilterData '<--- by RICVBA - comment: for maximum code control it's better to avoid GOTO stataments and use if-then-else ones instead ''If no bend lines are found then exit the sub routine <--- by RICVBA - comment: what follows points to "if no bend lines are found then process "BendDown" stataments 'If SelSet.Count = 0 Then 'GoTo BendDown ''Exit Sub 'End If If SelSet.Count > 0 Then '<--- by RICVBA - comment: this way you avoid GOTO 'Set the active layer to the bend line layer for newly created lines ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer) 'Enumerate the selection set and shorten the exiting bend line 'Next we create a new bend line existing at the endpoint. Dim L As AcadLine For Each L In SelSet Dim EndPoint As Variant: EndPoint = L.EndPoint L.EndPoint = ThisDrawing.Utility.PolarPoint(L.StartPoint, L.Angle, Remnant) Call ThisDrawing.ModelSpace.AddLine(ThisDrawing.Utility.PolarPoint(EndPoint, L.Angle - Pi, Remnant), EndPoint) L.Layer = "MARK" 'L.TrueColor = acBlue Next '-------------------------------------------------?CONVERT NEW LINES TO MARK LAYER ---------------------------------------- BendLineLayer = "IV_BEND" On Error Resume Next ThisDrawing.SelectionSets.Add ("BendLines") Set SelSet = ThisDrawing.SelectionSets.Item("BendLines") SelSet.Clear On Error GoTo 0 'Create filters so that we only select line objects on the bend line layer FilterType(0) = 8: FilterData(0) = BendLineLayer FilterType(1) = 0: FilterData(1) = "Line" 'Select the objects (if any exist) SelSet.Select acSelectionSetAll, , , FilterType, FilterData 'If no bend lines are found then exit the sub routine ' If SelSet.Count = 0 Then ' Exit Sub ' End If If SelSet.Count = 0 Then Exit Sub '<--- by RICVBA - comment: a one line statement is possible, and more readable 'Set the active layer to the bend line layer for newly created lines ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer) For Each L In SelSet L.Layer = "MARK" Next End If '<--- by RICVBA '-------------------------------------------------?-------BEND DOWN LINES---------------------------------------- 'BendDown: '<--- by RICVBA - comment: absent GOTo you don't need it anymore 'Change the following line to match your layer names BendLineLayer = "IV_BEND_DOWN" 'Need to declare a selection set in AutoCAD to store bend lines for trimming On Error Resume Next ThisDrawing.SelectionSets.Add ("BendLines") On Error GoTo 0 '<--- by RICVBA - comment: see comment above about the same issue Set SelSet = ThisDrawing.SelectionSets.Item("BendLines") SelSet.Clear 'Create filters so that we only select line objects on the bend line layer FilterType(0) = 8: FilterData(0) = BendLineLayer FilterType(1) = 0: FilterData(1) = "Line" 'Select the objects (if any exist) SelSet.Select acSelectionSetAll, , , FilterType, FilterData 'If no bend lines are found then exit the sub routine 'If SelSet.Count = 0 Then 'Exit Sub 'End If If SelSet.Count = 0 Then Exit Sub '<--- by RICVBA - comment: a one line statement is possible, and more readable 'Set the active layer to the bend line layer for newly created lines ThisDrawing.ActiveLayer = ThisDrawing.Layers.Item(BendLineLayer) 'Enumerate the selection set and shorten the exiting bend line 'Next we create a new bend line existing at the endpoint. 'Dim x As Double '<--- by RICVBA - comment: you don't need this variable (see a few lines below) -> you don't need to declare it 'Dim y As Double '<--- by RICVBA - comment: you don't need this variable (see a few lines below) -> you don't need to declare it 'Dim z As Double '<--- by RICVBA - comment: you don't need this variable (see a few lines below) -> you don't need to declare it Dim StartMovingPoint(0 To 2) As Double '<--- by RICVBA Dim EndMovingPoint(0 To 2) As Double '<--- by RICVBA 'Dim MP(0 To 2) As Double 'Dim EP(0 To 2) As Double For Each L In SelSet ' x = L.Delta(0) / 2 '<--- by RICVBA - comment: you don't need this variable ' y = L.Delta(1) / 2 '<--- by RICVBA - comment: you don't need this variable ' z = L.Delta(2) / 2 '<--- by RICVBA - comment: you don't need this variable Call setMidPoint(L, EndMovingPoint()) '<--- by RICVBA - comment: use e sub to avoid repeating the same code (see a few lines below) more than once ' EndMovingPoint(0) = (L.StartPoint(0) + L.EndPoint(0)) / 2 '<--- by RICVBA ' EndMovingPoint(1) = (L.StartPoint(1) + L.EndPoint(1)) / 2 '<--- by RICVBA ' EndMovingPoint(2) = (L.StartPoint(2) + L.EndPoint(2)) / 2 '<--- by RICVBA 'EP(0) = L.EndPoint(0): EP(1) = L.EndPoint(1) 'MP(0) = L.Delta(0) / 2: MP(1) = L.Delta(1) / 2 L.EndPoint = ThisDrawing.Utility.PolarPoint(L.StartPoint, L.Angle, Remnant) L.Layer = "MARK" Call setMidPoint(L, StartMovingPoint()) '<--- by RICVBA - comment: use e sub to avoid repeating the same code more than once ' StartMovingPoint(0) = (L.StartPoint(0) + L.EndPoint(0)) / 2 '<--- by RICVBA ' StartMovingPoint(1) = (L.StartPoint(1) + L.EndPoint(1)) / 2 '<--- by RICVBA ' StartMovingPoint(2) = (L.StartPoint(2) + L.EndPoint(2)) / 2 '<--- by RICVBA L.Move StartMovingPoint, EndMovingPoint '<--- by RICVBA 'L.EndPoint(0) = x: L.EndPoint(1) = y 'MP = L.Length / 2: 'L.Move EP, MP 'If L.StartPoint(0) = L.EndPoint(0) The 'LA = L.Angle 'EP(0) = L.EndPoint(0) 'SP(0) = L.StartPoint(0) 'LN = L.Length 'End If Next End Sub Sub setMidPoint(L As AcadLine, MidPoint() As Double) '<--- by RICVBA MidPoint(0) = (L.StartPoint(0) + L.EndPoint(0)) / 2 MidPoint(1) = (L.StartPoint(1) + L.EndPoint(1)) / 2 MidPoint(2) = (L.StartPoint(2) + L.EndPoint(2)) / 2 End Sub
Finally, once removing all commented lines (and my comments too!) the code would look much more friendly
bye