1 Reply Latest reply on Feb 14, 2017 5:35 PM by Artem Taturevych

    Need a Macro to save drawing tabs to separate drawing files in 2016

    Jeremy Campbell

      I have a drawing file that contains 20 sheet tabs and would like to have a macro that saves them as separate files with one sheet tab each. I tried a previous macro that was posted on a thread for SW 2014 but it only produced a copy of the original file and named it sheet1 and still contained all sheet tabs. 2014 Macro below:

       

      Dim swApp As Object

      Sub main()

      Dim swApp               As SldWorks.SldWorks

       

          Dim swModel             As SldWorks.ModelDoc2

       

          Dim swDrawing           As SldWorks.DrawingDoc

       

          Dim swModelDocExt       As SldWorks.ModelDocExtension

       

          Dim boolstatus          As Boolean

       

          Dim filename            As String

       

          Dim Newfilename         As String

        

          Dim sfilename            As String

       

          Dim lErrors             As Long

       

          Dim lWarnings           As Long

       

          Dim varSheetName1       As Variant

       

          Dim varSheetNames       As Variant

       

          Dim varSheetName2       As Variant

       

          Set swApp = Application.SldWorks

       

          Set swModel = swApp.ActiveDoc

       

          Set swDrawing = swModel

       

          filename = swModel.GetPathName

       

          varSheetNames = swDrawing.GetSheetNames

       

          swApp.CloseDoc filename

       

          For Each varSheetName1 In varSheetNames

       

                      sfilename = Left$(filename, InStrRev(filename, "\"))

       

              Newfilename = sfilename & varSheetName1 & ".slddrw"

       

              FileCopy filename, Newfilename

       

              Set swModel = swApp.OpenDoc6(Newfilename, swDocDRAWING, swOpenDocOptions_Silent Or swOpenDocOptions_RapidDraft, "", lErrors, lWarnings)

       

              Set swDrawing = swModel

       

              If lErrors + lWarnings = 0 Then

       

                  For Each varSheetName2 In varSheetNames

       

                      If varSheetName1 <> varSheetName2 Then

       

                          swDrawing.ActivateSheet (varSheetName1)

       

                          swModel.Extension.SelectByID2 varSheetName2, "SHEET", 0, 0, 0, False, 0, Nothing, 0

       

                          swModel.Extension.DeleteSelection2 swDelete_Children

       

                      End If

       

                  Next varSheetName2

       

                  swModel.Save3 swSaveAsOptions_Silent, lErrors, lWarnings

       

                  swApp.CloseDoc Newfilename

       

              End If

       

          Next varSheetName1

      Set swApp = Application.SldWorks

      End Sub