Hallo ihr alle
Ich versuche, ein Makro zu erstellen, um eine Reihe ausgewählter Dimensionen in einem Plan zu extrahieren und sie nach Excel zu exportieren.
Ich stelle drei Eigenschaften wieder her, die es ermöglichen, die Datei, aus der die Dimensionen extrahiert wurden, schnell zu identifizieren.
Das Makro funktioniert einwandfrei (das Layout ist in Ordnung, die Eigenschaften werden abgerufen, die ausgewählten Bemaßungen werden gut angezeigt), außer dass die Toleranzen systematisch auf Null gehen...
Chat GPT, das mir bei der Erstellung dieses Makros eine große Hilfe war, stolpert über das Problem. Eine andere KI, Claude, könnte es nicht besser machen.
Weiß jemand, was den Nullwert systematisch steigen lässt? Ich gebe an, dass die Dimensionen, die ich in meinem zu testenden Plan auswähle, eine symmetrische Toleranz von +/-0,15 haben, die direkt aus dem Angebot des Immobilienverwalters eingegeben wird.
Option Explicit
Sub main()
ExportCotesVersExcel
End Sub
Sub ExportCotesVersExcel()
Dim swApp As Object
Dim swModel As Object
Dim swDraw As Object
Dim swSelMgr As Object
Dim swDispDim As Object
Dim swDim As Object
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim i As Integer
Dim j As Integer
Dim tolMin As Double
Dim tolMax As Double
Dim value As Double
Dim valueMin As Double
Dim valueMax As Double
Dim itMin As Double
Dim itMax As Double
' Créer une instance de SolidWorks (Late Binding)
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc
' Vérification si un dessin est actif
If swModel Is Nothing Then
MsgBox "Veuillez ouvrir un dessin 2D avant d'exécuter la macro.", vbExclamation
Exit Sub
End If
' Vérification du type de document
If swModel.GetType <> 3 Then ' 3 correspond à swDocDRAWING
MsgBox "Cette macro fonctionne uniquement sur un dessin 2D.", vbExclamation
Exit Sub
End If
Set swDraw = swModel
Set swSelMgr = swModel.SelectionManager
' Créer une instance d'Excel (Late Binding)
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application") ' Vérifier si Excel est ouvert
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application") ' Ouvrir Excel si ce n'est pas le cas
End If
On Error GoTo 0
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
Set xlSheet = xlWorkbook.Sheets(1)
' Entêtes Excel pour les propriétés
xlSheet.Cells(1, 1).value = "Référence M3_2D"
xlSheet.Cells(2, 1).value = "Indice"
xlSheet.Cells(3, 1).value = "Description"
' Ajouter une ligne vide après les propriétés
xlSheet.Cells(4, 1).value = ""
' Récupérer les propriétés du modèle (Référence M3_2D, Indice, Description)
Dim customProps As Object
Set customProps = swModel.Extension.CustomPropertyManager("")
Dim refM3_2D As String
Dim indice As String
Dim description As String
' Essayer de récupérer les propriétés en tenant compte des erreurs
On Error Resume Next
refM3_2D = customProps.Get("Référence M3_2D")
If Err.Number <> 0 Then refM3_2D = "Non disponible"
indice = customProps.Get("Indice")
If Err.Number <> 0 Then indice = "Non disponible"
description = customProps.Get("Description")
If Err.Number <> 0 Then description = "Non disponible"
On Error GoTo 0
' Ajouter les propriétés dans Excel
xlSheet.Cells(1, 2).value = refM3_2D
xlSheet.Cells(2, 2).value = indice
xlSheet.Cells(3, 2).value = description
' Ajouter une ligne vide après les propriétés
xlSheet.Cells(4, 1).value = ""
' Ajouter les en-têtes pour les cotes
xlSheet.Cells(5, 1).value = "Nom de la cote"
xlSheet.Cells(5, 2).value = "Valeur"
xlSheet.Cells(5, 3).value = "IT Min"
xlSheet.Cells(5, 4).value = "IT Max"
xlSheet.Cells(5, 5).value = "Valeur Cote Min"
xlSheet.Cells(5, 6).value = "Valeur Cote Max"
' Vérifier si des cotes sont sélectionnées
Dim nbCotes As Integer
nbCotes = swSelMgr.GetSelectedObjectCount()
If nbCotes = 0 Then
MsgBox "Veuillez sélectionner des cotes avant d'exécuter la macro.", vbExclamation
Exit Sub
End If
' Parcours des cotes sélectionnées
i = 6 ' Commencer à la ligne 6 après les propriétés, la ligne vide et les en-têtes
Dim ent As Object
For j = 1 To nbCotes
Set ent = swSelMgr.GetSelectedObject6(j, -1)
' Vérifier si l'entité sélectionnée est une cote
If Not ent Is Nothing Then
If TypeOf ent Is SldWorks.DisplayDimension Then
Set swDispDim = ent
Set swDim = swDispDim.GetDimension
' Vérification de swDim avant d’accéder à ses valeurs
If Not swDim Is Nothing Then
' Récupérer la valeur de la cote
value = swDim.value
' Calcul des valeurs min et max de la cote
valueMin = value - tolMin
valueMax = value + tolMax
' Récupérer les tolérances IT (si disponibles)
On Error Resume Next
itMin = swDim.tolerance.itMin
itMax = swDim.tolerance.itMax
On Error GoTo 0
' Si les tolérances IT ne sont pas disponibles, les assigner à 0
If IsError(itMin) Then itMin = 0
If IsError(itMax) Then itMax = 0
' Exporter la cote, sa valeur, les tolérances IT et les valeurs min et max dans Excel
xlSheet.Cells(i, 1).value = swDim.FullName ' Nom de la cote
xlSheet.Cells(i, 2).value = Round(value, 2) ' Valeur de la cote
xlSheet.Cells(i, 3).value = Round(itMin, 2) ' Tolérance IT Min
xlSheet.Cells(i, 4).value = Round(itMax, 2) ' Tolérance IT Max
xlSheet.Cells(i, 5).value = Round(valueMin, 2) ' Valeur min de la cote
xlSheet.Cells(i, 6).value = Round(valueMax, 2) ' Valeur max de la cote
i = i + 1
Else
Debug.Print "Erreur : swDim est null pour un élément sélectionné."
End If
Else
Debug.Print "L'élément sélectionné n'est pas une cote."
End If
Else
Debug.Print "Erreur : ent est null pour l'élément " & j
End If
Next j
' Ajuster la largeur de la colonne A en fonction de son contenu
xlSheet.Columns("A:A").AutoFit
MsgBox "Exportation terminée avec succès !", vbInformation
End Sub
)
), aber... Es funktioniert nicht gut für symmetrische Toleranzen.