Hello,
I have a macro to make DXF and PDF files from my opened assembly, works perfectly. But I have one problem.
My assembly constist of components from different folders, so it makes multiple PDF and DXF folders in the same location of the parts.
Is it possible to make just one DXF/PDF folder in the same folder as the location of the openend assembly where all my files will be exported to?
Props to Simon for this macro!!
'***********************************************************************
'* OK, this isn't the tidiest bit of code I've ever written *
'* & it's mostly cobbled together from examples in the Solidworks API *
'* Documentation - but it works OK! *
'* To use, you need to have an assembly open. It will find all the *
'* linked drawings (must have same name as model) and export to PDF *
'* It then finds all the SheetMetal parts, exports them to DXF and *
'* builds a BOM for them - to be sent to your favorite Laser Cutter *
'* *
'* Mail me at simon1@psi-design.co.uk if you want to tell be how cool *
'* you think it is! (or tell me if you've found a problem!) *
'***********************************************************************
Option Explicit
Dim swExportPDFData As SldWorks.ExportPdfData
Sub ShowAllOpenFiles()
Dim swDoc As SldWorks.ModelDoc2
Dim swAllDocs As EnumDocuments2
Dim FirstDoc As SldWorks.ModelDoc2
Dim NumDocsReturned As Long
Dim DocCount As Long
Dim swApp As SldWorks.SldWorks
Dim bDocWasVisible As Boolean
Dim OpenWarnings As Long
Dim OpenErrors As Long
Dim DwgPath As String
Dim myDwgDoc As SldWorks.ModelDoc2
Dim drwPathName As String
Dim pdfPathName As String
Dim pdfFolderName As String
Dim lErrors As Long
Dim lWarnings As Long
Dim sMessage As String
Dim nExported As Integer
Dim fso As Scripting.FileSystemObject
Dim FeatureDefinition As SheetMetalFeatureData
Dim prtPath As String
Dim featureMgr As Feature
Dim SheetMetalFolder As Folder
Set swApp = Application.SldWorks
Set swAllDocs = swApp.EnumDocuments2
Set FirstDoc = swApp.ActiveDoc
On Error Resume Next
If FirstDoc.GetType <> swDocASSEMBLY Then
MsgBox "I'm afraid this macro only works when run" & vbCr & "from within a top level assembly!"
Exit Sub
End If
nExported = 0
DocCount = 0
swAllDocs.Reset
swAllDocs.Next 1, swDoc, NumDocsReturned
While NumDocsReturned <> 0
bDocWasVisible = swDoc.Visible
'swApp.ActivateDoc swDoc.GetPathName'
DwgPath = swDoc.GetPathName
If (LCase(Right(DwgPath, 3)) = "prt") Then
'Open model
'Export any sheet metal parts as DXF Flat patterns
prtPath = Left(DwgPath, Len(DwgPath) - 3) & "prt"
Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocPART, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
Set featureMgr = myDwgDoc.FeatureManager
Set SheetMetalFolder = featureMgr.GetSheetMetalFolder
End If
If (LCase(Right(DwgPath, 3)) <> "drw") And (DwgPath <> "") Then
DwgPath = Left(DwgPath, Len(DwgPath) - 3) & "drw"
Set myDwgDoc = swApp.OpenDoc6(DwgPath, swDocDRAWING, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
If Not myDwgDoc Is Nothing Then
swApp.ActivateDoc myDwgDoc.GetPathName
'Extract the root folder for assembly and create a PDF folder inside
pdfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "PDF Drawings\"
Set fso = CreateObject("Scripting.FileSystemObject")
If (Not fso.FolderExists(pdfFolderName)) Then
MkDir pdfFolderName
End If
Dim Part As ModelDoc2
Set Part = swApp.ActiveDoc()
'You have a drawing active
drwPathName = Part.GetPathName()
If ("" = drwPathName) Then
' GetPathName() was empty
MsgBox ("This drawing has not been saved yet")
Exit Sub
End If
pdfPathName = fso.BuildPath(pdfFolderName, fso.GetBaseName(drwPathName) & ".pdf")
Set swExportPDFData = swApp.GetExportFileData(1)
swExportPDFData.ViewPdfAfterSaving = False
Part.Extension.SaveAs pdfPathName, 0, 0, swExportPDFData, lErrors, lWarnings
swApp.QuitDoc (Part.GetTitle)
Set myDwgDoc = Nothing
nExported = nExported + 1
End If
End If
swAllDocs.Next 1, swDoc, NumDocsReturned
DocCount = DocCount + 1
Wend
sMessage = "PDF/DXF/BOM Export " & vbCr & vbCr
If nExported = 0 Then
sMessage = sMessage & "No Drawings found to export to PDF" & vbCr & vbCr
Else
sMessage = sMessage & CStr(nExported) & " PDF's saved to: " & vbCr & pdfFolderName & vbCr & vbCr
End If
swApp.ActivateDoc FirstDoc.GetPathName
'Generate & save the BOM for sheet metal parts
sMessage = sMessage & ExportSheetBOM() 'Returns info on DXF's exported if any
MsgBox sMessage
End Sub
Function ExportSheetBOM() As String
'Counts the instances of sheet metal parts in Assembly (and su=assemblies)
Dim swApp As SldWorks.SldWorks
Dim swDoc As SldWorks.ModelDoc2
Dim swMyDoc As SldWorks.ModelDoc2
Dim swAssy As SldWorks.AssemblyDoc
Dim swSelMgr As SldWorks.SelectionMgr
Dim swSelComp As SldWorks.Component2
Dim CurSelCount As Long
Dim GeneralSelObj As Object
Dim AllComponents As Variant
Dim i As Long
Dim TopLevOnly As Boolean
Dim SupCount As Long
Dim LwtCount As Long
Dim ResCount As Long
Dim sMsg As String
Dim CompPath As String
Dim EachComp As SldWorks.Component2
'Bill of Materials
Dim sPartNames() As String
Dim nPartQty() As Integer
Dim sPartMaterial() As String
Dim sPartThickness() As String
Dim nCnt As Integer
Dim FeatureDefinition As SheetMetalFeatureData
Dim nThickness As Double
Dim sMatDB As String
Dim OpenWarnings As Long
Dim OpenErrors As Long
Dim mFSO As Scripting.FileSystemObject
Dim prtPath As String
Dim featureMgr As Feature
Dim firstfeature As Feature
Dim SheetMetalFolder As Folder
Dim nextfeature As Feature
Dim Thickness As Double
Dim bRebuild As Boolean
Dim bRet As Boolean
Dim sBOM As String
Dim ComponentRoot As String
Dim ComponentName As String
Dim Material As String
Dim DwgPath As String
Dim EachName As String
Dim dxfFolderName As String
Dim dxfFileName As String
Dim NewFilePath As String
Dim fso As Scripting.FileSystemObject
Dim nDXFExported As Integer
Dim bFound As Boolean
Dim objTextStream As Object
'Dim swSelMgr As SldWorks.SelectionMgr
Dim swView As SldWorks.View
Dim swDrawModel As SldWorks.ModelDoc2
Dim myDwgDoc As SldWorks.ModelDoc2
Dim pdfFolderName As String
Dim drwPathName As String
Dim pdfPathName As String
Dim lErrors As Long
Dim lWarnings As Long
Dim nExported As Integer
Dim fsoForWriting As Variant
Dim sDXFPath As String
On Error Resume Next
ReDim Preserve sPartNames(0)
ReDim Preserve nPartQty(0)
ReDim Preserve sPartMaterial(0)
ReDim Preserve sPartThickness(0)
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set swAssy = swDoc
Set swSelMgr = swDoc.SelectionManager
CompPath = swDoc.GetPathName
CompPath = swSelMgr.GetPathName
'Find component name.
ComponentRoot = Left(CompPath, InStrRev(CompPath, "\"))
ComponentName = Mid(CompPath, InStrRev(CompPath, "\") + 1)
ComponentName = Left(ComponentName, InStrRev(ComponentName, ".") - 1)
TopLevOnly = False
AllComponents = swAssy.GetComponents(TopLevOnly)
SupCount = 0
ResCount = 0
LwtCount = 0
For i = 0 To UBound(AllComponents)
Set EachComp = AllComponents(i)
Set firstfeature = EachComp.firstfeature
Set nextfeature = firstfeature.GetNextFeature
Material = "Not Set"
Do While (Not (firstfeature Is Nothing))
If nextfeature.GetTypeName = "SheetMetal" Then
'This part has sheet metal
Set FeatureDefinition = nextfeature.GetDefinition
Set swMyDoc = swApp.OpenDoc6(EachComp.GetPathName, swDocPART, swOpenDocOptions_Silent, "", OpenErrors, OpenWarnings)
DwgPath = swMyDoc.GetPathName
EachName = Mid(EachComp.GetPathName, InStrRev(EachComp.GetPathName, "\") + 1)
EachName = Left(EachName, InStrRev(EachName, ".") - 1)
bRebuild = swMyDoc.ForceRebuild3(False)
dxfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "DXF Flat Patterns\"
dxfFileName = Mid(DwgPath, InStrRev(DwgPath, "\") + 1)
'Loose Extension
dxfFileName = Left(dxfFileName, InStrRev(dxfFileName, ".") - 1)
NewFilePath = dxfFolderName & dxfFileName & ".DXF"
'Now create path
Set fso = CreateObject("Scripting.FileSystemObject")
If (Not fso.FolderExists(dxfFolderName)) Then
MkDir dxfFolderName
End If
Set fso = Nothing 'destroy object
'Export Flat Pattern
bRet = swMyDoc.ExportFlatPatternView(NewFilePath, 1)
nDXFExported = nDXFExported + 1
Material = swMyDoc.MaterialIdName
If InStr(Material, "SOLIDWORKS Materials|") > 0 Then
Material = Mid(Material, InStr(Material, "SOLIDWORKS Materials|") + 21)
End If
If InStr(Material, "|") > 0 Then
Material = Left(Material, InStr(Material, "|") - 1)
End If
Thickness = FeatureDefinition.Thickness * 1000 'put in to mm
'Look through array for component name
bFound = False
For nCnt = 1 To UBound(sPartNames)
If UCase(sPartNames(nCnt)) = UCase(EachName) Then
'Inc qty
nPartQty(nCnt) = nPartQty(nCnt) + 1
bFound = True
End If
Next
If Not bFound Then
ReDim Preserve sPartNames(UBound(sPartNames) + 1)
ReDim Preserve nPartQty(UBound(sPartNames) + 1)
ReDim Preserve sPartMaterial(UBound(sPartNames) + 1)
ReDim Preserve sPartThickness(UBound(sPartNames) + 1)
sPartNames(UBound(sPartNames)) = EachName
nPartQty(UBound(sPartNames)) = 1
sPartThickness(UBound(sPartNames)) = Thickness
sPartMaterial(UBound(sPartNames)) = Material
End If
swApp.QuitDoc (swMyDoc.GetTitle)
End If
Set firstfeature = nextfeature.GetNextFeature
If (Not (firstfeature Is Nothing)) Then
'Debug.Print nextfeature.GetTypeName
Set nextfeature = firstfeature
End If
Loop
Next i
ExportSheetBOM = ""
If UBound(sPartNames) > 0 Then
'We should now have an array we can save as a CSV
'Finally Export a CSV of the BOM
'Extract the root folder for assembly and create a DXF folder inside
sDXFPath = Left(swDoc.GetPathName, InStrRev(swDoc.GetPathName, "\")) & "DXF Flat Patterns\"
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
If (objFSO.FileExists(sDXFPath & "BOM Sheet Metal.csv")) Then
objFSO.DeleteFile sDXFPath & "BOM Sheet Metal.csv", True
End If
'Open the text file
Set objTextStream = objFSO.CreateTextFile(sDXFPath & ComponentName & "-Sheet BOM.csv", fsoForWriting, True)
'Write a header line to the file
objTextStream.WriteLine "PART NAME, MATERIAL, THICKNESS(mm), QUANTITY"
'Field headings for Laser Lee
'objTextStream.WriteLine "PART NAME,MATERIAL,GRADE,THICKNESS(mm),GRAIN,OVERWRITE,QUANTITY,NOTES,NOT FOR MANUFACTURE"
For nCnt = 1 To UBound(sPartNames())
'objTextStream.WriteLine sPartNames(nCnt) & "," & sPartMaterial(nCnt) & "," & sPartThickness(nCnt) & "," & nPartQty(nCnt)
'Special including Gonfiguration
objTextStream.WriteLine sPartNames(nCnt) & "," & sPartMaterial(nCnt) & "," & sPartThickness(nCnt) & "," & nPartQty(nCnt)
'Fields for Laser Lee
'objTextStream.WriteLine sPartNames(nCnt) & "," & sPartMaterial(nCnt) & "," & sPartMaterial(nCnt) & "," & sPartThickness(nCnt) & "," & "N," & "1," & nPartQty(nCnt) & ",- ,0 "
Next
'Close the file and clean up
objTextStream.Close
Set objTextStream = Nothing
Set objFSO = Nothing
If nDXFExported > 0 Then
ExportSheetBOM = CStr(nDXFExported) & " DXF's + BOM saved to: " & vbCr & sDXFPath & "BOM Sheet Metal.csv" & vbCr & vbCr
Else
ExportSheetBOM = "No DXF's Exported" & vbCr & vbCr
End If
End If
End Function
SolidworksApi macros