Assembly macro multiple folders

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