Hoi allemaal
Ik probeer een macro te maken om een reeks geselecteerde dimensies in een plan te extraheren en deze naar Excel te exporteren.
Ik herstel drie eigenschappen, waardoor ik snel het bestand kan identificeren waaruit de dimensies zijn geëxtraheerd.
De macro werkt perfect (de lay-out is Ok, de eigenschappen worden opgehaald, de geselecteerde dimensies zien er goed uit), behalve dat de toleranties systematisch op nul uitkomen...
Chat GPT, dat me enorm heeft geholpen bij het maken van deze macro, stuit op het probleem. Een andere AI, Claude, kon het niet beter doen.
Weet iemand waardoor de nulwaarde systematisch stijgt? Ik geef aan dat op de afmetingen die ik selecteer op mijn plan om te testen een tolerantie hebben, symmetrisch, van +/- 0,15, rechtstreeks ingevoerd vanuit de offerte van de vastgoedbeheerder.
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
)
) maar... Het werkt niet goed voor symmetrische toleranties.