6 Replies Latest reply on Apr 19, 2018 11:44 AM by Christian Chu

    Help with Macro for Adding part of File name to Property

    Daniel Finn

      Hi,

       

      I would appreciate anyone that can help with this.

       

      To briefly explain what i am trying to do, we name our files as following eg: TE1234 Description

       

      I want to pull out the first 6 letters which i have succeeded in doing using the following code:

       

      Dim swApp As SldWorks.SldWorks

      Dim swModel As ModelDoc2

       

      Sub main()

       

           Set swApp = Application.SldWorks

          Set swModel = swApp.ActiveDoc

       

           swModel.DeleteCustomInfo ("JobNo")

          swModel.AddCustomInfo2 "JobNo", swCustomInfoText, Left(swModel.GetTitle, 6)

       

      End Sub

       

      The issue i have is that there are occasions when a part may be labelled what it is eg: M6x12mm Screw

      With this macro it pulls through the first 6 digits.

       

      Is there a way to specify for instance, if the filename does not start with 2 letters and followed by 4 digits then ignore and leave blank

       

      Any help would be appreciated with this

        • Re: Help with Macro for Adding part of File name to Property
          Simon Turner

          Dim swApp As SldWorks.SldWorks

          Dim swModel As ModelDoc2

           

          Sub main()

              Dim myName as String

           

              Set swApp = Application.SldWorks

              Set swModel = swApp.ActiveDoc

              If swModel Is Nothing Then Exit Sub

              myName = swModel.GetTitle

              If IsGoodFormat(myName) = False Then Exit Sub

           

              swModel.DeleteCustomInfo ("JobNo")

              swModel.AddCustomInfo2 "JobNo", swCustomInfoText, Left(myName, 6)

          End Sub

           

          Function IsGoodFormat(myName As String) As Boolean

              Dim i As Integer

             

              IsGoodFormat = False

             

              If Len(myName) < 6 Then Exit Function

              If IsAlpha(Left(myName, 1)) = False Then Exit Function

              If IsAlpha(Mid(myName, 2, 1)) = False Then Exit Function

              For i = 3 To 6

                  If IsNumeric(Mid(myName, i, 1)) = False Then Exit Function

              Next

              IsGoodFormat = True

          End Function

           

          Function IsAlpha(myChar As String) As Boolean

              Dim myLetters As String

             

              IsAlpha = False

              myLetters = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

              If InStr(myLetters, UCase(myChar)) = False Then Exit Function

              IsAlpha = True

          End Function

          • Re: Help with Macro for Adding part of File name to Property
            Deepak Gupta

            Simon definitely has a clever solution but here is mine simple version

             

            Dim swApp As SldWorks.SldWorks

            Dim swModel As ModelDoc2

            Dim cusPropMgr As SldWorks.CustomPropertyManager

            Sub main()

             

            Set swApp = Application.SldWorks

            Set swModel = swApp.ActiveDoc

            Set cusPropMgr = swModel.Extension.CustomPropertyManager("")

             

            If IsNumeric(Left(swModel.GetTitle, 2)) = False And IsNumeric(Mid(swModel.GetTitle, 3, 4)) = True Then

            cusPropMgr.Add3 "JobNo", swCustomInfoText, Left(swModel.GetTitle, 6), 1

            End If

             

            End Sub

            • Re: Help with Macro for Adding part of File name to Property
              Daniel Finn

              Any idea on this one? I have the macro below which now includes the above code to get the Jobno. This is creates a bounding box around the part and adds the height, width, depth to the custom properties.

               

              Any way a similar macro can work in an assembly as i cant get it work properly.

               

              PS, i did not write this, i have only added the above code into make it work how i want it too

               

               

               

               

               

              ' Handle to Macro feature regeneration

              Function swmMain(swAppIn As SldWorks.SldWorks, partIn As SldWorks.PartDoc, featureIn As feature)

                  On Error Resume Next

                 getSize (Precision)

              End Function

               

              ' Handle to Macro feature edit definition

              Sub swmPM(swAppIn, partIn, featureIn)

              On Error Resume Next

                  Dim swPage As New PropMgr

                  swPage.Init swAppIn, partIn, featureIn, swCmdEdit, swAppIn.GetCurrentMacroPathName

                  swPage.Show

              End Sub

               

              'Run this procedure to insert Macro feature with customized Property Manager Page

              Public Sub swmInsertCustomizedMacroFeature()

              On Error Resume Next

                  Dim swAppIn As SldWorks.SldWorks

                  Dim partIn As SldWorks.PartDoc

                  Dim featureIn As SldWorks.feature

                 

                  Set swAppIn = CreateObject("SldWorks.Application")

                  Set partIn = swAppIn.ActiveDoc

                 

                  Dim swPage As New PropMgr

                  swPage.Init swAppIn, partIn, featureIn, swCmdCreate, swAppIn.GetCurrentMacroPathName

                  swPage.Show

               

              End Sub

               

              Function GetMax(Val1 As Double, Val2 As Double, Val3 As Double, Val4 As Double)

               

               

              ' Finds maximum of four values

              On Error Resume Next

               

                  GetMax = Val1

               

                  If Val2 > GetMax Then

                      GetMax = Val2

                  End If

               

                  If Val3 > GetMax Then

                      GetMax = Val3

                  End If

                  If Val4 > GetMax Then

                      GetMax = Val4

                  End If

                 

                  Set swApp = Application.SldWorks

              Set swModel = swApp.ActiveDoc

               

              Set cusPropMgr = swModel.Extension.CustomPropertyManager("")

               

              If IsNumeric(Left(swModel.GetTitle, 2)) = False And IsNumeric(Mid(swModel.GetTitle, 3, 4)) = True Then

               

              cusPropMgr.Add3 "JobNo", swCustomInfoText, Left(swModel.GetTitle, 6), 1

               

              End If

               

              End Function

               

              Function GetMin(Val1 As Double, Val2 As Double, Val3 As Double, Val4 As Double)

               

              ' Finds minimum of four values

              On Error Resume Next

                  GetMin = Val1

               

                  If Val2 < GetMin Then

                      GetMin = Val2

                  End If

               

                  If Val3 < GetMin Then

                      GetMin = Val3

                  End If

               

                  If Val4 < GetMin Then

                      GetMin = Val4

                  End If

               

              End Function

               

              Sub ProcessTessTriangles(vTessTriangles As Variant, X_max As Double, _

              X_min As Double, Y_max As Double, Y_min As Double, Z_max As Double, Z_min As Double)

              On Error Resume Next

                  Dim i  As Long

               

                  For i = 0 To UBound(vTessTriangles) / (1 * 9) - 1

               

                      X_max = GetMax((vTessTriangles(9 * i + 0)), (vTessTriangles(9 * i + 3)), (vTessTriangles(9 * i + 6)), X_max)

                      X_min = GetMin((vTessTriangles(9 * i + 0)), (vTessTriangles(9 * i + 3)), (vTessTriangles(9 * i + 6)), X_min)

               

                      Y_max = GetMax((vTessTriangles(9 * i + 1)), (vTessTriangles(9 * i + 4)), (vTessTriangles(9 * i + 7)), Y_max)

                      Y_min = GetMin((vTessTriangles(9 * i + 1)), (vTessTriangles(9 * i + 4)), (vTessTriangles(9 * i + 7)), Y_min)

               

                      Z_max = GetMax((vTessTriangles(9 * i + 2)), (vTessTriangles(9 * i + 5)), (vTessTriangles(9 * i + 8)), Z_max)

                      Z_min = GetMin((vTessTriangles(9 * i + 2)), (vTessTriangles(9 * i + 5)), (vTessTriangles(9 * i + 8)), Z_min)

               

                  Next i

               

              End Sub

               

              Sub ProcessBodies(vBodies As Variant, X_max As Double, X_min As Double, Y_max As Double, Y_min As Double, _

              Z_max As Double, Z_min As Double)

              On Error Resume Next

                  Dim swBody              As SldWorks.Body2

                  Dim swFace              As SldWorks.Face2

                  Dim vTessTriangles      As Variant

                  Dim i                   As Long

               

                  ' Probably empty if no reference surfaces

                  If IsEmpty(vBodies) Then Exit Sub

                 

                  For i = 0 To UBound(vBodies)

               

                      Set swBody = vBodies(i)

                      Set swFace = swBody.GetFirstFace

               

                      While Not swFace Is Nothing

                          vTessTriangles = swFace.GetTessTriangles(True)

                          ProcessTessTriangles vTessTriangles, X_max, X_min, Y_max, Y_min, Z_max, Z_min

                          Set swFace = swFace.GetNextFace

                      Wend

                  Next i

               

              End Sub

               

              Sub getSize(accuracy As Integer)

              On Error Resume Next

                  Const MaxDouble         As Double = 1.79769313486231E+308

                  Const MinDouble         As Double = -1.79769313486231E+308

               

                  Dim swApp               As SldWorks.SldWorks

                  Dim swModel             As SldWorks.ModelDoc2

                  Dim swPart              As SldWorks.PartDoc

                  Dim vBodies             As Variant

                  Dim vBoundBox           As Variant

                  Dim X_max               As Double

                  Dim X_min               As Double

                  Dim Y_max               As Double

                  Dim Y_min               As Double

                  Dim Z_max               As Double

                  Dim Z_min               As Double

                  Dim i                   As Long

                  Dim W                   As String

                  Dim H                   As String

                  Dim D                   As String

                  Dim res                 As Boolean

                             

                  Set swApp = CreateObject("SldWorks.Application")

                  Set swModel = swApp.ActiveDoc

                 

                  If Not swModel.GetType = swDocPART Then

                      Exit Sub

                  End If

                     

                  Set swPart = swModel

               

                  ' Initialise to large/small values

               

                  X_max = MinDouble

                  X_min = MaxDouble

                  Y_max = MinDouble

                  Y_min = MaxDouble

                  Z_max = MinDouble

                  Z_min = MaxDouble

               

                  ' Solid body

                  vBodies = swPart.GetBodies2(swSolidBody, False)

                  ProcessBodies vBodies, X_max, X_min, Y_max, Y_min, Z_max, Z_min

                

                  W = rndDecimal((X_max - X_min), accuracy)

                  H = rndDecimal((Y_max - Y_min), accuracy)

                  D = rndDecimal((Z_max - Z_min), accuracy)

                     

                  'Configs

                  Dim ConfigName As String

                  ConfigName = GetConfigName(swModel)

                 

                

                  res = swModel.AddCustomInfo3(ConfigName, "W", SwConst.swCustomInfoType_e.swCustomInfoText, W)

                  If res = False Then

                      swModel.CustomInfo2(ConfigName, "W") = W

                  End If

                 

                  res = swModel.AddCustomInfo3(ConfigName, "H", SwConst.swCustomInfoType_e.swCustomInfoText, CStr(H))

                  If res = False Then

                      swModel.CustomInfo2(ConfigName, "H") = CStr(H)

                  End If

                 

                  res = swModel.AddCustomInfo3(ConfigName, "D", SwConst.swCustomInfoType_e.swCustomInfoText, CStr(D))

                  If res = False Then

                      swModel.CustomInfo2(ConfigName, "D") = CStr(D)

                  End If

                     

              End Sub

               

               

              Private Function GetConfigName(swModel) As String

                  On Error Resume Next

                 

                  Set Configuration = swModel.GetActiveConfiguration()

                  GetConfigName = Configuration.Name

                  If Len(GetConfigName) < 1 Or UCase(GetConfigName) = "DEFAULT" Then

                      GetConfigName = ""

                  End If

              End Function

               

              Function rndDecimal(numbRnd As Double, decPlaces As Integer) As String

              On Error Resume Next

                  'converts a number to a string, ensuring trailing zeros are kept

                  'Aslso multiplies by 1000 as SW units are in Meters not mm

                     

                  rndDecimal = CStr(Round(((numbRnd) * 1000), decPlaces))

                 

                  'Add additional decimal places

                  If InStr(rndDecimal, ".") = 0 Then rndDecimal = rndDecimal & "."

                     

                  While (decPlaces > (Len(rndDecimal) - InStr(rndDecimal, ".")))

                     rndDecimal = rndDecimal & "0"

                  Wend

               

              End Function

              • Re: Help with Macro for Adding part of File name to Property
                Christian Chu

                Instead of using left function at 6th character, why don't you break a string of file name at space before the description? so it doesn't matter if you have 6 or 7 or 8 or whatever as long as you have a space before the descipion