3 Replies Latest reply on Feb 24, 2017 7:14 PM by Raghvendra Bhargava

    Assembly macro multiple folders

    Nick Makkinga

      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

        • Re: Assembly macro multiple folders
          Raghvendra Bhargava

          Replace:

              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

           

          With:

              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

          Dim PDFPath As String

          PDFPath = Left(FirstDoc.GetPathName, InStrRev(FirstDoc.GetPathName, "\"))

           

          Replace:

             'Extract the root folder for assembly and create a PDF folder inside

              pdfFolderName = Left(DwgPath, InStrRev(DwgPath, "\")) & "PDF Drawings\"

           

          With:

             'Extract the root folder for assembly and create a PDF folder inside

              pdfFolderName = PDFPath & "PDF Drawings\"

           

           

          I guess it should work!!

            • Re: Assembly macro multiple folders
              Nick Makkinga

              Thanks Raghvendra,

               

              Works like a charm! Is it possible to do the same for the DXF folders that are created?

                • Re: Assembly macro multiple folders
                  Raghvendra Bhargava

                  To Export BOM:

                   

                  Replace:

                      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

                  Dim PDFPath As String

                  PDFPath = Left(FirstDoc.GetPathName, InStrRev(FirstDoc.GetPathName, "\"))

                   

                  With:

                      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

                  Dim PDFPath As String

                  PDFPath = Left(FirstDoc.GetPathName, InStrRev(FirstDoc.GetPathName, "\"))

                   

                  Dim swFeat As Feature

                  Set swFeat = FirstDoc.FirstFeature

                   

                  Do While Not swFeat Is Nothing

                      Dim SubFeat As Feature

                      Set SubFeat = swFeat.GetFirstSubFeature

                         

                      Do While Not SubFeat Is Nothing

                          If "BomFeat" = SubFeat.GetTypeName Then

                         

                              Dim AssmPath As String

                              AssmPath = Left(FirstDoc.GetPathName, InStrRev(FirstDoc.GetPathName, "\"))

                             

                              'Path to Export BOM as '.xls'

                              Dim BOMFolderName As String

                              BOMFolderName = Left(AssmPath, InStrRev(AssmPath, "\")) & "BOM\"

                             

                              Dim fso As Object

                              Set fso = CreateObject("Scripting.FileSystemObject")

                             

                              If (Not fso.FolderExists(BOMFolderName)) Then

                                  MkDir BOMFolderName

                              End If

                   

                              Dim BomFeat As BomFeature

                              Set BomFeat = SubFeat.GetSpecificFeature2

                             

                              Dim vTblBOM As Variant

                              vTblBOM = BomFeat.GetTableAnnotations

                             

                              If IsEmpty(vTblBOM) = False Then

                                  Dim BomTblAnn As BomTableAnnotation

                                  Set BomTblAnn = vTblBOM(0)

                                 

                                  Dim TblAnn As TableAnnotation

                                  Set TblAnn = BomTblAnn

                                 

                                  boolstatus = TblAnn.SaveAsText(BOMFolderName & FirstDoc.GetTitle & "_BOM.xls", "")

                                  If boolstatus = False Then swApp.SendMsgToUser "BOM for " & Part.GetTitle & " is not generated."

                                  Exit Do

                              End If

                        

                          End If

                         

                           Set SubFeat = SubFeat.GetNextFeature

                      Loop

                     

                      Set swFeat = swFeat.GetNextFeature

                  Loop