Macro to Initialize Unity and Customs properties

Library for macros
jeremyrz
Posts: 8
Joined: Thu Nov 02, 2023 11:22 am
Answers: 0

Macro to Initialize Unity and Customs properties

Unread post by jeremyrz »

Hello,
I've created a macro that allows you to manually initialise certain perssonalised properties in solidworks.
It worked until I decided to merge it with another macro that initializes units. Since then, I've been unable to get my macros to work together, or even to separate the 2 as was the case at the beginning.

Here are the lines that make up my macro.

Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Call AjoutPP
Call Macro_Init_Unit

End Sub


Sub AjoutPP()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swCustPropMgr = swModel.GetActiveConfiguration.CustomPropertyManager
Dim swFileName As String

swFileName = swModel.GetTitle
Dim sPartNo As String
Dim EValMasse As String
Dim ValMasse As String
Dim Value As String
Dim prpName As String, prpVal As String, prpType As swCustomInfoType_e
'esoIsLocked = swModel.IsLocked
'Debug.Print esoIsLocked

'Dim ffile As IEdmFile5


'IEdmFile5:: Refresh
'If True = IEdmFile5.IsLocked Then
'MsgBox "Fichier archivé"
'End If


'Debug.Print swFileName

'Debug.Print Left(swFileName, 1)
'If Left(swFileName, 1) = 0 Then
' sPartNo = Split(swFileName, ".")(0)
'Code_SAP = "B" & sPartNo
'Debug.Print Code_SAP
'End If
'Debug.Print Code_SAP

If swModel.GetType = 1 Then 'Si fichier SLDPRT

swModel.AddCustomInfo2 "Matiere", swCustomInfoText, Chr(34) & "SW-Material" & "@" & swModel.GetTitle & ".SLDPRT" & Chr(34)
swModel.AddCustomInfo2 "Masse", swCustomInfoText, Chr(34) & "SW-Mass" & "@" & swModel.GetTitle & ".SLDPRT" & Chr(34)
swModel.AddCustomInfo2 "Issude2", swCustomInfoText, "/"

vConfNameArr = swModel.GetConfigurationNames
Start = Timer
For i = 0 To UBound(vConfNameArr)

sConfigName = vConfNameArr(i)
'(RECONSTRUCTION DES CONFIGURATIONS
'bShowConfig = swModel.ShowConfiguration2(sConfigName)
'Start = Timer
bRebuild = swModel.ForceRebuild3(False)
'Debug.Print " Configuration = " & sConfigName
'Debug.Print " ShowConfig = " & bShowConfig
Debug.Print " Rebuild = " & bRebuild
Debug.Print " Time = " & Timer - Start & " seconds"

Debug.Print vConfNameArr(i)

ModelName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)
Debug.Print ModelName

Set swCustPropMgr = swModel.Extension.CustomPropertyManager(sConfigName)

swCustPropMgr.Add3 "Matiere", swCustomInfoText, Chr(34) & "SW-Material@@" & vConfNameArr(i) & "@" & ModelName & Chr(34), swCustomPropertyDeleteAndAdd
swCustPropMgr.Add3 "Masse", swCustomInfoText, Chr(34) & "SW-Mass@@" & vConfNameArr(i) & "@" & ModelName & Chr(34), swCustomPropertyDeleteAndAdd
swCustPropMgr.Add3 "Code SAP", swCustomInfoText, Code_SAP, swCustomPropertyOnlyIfNew

Next i
Else
End If

If swModel.GetType = 2 Then 'Si fichier SLDASM

swModel.AddCustomInfo2 "Matiere", swCustomInfoText, " "
swModel.AddCustomInfo2 "Masse", swCustomInfoText, Chr(34) & "SW-Mass" & "@" & swModel.GetTitle & ".SLDPRT" & Chr(34)
swModel.AddCustomInfo2 "Issude2", swCustomInfoText, "/"

vConfNameArr = swModel.GetConfigurationNames
Start = Timer
For i = 0 To UBound(vConfNameArr)

sConfigName = vConfNameArr(i)

'(RECONSTRUCTION DES CONFIGURATIONS
'bShowConfig = swModel.ShowConfiguration2(sConfigName)
'Start = Timer
bRebuild = swModel.ForceRebuild3(False)
'Debug.Print " Configuration = " & sConfigName
'Debug.Print " ShowConfig = " & bShowConfig
Debug.Print " Rebuild = " & bRebuild
Debug.Print " Time = " & Timer - Start & " seconds"

Debug.Print vConfNameArr(i)

ModelName = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1)
Debug.Print ModelName

Set swCustPropMgr = swModel.Extension.CustomPropertyManager(sConfigName)

swCustPropMgr.Add3 "Matiere", swCustomInfoText, " ", swCustomPropertyOnlyIfNew
swCustPropMgr.Add3 "Masse", swCustomInfoText, Chr(34) & "SW-Mass@@" & vConfNameArr(i) & "@" & ModelName & Chr(34), swCustomPropertyDeleteAndAdd
swCustPropMgr.Add3 "Code SAP", swCustomInfoText, Code_SAP, swCustomPropertyOnlyIfNew

Next i
Else

End If

End Sub

Sub Macro_Init_Unit()

Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim prpValNb As Double

Set swApp = Application.SldWorks
Dim prpName As String

Dim swModel As SldWorks.ModelDoc2

Set swModel = swApp.ActiveDoc
prpName = "Masse"
Debug.Print GetPropertyValue(swModel, prpName)

Set Part = swApp.ActiveDoc

boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 2)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitSystem, 0, swUnitSystem_e.swUnitSystem_Custom)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinear, 0, swLengthUnit_e.swMM)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearDecimalPlaces, 0, 2)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinear, 0, swLengthUnit_e.swINCHES)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearDecimalPlaces, 0, 2)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsAngular, 0, swAngleUnit_e.swDEGREES)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsAngularDecimalPlaces, 0, 1)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropLength, 0, swLengthUnit_e.swMM)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropVolume, 0, swUnitsMassPropVolume_e.swUnitsMassPropVolume_Centimeters3)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsTimeUnits, 0, swUnitsTimeUnit_e.swUnitsTimeUnit_Second)
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsTimeDecimalPlaces, 0, 2)

prpValNb = CDbl(Replace(prpVal, ".", ","))

Debug.Print prpValNb

Select Case prpValNb
Case Is = 0
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 3)
Case Is >= 100
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 0)
Case Is >= 5
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 1)
Case Else
boolstatus = Part.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 2)

End Select

Debug.Print prpVal

End Sub



Function GetPropertyValue(model As SldWorks.ModelDoc2, prpName As String, prpVal As String) As String

Dim swCustPrpMgr As SldWorks.CustomPropertyManager
'Dim prpVal As String

If TypeOf model Is SldWorks.PartDoc Or TypeOf model Is SldWorks.AssemblyDoc Then
Set swCustPrpMgr = model.ConfigurationManager.ActiveConfiguration.CustomPropertyManager
swCustPrpMgr.Get4 prpName, True, "", prpVal
End If

If prpVal = "" Then
Set swCustPrpMgr = model.Extension.CustomPropertyManager("")
swCustPrpMgr.Get4 prpName, True, "", prpVal
End If

GetPropertyValue = prpVal
Debug.Print prpVal

End Function


I'm getting compilation errors in VBA, and I can't find a solution to my problem.

Could one of you please help me find the problem?
Thank you very much.
User avatar
JSculley
Posts: 638
Joined: Tue May 04, 2021 7:28 am
Answers: 55
x 9
x 868

Re: Macro to Initialize Unity and Customs properties

Unread post by JSculley »

In this line:

Code: Select all

Debug.Print GetPropertyValue(swModel, prpName)
you are calling your GetPropertyValue function with two arguments, but it expects three arguments:

Code: Select all

Function GetPropertyValue(model As SldWorks.ModelDoc2, prpName As String, prpVal As String) As String
The third argument is useless since the function returns a string directly, so there is no need to pass in another argument. Change the function declaration to this:

Code: Select all

Function GetPropertyValue(model As SldWorks.ModelDoc2, prpName As String) As String
Then uncomment the second line of the function:

Code: Select all

Dim prpVal As String
This will solve the compile errors but will result in a runtime error:
image.png
image.png (5.63 KiB) Viewed 767 times
at this line:

Code: Select all

prpValNb = CDbl(Replace(prpVal, ".", ","))
because the variable prpVal doesn't exist in the Macro_Init_Unit subroutine.

Change this line:

Code: Select all

Debug.Print GetPropertyValue(swModel, prpName)
to this:

Code: Select all

prpVal = GetPropertyValue(swModel, prpName)
Debug.Print prpVal
The code will now compile and run. I leave it to you to determine if it is actually doing what you want it to do.
User avatar
gupta9665
Posts: 405
Joined: Thu Mar 11, 2021 10:20 am
Answers: 25
Location: India
x 426
x 445

Re: Macro to Initialize Unity and Customs properties

Unread post by gupta9665 »

In addition I would advise to simply the codes, remove all unwanted lines, make separate sub/function for repeated tasks, for e.g. adding the properties. This way you can fix the macro and make it more robust.
Deepak Gupta
SOLIDWORKS Consultant/Blogger
Post Reply