Ich poste die neueste Vollversion, die den Zweck erfüllt:
Option Explicit
Const UPDATE_ALL_COMPS As Boolean = True
Const REBUILD_ALL_CONFIGS As Boolean = False 'Mettre true pour reconstruire toutes les configurations (attention peut être très long sur grande famille de pièces)
Dim swApp As SldWorks.SldWorks
Dim enLectureSeule As Boolean
Dim PathName As String
Dim bRet As Boolean
Dim errorsSave As Long
Dim warnings As Long
Sub main()
enLectureSeule = False
Set swApp = Application.SldWorks
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
'On vérifie si la pièce est en lecture seule
If swModel.IsOpenedReadOnly Then
Debug.Print "Fichier en lecture seule"
enLectureSeule = True
'On enlève la lecture seule
PathName = UCase(swModel.GetPathName)
SetAttr PathName, vbNormal
swModel.FileReload
bRet = swModel.ReloadOrReplace(False, swModel.GetPathName, True)
swModel.FileReload
End If
'On passe au nouveau mode de représentation de filetage
Dim allowUpgrade As Boolean
allowUpgrade = swApp.GetUserPreferenceToggle(swUserPreferenceToggle_e.swEnableAllowCosmeticThreadsUpgrade)
swApp.SetUserPreferenceToggle swUserPreferenceToggle_e.swEnableAllowCosmeticThreadsUpgrade, True
If False = swModel.Extension.UpgradeLegacyCThreads() Then
Debug.Print "Thread is not upgraded"
End If
'On passe au nouveau mode d'affichage des propriétés personnalisées
swModel.Extension.UpgradeLegacyCustomProperties UPDATE_ALL_COMPS
'Modification de la table de famille de pièce
Dim swDesTable As SldWorks.DesignTable
Dim nTotRow As Long
Dim nTotCol As Long
Dim sRowStr As String
Dim i As Long
Dim j As Long
Set swDesTable = swModel.GetDesignTable
bRet = swDesTable.Attach
'Debug.Assert bRet
nTotRow = swDesTable.GetTotalRowCount
nTotCol = swDesTable.GetTotalColumnCount
Debug.Print "File = " & swModel.GetPathName
Debug.Print " Title = " & swDesTable.GetTitle
Debug.Print " Row = " & swDesTable.GetRowCount
Debug.Print " Col = " & swDesTable.GetColumnCount
Debug.Print " TotRow = " & nTotRow
Debug.Print " TotCol = " & nTotCol
Debug.Print " VisRow = " & swDesTable.GetVisibleRowCount
Debug.Print " VisCol = " & swDesTable.GetVisibleColumnCount
Debug.Print ""
For i = 0 To nTotRow
sRowStr = " |"
For j = 0 To nTotCol
If i = 0 Then sRowStr = sRowStr + swDesTable.GetEntryText(i, j) + "|"
If swDesTable.GetEntryText(i, j) = "$DESCRIPTION" Then
swDesTable.SetEntryText i, j, "$Description2"
swDesTable.SetEntryText i, j, "$Description"
End If
If swDesTable.GetEntryText(i, j) Like "$*DESIGNATION" Then
swDesTable.SetEntryText i, j, "$Propriete@Designation2"
swDesTable.SetEntryText i, j, "$Propriete@Designation"
End If
If swDesTable.GetEntryText(i, j) Like "$*CODE GUELT" Then
swDesTable.SetEntryText i, j, "$Propriete@Code Guelt2"
swDesTable.SetEntryText i, j, "$Propriete@Code Guelt"
End If
If swDesTable.GetEntryText(i, j) Like "$*CODE" Then
swDesTable.SetEntryText i, j, "$Propriete@Code2"
swDesTable.SetEntryText i, j, "$Propriete@Code"
End If
If swDesTable.GetEntryText(i, j) Like "$*CATEGORIE" Then
swDesTable.SetEntryText i, j, "$Propriete@Categorie2"
swDesTable.SetEntryText i, j, "$Propriete@Categorie"
End If
If swDesTable.GetEntryText(i, j) Like "$*FOURNISSEUR" Then
swDesTable.SetEntryText i, j, "$Propriete@Fournisseur2"
swDesTable.SetEntryText i, j, "$Propriete@Fournisseur"
End If
Next j
Debug.Print sRowStr
Next i
swDesTable.Detach
'On lance la fonction recherche des propriété à modifier
PrintConfigurationSpecificProperties swModel, True
'On reconstruit toutes les configs si besoin (suivant constante REBUILD_ALL_CONFIGS -> True or False)
If REBUILD_ALL_CONFIGS Then
swModel.Extension.ForceRebuildAll
End If
'Vue iso avant sauvegarde et zoom tout
swModel.ShowNamedView2 "*Isométrique", 7
swModel.ViewZoomtofit2
'On sauvegarde
bRet = swModel.Save3(swSaveAsOptions_e.swSaveAsOptions_Silent, errorsSave, warnings)
If bRet = False Then
Debug.Print "Save errors (8192 = Saving an assembly with renamed components requires saving the references): " & errorsSave
End If
'on remet la lecture seule si activé au départ
If enLectureSeule = True Then
SetAttr PathName, vbReadOnly
'Si oui, on met la lecture seule dans Windows
swModel.FileReload
bRet = swModel.ReloadOrReplace(False, swModel.GetPathName, True)
swModel.FileReload
End If
Else
MsgBox "Please open model"
End If
End Sub
Sub PrintConfigurationSpecificProperties(model As SldWorks.ModelDoc2, cached As Boolean)
Dim vNames As Variant
vNames = model.GetConfigurationNames()
Dim i As Integer
Debug.Print "Configuration Specific Properties"
For i = 0 To UBound(vNames)
Dim confName As String
confName = vNames(i)
Dim swCustPrpMgr As SldWorks.CustomPropertyManager
Set swCustPrpMgr = model.Extension.CustomPropertyManager(confName)
Debug.Print " " & confName
PrintProperties swCustPrpMgr, cached, " "
Next
End Sub
Sub PrintProperties(custPrpMgr As SldWorks.CustomPropertyManager, cached As Boolean, indent As String)
Dim vPrpNames As Variant
vPrpNames = custPrpMgr.GetNames()
Dim i As Integer
If Not IsEmpty(vPrpNames) Then
For i = 0 To UBound(vPrpNames)
Dim prpName As String
prpName = vPrpNames(i)
Dim prpVal As String
Dim prpResVal As String
Dim wasResolved As Boolean
Dim isLinked As Boolean
Dim res As Long
res = custPrpMgr.Get6(prpName, cached, prpVal, prpResVal, wasResolved, isLinked)
Dim status As String
Select Case res
Case swCustomInfoGetResult_e.swCustomInfoGetResult_CachedValue
status = "Cached Value"
Case swCustomInfoGetResult_e.swCustomInfoGetResult_ResolvedValue
status = "Resolved Value"
Case swCustomInfoGetResult_e.swCustomInfoGetResult_NotPresent
status = "Not Present"
End Select
Debug.Print indent & "Property: " & prpName
Debug.Print indent & "Value/Text Expression: " & prpVal
Debug.Print indent & "Evaluated Value: " & prpResVal
Debug.Print indent & "Was Resolved: " & wasResolved
Debug.Print indent & "Is Linked: " & isLinked
Debug.Print indent & "Status: " & status
Debug.Print ""
If prpName = "CATEGORIE" Then
'On supprime la propriété
custPrpMgr.Delete "CATEGORIE"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Categorie", 30, prpVal, swCustomPropertyReplaceValue
End If
If prpName = "CODE" Then
'On supprime la propriété
custPrpMgr.Delete "CODE"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Code", 30, prpVal, swCustomPropertyReplaceValue
End If
If prpName = "CODE GUELT" Then
'On supprime la propriété
custPrpMgr.Delete "CODE GUELT"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Code Guelt", 30, prpVal, swCustomPropertyReplaceValue
End If
If prpName = "FOURNISSEUR" Then
'On supprime la propriété
custPrpMgr.Delete "FOURNISSEUR"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Fournisseur", 30, prpVal, swCustomPropertyReplaceValue
End If
If prpName = "DESIGNATION" Then
'On supprime la propriété
custPrpMgr.Delete "DESIGNATION"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Designation", 30, prpVal, swCustomPropertyReplaceValue
End If
If prpName = "DESCRIPTION" Then
Debug.Print "texte en majuscule"
'On supprime la propriété
custPrpMgr.Delete "DESCRIPTION"
'Création de la propriété avec changement de casse et la valeure de l'ancienne propriété
custPrpMgr.Add3 "Description", 30, prpVal, swCustomPropertyReplaceValue
End If
Next
Else
Debug.Print indent & "-No Properties-"
End If
End Sub
Für die beste Antwort gebe ich sie an @Maclane, der mir einen Teil der Antwort und einen Hinweis für den 2. Teil gegeben hat.