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

Outcomes