2 Replies Latest reply on Dec 23, 2015 12:23 PM by Carlos Carneiro

    Macro to change Author, Comments, keywords, etc in all parts/assembly in one folder

    Carlos Carneiro


      I'd like to know if there's a way to make a Macro that sets or ovewrites the Author, keywords, comments and title in the Summary information of all parts and assemblies that are located in one folder, something like "open, change values, save, close" automatically. if there was a popup window wita field to define the desire values great, if not, changing it in the code would also be just fine.

      I found some code from Deepak Gupta  here but the code doesnt overwite the values.

      Thank you all for your attention.
      Best regards,


        • Re: Macro to change Author, Comments, keywords, etc in all parts/assembly in one folder
          Deepak Gupta

          These will set the two field and you can edit the codes for other fields.

          Dim swApp               As SldWorks.SldWorks

          Dim swModel             As SldWorks.ModelDoc2

          Sub main()

          Set swApp = Application.SldWorks

          Set swModel = swApp.ActiveDoc

          swModel.SummaryInfo(swSumInfoAuthor) = "Author name Here"

          swModel.SummaryInfo(swSumInfoComment) = "Comments Here"

          End Sub

            • Re: Macro to change Author, Comments, keywords, etc in all parts/assembly in one folder
              Carlos Carneiro


              Thank you for your help, I combined code from some of your macros and got this



              Option Explicit

              Private Const BIF_RETURNONLYFSDIRS As Long = &H1

              Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2

              Private Const BIF_RETURNFSANCESTORS As Long = &H8

              Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

              Private Const BIF_BROWSEFORPRINTER As Long = &H2000

              Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000

              Private Const MAX_PATH As Long = 260



              Dim swApp              As SldWorks.SldWorks

              Dim swModel            As SldWorks.ModelDoc2

              Dim swModelDocExt      As SldWorks.ModelDocExtension

              Dim Path                As String

              Dim swFilename          As String

              Dim nErrors            As Long

              Dim nWarnings          As Long

              Dim Response            As String

              Dim DocName            As String

              Dim bret                As Boolean

              Dim swDocTypeLong      As Long

              Dim vConfs              As Variant

              Dim vPropNames          As Variant

              Dim i                  As Integer

              Dim j                  As Integer

              Dim fso                As New Scripting.FileSystemObject

              Dim MYext              As String

              Dim swCustPropMgr      As SldWorks.CustomPropertyManager

              Dim tDate              As String

                Dim value              As String

                  Dim svalue              As String

                  Dim kvalue              As String

                  Dim tvalue              As String





              Function BrowseFolder(Optional Caption As String, _

                  Optional InitialFolder As String) As String



              Dim SH As Shell32.Shell

              Dim F As Shell32.folder



              Set SH = New Shell32.Shell

              Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)

              If Not F Is Nothing Then

                  BrowseFolder = F.Items.Item.Path

              End If



              End Function



              Sub main()


                  Set swApp = Application.SldWorks


                  Path = BrowseFolder()

                  If Path = "" Then

                  MsgBox "Please select the path and try again"



                  Path = Path & "\"

                  End If



                  BatchFolder Path, ".SLDPRT", ".SLDASM", True


                  MsgBox "DONE"

              End Sub

              Sub BatchFolder(folder As String, ext As String, ext2 As String, silent As Boolean)



                  If Right(folder, 1) <> "\" Then folder = folder & "\"

                  ChDir (folder)

                  Response = Dir(folder)

                  Do Until Response = ""

                      swFilename = folder & Response

                      Debug.Print swFilename

                      MYext = Right(UCase$(Response), 7)

                      If MYext = ext Or MYext = ext2 Then 'this is a file type we want, process it

                          swDocTypeLong = Switch(MYext = ".SLDPRT", swDocPART, MYext = ".SLDDRW", swDocDRAWING, MYext = ".SLDASM", swDocASSEMBLY, True, -1)


                          Set swModel = swApp.OpenDoc6(swFilename, swDocTypeLong, swOpenDocOptions_Silent, "", nErrors, nWarnings)

                          Set swModelDocExt = swModel.Extension

                        value = swModel.SummaryInfo(swSumInfoAuthor)

              If Not value = "" Then

              swModel.SummaryInfo(swSumInfoAuthor) = "AUTHOR"


              swModel.SummaryInfo(swSumInfoAuthor) = "AUTHOR"



              End If



              'Get and set the Comment KeyWord in the File Summary Info

              svalue = swModel.SummaryInfo(swSumInfoComment)

              If Not svalue = "" Then

              swModel.SummaryInfo(swSumInfoComment) = "COMMENT"


              swModel.SummaryInfo(swSumInfoComment) = "COMMENT"



              End If



              'Get and set the Comment KeyWord in the File Summary Info

              kvalue = swModel.SummaryInfo(swSumInfoKeywords)

              If Not svalue = "" Then

              swModel.SummaryInfo(swSumInfoKeywords) = "KEYWORDS"


              swModel.SummaryInfo(swSumInfoKeywords) = "KEYWORDS"



              End If



              tvalue = swModel.SummaryInfo(swSumInfoTitle)

              If Not svalue = "" Then

              swModel.SummaryInfo(swSumInfoTitle) = "TITLE"


              swModel.SummaryInfo(swSumInfoTitle) = "TITLE"



              End If




                          swModel.ShowNamedView2 "*Isometric", -1


                          swModel.ForceRebuild3 False

                          swModel.Save2 silent

                          swApp.CloseAllDocuments (True)

                      End If

                      Response = Dir


                  Dim myFolder As folder

                  Dim mySub As folder



                  Set myFolder = fso.GetFolder(folder)

                  For Each mySub In myFolder.SubFolders

                      BatchFolder mySub.Path, ext, ext2, silent

              '      Debug.Print mySub.Path


              End Sub

              Sub ClearCustPrps(conf As String)





                  Set swCustPropMgr = swModelDocExt.CustomPropertyManager(conf)

                  If Not swCustPropMgr Is Nothing Then

                      swCustPropMgr.GetAll vPropNames, Empty, Empty

                      If Not IsEmpty(vPropNames) Then

                          For j = 0 To UBound(vPropNames)

                              Debug.Print " ClearCustPrps: " & vPropNames(j)

                              swCustPropMgr.Delete vPropNames(j)


                      End If

                  End If

              End Sub


              I got it to work like i Intended to, select a folder, it opens, changes values, saves and closes all the parts.
              Now I wanted to get it to prompt a window on run where I could input the values so I didn't need to edit the code everytime.

              Can you tell me where I can find an example on how to do it?
              Best regards,