AnsweredAssumed Answered

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

Question asked by Jeremy Campbell on Feb 14, 2017
Latest reply on Feb 14, 2017 by Artem Taturevych

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