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.
Macro to Initialize Unity and Customs properties
Re: Macro to Initialize Unity and Customs properties
In this line:
you are calling your GetPropertyValue function with two arguments, but it expects three arguments:
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:
Then uncomment the second line of the function:
This will solve the compile errors but will result in a runtime error:
at this line:
because the variable prpVal doesn't exist in the Macro_Init_Unit subroutine.
Change this line:
to this:
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.
Code: Select all
Debug.Print GetPropertyValue(swModel, prpName)
Code: Select all
Function GetPropertyValue(model As SldWorks.ModelDoc2, prpName As String, prpVal As String) As String
Code: Select all
Function GetPropertyValue(model As SldWorks.ModelDoc2, prpName As String) As String
Code: Select all
Dim prpVal As String
Code: Select all
prpValNb = CDbl(Replace(prpVal, ".", ","))
Change this line:
Code: Select all
Debug.Print GetPropertyValue(swModel, prpName)
Code: Select all
prpVal = GetPropertyValue(swModel, prpName)
Debug.Print prpVal
Re: Macro to Initialize Unity and Customs properties
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
SOLIDWORKS Consultant/Blogger