Tag zusammen
Ich arbeite derzeit an einem Makro, mit dem ich Dateien auf SOLIDWORKS bereinigen kann. (Reinigungseigenschaften, Änderung des Einheitensystems). Neben der Änderung der Einheit auf MMGS hätte ich gerne die Dezimalstellen auf .1 gesetzt
Wenn jemand eine Idee hat, welche Formel man dafür verwenden soll?
Option Explicit
Sub RunMacro()
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim modelDocType As Long
Dim swDocs As Variant
Dim i As Integer
Dim updatedCount As Integer
Dim updatedDocs As String ' Variable pour accumuler les documents modifiés
Dim swConfig As Configuration
Dim swCustPropMgr As CustomPropertyManager
Dim propNames As Variant
Dim propName As Variant
Dim swConfigNames As Variant
Dim configName As Variant
Dim modelName As String
Dim massValue As String
Dim excludeProps As Variant
Dim excludeProp As Variant
Dim propToDelete As Boolean
Dim userResponse As VbMsgBoxResult
Dim runMode As Integer ' 1 = actif uniquement, 2 = tous les documents
Dim docCount As Integer
' Obtenir l'instance de SolidWorks
Set swApp = Application.SldWorks
' Obtenir tous les documents ouverts
swDocs = swApp.GetDocuments()
' Compter le nombre de documents ouverts
If Not IsEmpty(swDocs) Then
docCount = UBound(swDocs) - LBound(swDocs) + 1
Else
MsgBox "Aucun document ouvert.", vbExclamation
Exit Sub
End If
' Message confirmation exécution
userResponse = MsgBox("Voulez-vous exécuter la macro SwCleaner ?" & vbCrLf & vbCrLf & _
"L'unité sera définie sur MMGS et les propriétés seront nettoyées.", _
vbYesNo + vbQuestion)
If userResponse = vbNo Then Exit Sub
' Gérer selon le contexte
If docCount = 1 Then
' Un seul document ouvert
Set swModel = swDocs(0)
If swModel.GetType = swDocPART Then
runMode = 1 ' lancer direct sur l'actif
Else
' Si c'est un assembly ou un plan, demander
userResponse = MsgBox("Vous avez un assemblage ou un plan ouvert." & vbCrLf & vbCrLf & _
"Souhaitez-vous exécuter la macro uniquement sur le document actif ?" & vbCrLf & vbCrLf & _
"(Oui = document actif, Non = tous les documents ouverts, Annuler = quitter)", _
vbYesNoCancel + vbQuestion)
If userResponse = vbYes Then
runMode = 1
ElseIf userResponse = vbNo Then
runMode = 2
Else
Exit Sub
End If
End If
Else
' Plusieurs documents ouverts ? demander
userResponse = MsgBox("Vous avez plusieurs documents ouverts." & vbCrLf & vbCrLf & _
"Sur quel document souhaitez-vous exécuter la macro ?" & vbCrLf & vbCrLf & _
"Oui = sur le document actif" & vbCrLf & _
"Non = sur tous les documents ouverts" & vbCrLf & _
"Annuler = quitter", vbYesNoCancel + vbQuestion)
If userResponse = vbYes Then
runMode = 1
ElseIf userResponse = vbNo Then
runMode = 2
Else
Exit Sub
End If
End If
' Liste des propriétés à ne pas supprimer
excludeProps = Array("MASSE", "Registration Date", "Customer", "Dossier", "Commande", "Code Article", "INDICE", _
"Ref designation", "Materials", "COULEUR MATIERE", "CONCEPTION MATIERE", "RETRAIT", "PROCESS", _
"LASER", "CN", "PIECE ISSUE DE :", "FINITION FACES BLEUES", "FINITION CHANTS", "IND DT", "MASSE DT")
updatedCount = 0
updatedDocs = "" ' Réinitialiser la chaîne des documents modifiés
' Parcours des documents selon le mode choisi
If runMode = 1 Then
Set swModel = swApp.ActiveDoc
If Not swModel Is Nothing Then
updatedDocs = updatedDocs & swModel.GetTitle() & vbCrLf ' Ajouter le nom du document modifié
Call NettoyerEtMettreAJour(swModel, excludeProps, updatedCount)
End If
ElseIf runMode = 2 Then
For i = LBound(swDocs) To UBound(swDocs)
Set swModel = swDocs(i)
If Not swModel Is Nothing Then
updatedDocs = updatedDocs & swModel.GetTitle() & vbCrLf ' Ajouter le nom du document modifié
Call NettoyerEtMettreAJour(swModel, excludeProps, updatedCount)
End If
Next i
End If
' Message final avec les documents modifiés
If updatedCount > 0 Then
MsgBox updatedCount & " document(s) ont été mis à jour." & vbCrLf & vbCrLf & _
"Documents modifiés : " & vbCrLf & updatedDocs, vbInformation
Else
MsgBox "Aucun document mis à jour.", vbExclamation
End If
End Sub
Sub NettoyerEtMettreAJour(swModel As ModelDoc2, excludeProps As Variant, updatedCount As Integer)
Dim modelDocType As Long
Dim swConfig As Configuration
Dim swCustPropMgr As CustomPropertyManager
Dim propNames As Variant
Dim propName As Variant
Dim swConfigNames As Variant
Dim configName As Variant
Dim modelName As String
Dim massValue As String
Dim excludeProp As Variant
Dim propToDelete As Boolean
modelDocType = swModel.GetType
If modelDocType = swDocPART Or modelDocType = swDocASSEMBLY Or modelDocType = swDocDRAWING Then
' Définir unité MMGS
swModel.SetUserPreferenceIntegerValue swUserPreferenceIntegerValue_e.swUnitSystem, swUnitSystem_e.swUnitSystem_MMGS
' Définir décimales longueur à 0.1
swModel.SetUserPreferenceDoubleValue swUserPreferenceDoubleValue_e.swLengthDecimalDisplay, 0.1
swModel.ForceRebuild3 False
' Nettoyer les propriétés "Personnaliser"
Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
propNames = swCustPropMgr.GetNames
If Not IsEmpty(propNames) Then
For Each propName In propNames
swCustPropMgr.Delete propName
Next propName
End If
' Nettoyer et ajouter propriétés dans chaque configuration (pour pièces et assemblages)
If modelDocType = swDocPART Or modelDocType = swDocASSEMBLY Then
swConfigNames = swModel.GetConfigurationNames
For Each configName In swConfigNames
Set swConfig = swModel.GetConfigurationByName(configName)
Set swCustPropMgr = swModel.Extension.CustomPropertyManager(swConfig.Name)
propNames = swCustPropMgr.GetNames
If Not IsEmpty(propNames) Then
For Each propName In propNames
propToDelete = True
For Each excludeProp In excludeProps
If propName = excludeProp Then
propToDelete = False
Exit For
End If
Next excludeProp
If propToDelete Then
swCustPropMgr.Delete propName
End If
Next propName
End If
modelName = swModel.GetTitle()
massValue = """SW-Mass@@Défaut@" & modelName & """"
swCustPropMgr.Add3 "masse", swCustomInfoText, massValue, swCustomPropertyDeleteAndAdd
Next configName
End If
updatedCount = updatedCount + 1
Debug.Print swModel.GetTitle() & " mis à jour."
End If
End Sub