I’m using the attached macro to generate DXFs from a multibody part in SolidWorks. It saves each DXF with a specific naming format that pulls info from both the part's custom properties and the cut list.
The DXF filename ends up looking like:
MK1-10382-010-01_5MM_MSPL_1OFF.DXF
That’s made up of: Project No + Number (from the custom properties) and THICKNESS + MATERIAL + QTY (from the cut list properties of the selected body).
It works by
- I select the face I want to use for the DXF view.
- Run the macro.
- It creates a DXF using that face and then hides the body.
The issue: In the multibody part, there might be 5 identical bodies. Right now, the macro only hides the one I selected. I’d like to improve it so that after exporting the DXF, it hides all bodies that are the same as the one selected (based on cut list grouping).
Has anyone tackled something similar or know a way to scan and hide all identical cut list bodies?
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim swFace As SldWorks.Face2
Dim swBody As SldWorks.Body2
Dim feat As SldWorks.Feature
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Dim SelMgr As SldWorks.SelectionMgr
Dim BodyFolder As SldWorks.BodyFolder
Dim CutListBdy As Body2
Dim strValue(14) As String
Dim WorkFace As Face2
Dim WorkSurface As Surface
Dim savepathdxf As String
Dim varAlignment As Variant
Dim dataAlignment(11) As Double
Dim seltype As Integer
Dim i As Integer
Dim isThisAPlane As Boolean
Dim vBodies As Variant
Dim j As Integer
Dim wasResolved As Boolean
Dim itemnumber As String
Dim config As SldWorks.Configuration
Dim swCustPropMgr1 As SldWorks.CustomPropertyManager
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim intLastRow As Long
Dim FilePath As String
Dim MyRange As Range
Dim DateCreated As Variant
Dim FilePath2 As String
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
'Don't run if no part is loaded
If Part Is Nothing Then
swApp.SendMsgToUser "There is no part loaded."
GoTo cleanupandquitnopart
End If
'did the user have the open file saved
If Part.GetPathName = "" Then
'user does not have open file saved
swApp.SendMsgToUser "Please save the file before running this script."
GoTo cleanupandquit
End If
Set swCustPropMgr = Part.Extension.CustomPropertyManager("")
'Get Custom Property Project
swCustPropMgr.Get5 "Project", False, strValue(8), strValue(0), wasResolved
'Get Custom Property Number
swCustPropMgr.Get5 "Number", False, strValue(9), strValue(1), wasResolved
'Get Custom MK Number
Set config = Part.GetActiveConfiguration
Set swCustPropMgr1 = config.CustomPropertyManager
swCustPropMgr1.Get5 "Config No", False, strValue(11), strValue(10), wasResolved
'did the user pre-select a face?
Set SelMgr = Part.SelectionManager
If SelMgr.GetSelectedObjectCount2(1) <> 1 Then
seltype = SelMgr.GetSelectedObjectType3(1, 0)
If seltype <> SwConst.swSelFACES Then
'user did not preselect one face
swApp.SendMsgToUser "Please select a (one) 2D face before running this command."
GoTo cleanupandquit
Else
Set swFace = SelMgr.GetSelectedObject6(1, -1)
Set swBody = swFace.GetBody
Set feat = Part.FirstFeature
While Not feat Is Nothing
If feat.GetTypeName = "CutListFolder" Or feat.GetTypeName = "SubWeldFolder" Then
Set BodyFolder = feat.GetSpecificFeature2
vBodies = BodyFolder.GetBodies
If Not IsEmpty(vBodies) Then
For j = LBound(vBodies) To UBound(vBodies)
Set CutListBdy = vBodies(j)
If CutListBdy.Name = swBody.Name Then
Set swCustPropMgr = feat.CustomPropertyManager
'Get Custom Property THICKNESS from cut list
swCustPropMgr.Get5 "THICKNESS", False, strValue(5), strValue(2), wasResolved
'Get Custom Property MATERIAL from cut list
swCustPropMgr.Get5 "MATERIAL", False, strValue(6), strValue(3), wasResolved
'Get Custom Property QUANTITY from cut list
swCustPropMgr.Get5 "QUANTITY", False, strValue(7), strValue(4), wasResolved
'Get Custom Property LENGTH from cut list
swCustPropMgr.Get5 "LENGTH", False, strValue(8), strValue(5), wasResolved
'Get Custom Property SECTION from cut list
swCustPropMgr.Get5 "SECTION", False, strValue(9), strValue(6), wasResolved
'Part.FeatureManager.HideBodies
itemnumber = feat.Name
End If
Next j
End If
End If
Set feat = feat.GetNextFeature()
Wend
End If
End If
'Determine if the selected face is a true 2D plane... exit if not
isThisAPlane = False 'initalize variable to false
'make sure that what is selected is a face... exit if not
If SelMgr.GetSelectedObjectType3(1, -1) <> 2 Then
swApp.SendMsgToUser "Item selected is not a face. You must select a (one) complete 2D Face to export."
GoTo cleanupandquit
End If
Set WorkFace = SelMgr.GetSelectedObject5(1)
Set WorkSurface = WorkFace.GetSurface
isThisAPlane = WorkSurface.IsPlane
If isThisAPlane = False Then
swApp.SendMsgToUser "The face selected is not 2D. Please select a (one) 2D face before running this command."
GoTo cleanupandquit
End If
'Save a DXF
dataAlignment(0) = 0#
dataAlignment(1) = 0#
dataAlignment(2) = 0#
dataAlignment(3) = 1#
dataAlignment(4) = 0#
dataAlignment(5) = 0#
dataAlignment(6) = 0#
dataAlignment(7) = 1#
dataAlignment(8) = 0#
dataAlignment(9) = 0#
dataAlignment(10) = 0#
dataAlignment(11) = 1#
varAlignment = dataAlignment
'Clean off the file name so that we can add our desired name
savepathdxf = "C:\Working\1. Profiles & Images\"
'File name in the standard of 70556-061-3_3MM_MILD STEEL PL_2OFF_REVA.DXF (Item 3 was selected)
savepathdxf = savepathdxf & strValue(10) & "-" & strValue(0) & "-" & strValue(1) & "-" & itemnumber & "_" & strValue(2) & "MM_" & strValue(3) & " PL_" & strValue(4) & "OFF_REVA" & ".DXF"
'save Excel File and dxf file names in the Profiles & Images folder on local C drive
'Save dxf File Name in excel
FilePath = "C:\Working\1. Profiles & Images\" & strValue(0) & "-DXF FILE NAMES.xlsx"
DateCreated = Date
If Dir(FilePath) <> "" Then
Workbooks.Open FilePath
With Workbooks
intLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Cells(intLastRow + 1, 1).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1) & "-" & itemnumber & "_" & strValue(2) & "MM_" & strValue(3) & " PL_" & strValue(4) & "OFF_REVA" & ".DXF"
Cells(intLastRow + 1, 4).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1)
Cells(intLastRow + 1, 5).Value = itemnumber
Cells(intLastRow + 1, 6).Value = DateCreated
Cells(intLastRow + 1, 8).Value = strValue(5)
Cells(intLastRow + 1, 9).Value = strValue(6)
Cells(intLastRow + 1, 10).Value = strValue(2)
Cells(intLastRow + 1, 11).Value = strValue(4)
Cells(intLastRow + 1, 12).Value = strValue(3)
Cells(intLastRow + 1, 14).Value = strValue(1)
End With
'DELETE DUPLICATES
Set MyRange = ActiveSheet.Range("A1:N1" & intLastRow)
MyRange.RemoveDuplicates Columns:=1, Header:=xlYes
'SORT
Dim oneRange As Range
Dim aCellA As Range
Dim aCellB As Range
Set oneRange = Range("A1:N1000")
Set aCellA = Range("E1")
Set aCellB = Range("N1")
oneRange.Sort Key1:=aCellA, Order1:=xlAscending, Header:=xlYes
oneRange.Sort Key1:=aCellB, Order1:=xlAscending, Header:=xlYes
ActiveWorkbook.Save
Workbooks.Close
ElseIf Dir(FilePath) = "" Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
xlWorkbook.SaveAs FilePath
'This is where the excel file is saved.
With xlWorkbook.Worksheets(1)
.Cells(1, 1).Value = "DXF FILE NAME"
.Cells(1, 2).Value = "TRANSMISSION"
.Cells(1, 4).Value = "PART #"
.Cells(1, 5).Value = "ITEM #"
.Cells(1, 6).Value = "DATE CREATED"
.Cells(1, 8).Value = "LENGTH"
.Cells(1, 9).Value = "SECTION"
.Cells(1, 10).Value = "THICKNESS"
.Cells(1, 11).Value = "QTY"
.Cells(1, 12).Value = "MATERIAL"
.Cells(1, 14).Value = "NUMBER"
.Cells(2, 1).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1) & "-" & itemnumber & "_" & strValue(2) & "MM_" & strValue(3) & " PL_" & strValue(4) & "OFF_REVA" & ".DXF"
.Cells(2, 4).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1)
.Cells(2, 5).Value = itemnumber
.Cells(2, 6).Value = DateCreated
.Cells(2, 8).Value = strValue(5)
.Cells(2, 9).Value = strValue(6)
.Cells(2, 10).Value = strValue(2)
.Cells(2, 11).Value = strValue(4)
.Cells(2, 12).Value = strValue(3)
.Cells(2, 14).Value = strValue(1)
End With
xlWorkbook.Save
xlWorkbook.Close
xlApp.Quit
End If
'save Excel File and dxf file names in running folder on z-drive
'Save dxf File Name in excel
FilePath2 = "Z:\1 Current Work\1. Projects\1. DXF Running Files\" & strValue(0) & "-DXF RUNNING FILES.xlsx"
DateCreated = Date
If Dir(FilePath2) <> "" Then
Workbooks.Open FilePath2
With Workbooks
intLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Cells(intLastRow + 1, 1).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1) & "-" & itemnumber & "_" & strValue(2) & "MM_" & strValue(3) & " PL_" & strValue(4) & "OFF_REVA" & ".DXF"
Cells(intLastRow + 1, 4).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1)
Cells(intLastRow + 1, 5).Value = itemnumber
Cells(intLastRow + 1, 6).Value = DateCreated
Cells(intLastRow + 1, 8).Value = strValue(5)
Cells(intLastRow + 1, 9).Value = strValue(6)
Cells(intLastRow + 1, 10).Value = strValue(2)
Cells(intLastRow + 1, 11).Value = strValue(4)
Cells(intLastRow + 1, 12).Value = strValue(3)
Cells(intLastRow + 1, 14).Value = strValue(1)
End With
'DELETE DUPLICATES
Set MyRange = ActiveSheet.Range("A1:N1" & intLastRow)
MyRange.RemoveDuplicates Columns:=1, Header:=xlYes
'SORT
Set oneRange = Range("A1:N1000")
Set aCellA = Range("E1")
Set aCellB = Range("N1")
oneRange.Sort Key1:=aCellA, Order1:=xlAscending, Header:=xlYes
oneRange.Sort Key1:=aCellB, Order1:=xlAscending, Header:=xlYes
ActiveWorkbook.Save
Workbooks.Close
ElseIf Dir(FilePath2) = "" Then
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
xlWorkbook.SaveAs FilePath2
With xlWorkbook.Worksheets(1)
.Cells(1, 1).Value = "DXF FILE NAME"
.Cells(1, 2).Value = "TRANSMISSION"
.Cells(1, 4).Value = "PART #"
.Cells(1, 5).Value = "ITEM #"
.Cells(1, 6).Value = "DATE CREATED"
.Cells(1, 8).Value = "LENGTH"
.Cells(1, 9).Value = "SECTION"
.Cells(1, 10).Value = "THICKNESS"
.Cells(1, 11).Value = "QTY"
.Cells(1, 12).Value = "MATERIAL"
.Cells(1, 14).Value = "NUMBER"
.Cells(2, 1).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1) & "-" & itemnumber & "_" & strValue(2) & "MM_" & strValue(3) & " PL_" & strValue(4) & "OFF_REVA" & ".DXF"
.Cells(2, 4).Value = strValue(10) & "-" & strValue(0) & "-" & strValue(1)
.Cells(2, 5).Value = itemnumber
.Cells(2, 6).Value = DateCreated
.Cells(2, 8).Value = strValue(5)
.Cells(2, 9).Value = strValue(6)
.Cells(2, 10).Value = strValue(2)
.Cells(2, 11).Value = strValue(4)
.Cells(2, 12).Value = strValue(3)
.Cells(2, 14).Value = strValue(1)
End With
xlWorkbook.Save
xlWorkbook.Close
xlApp.Quit
End If
'Export selected face to a DXF
Part.ExportToDWG2 savepathdxf, FilePath, swExportToDWG_ExportSelectedFacesOrLoops, True, varAlignment, False, False, 0, Null
Part.FeatureManager.HideBodies
Part.ClearSelection2 False
GoTo cleanupandquit
'#############################################################
'DRAWING (this macro started while a drawing was active )
'#############################################################
GoTo cleanupandquit
cleanupandquit:
Part.DeleteConfiguration (Part.GetActiveConfiguration.Name & "SM-FLAT-PATTERN")
Set swApp = Nothing
Set Part = Nothing
Set SelMgr = Nothing
Set xlWorkbook = Nothing
Set xlApp = Nothing
cleanupandquitnopart: 'only called if no part is loaded
Set swApp = Nothing
Set Part = Nothing
Set SelMgr = Nothing
End Sub
