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