Macro to Initialize Unity and Customs properties

[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.

[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 (5.63 KiB) Viewed 844 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.

[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.