Hallo allemaal !
Ik heb code die over de lijnen en boog van een schets wordt herhaald en geen onderscheid maakt tussen lijnen en constructielijnen. Weet jij een manier om dit onderscheid te maken?
Er is een vakje aangevinkt tijdens de bouw, dus ik hoop dat we deze informatie via de API kunnen vinden. Dit is mijn code, als je het wilt controleren.
Dim dupIndex1 As Long, dupIndex2 As Long, uniqueIndex As Long
Sub CompterBalayages()
' Déclaration des variables
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeat As SldWorks.Feature
Dim compteur As Integer
Dim typeFeat As String
' Récupérer l'instance de SolidWorks
Set swApp = Application.SldWorks
' Récupérer le document actif
Set swModel = swApp.ActiveDoc
' Vérifier qu'un document est ouvert
If swModel Is Nothing Then
MsgBox "Aucun document ouvert."
Exit Sub
End If
compteur = 0
' Démarrer à partir de la première feature du document
Set swFeat = swModel.FirstFeature
' Boucle sur toutes les features du modèle
Do While Not swFeat Is Nothing
' Récupérer le nom du type de la feature
typeFeat = swFeat.GetTypeName2
' Vérifier si la feature est un balayage.
' Selon la langue, le nom peut être "Balayage", "Sweep" ou "Swept Boss/Base"
If typeFeat = "Balayage" Or typeFeat = "Sweep" Or typeFeat = "Swept Boss/Base" Then
compteur = compteur + 1
End If
' Passer à la feature suivante
Set swFeat = swFeat.GetNextFeature
Loop
Debug.Print "compteur = " & compteur
If compteur = 1 Then
DetectSketchSegmentsInExtrusion
Else
Debug.Print "yen a trop ou pas assez "
End If
End Sub
Sub DetectSketchSegmentsInExtrusion()
' Déclaration des objets SolidWorks
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swFeature As Feature
Dim swSubFeature As Feature
Dim swSketch As Sketch
Dim swSketchSegment As SketchSegment
Dim vSketchSegments As Variant
Dim i As Long
Dim sketchIndex As Integer
Dim segType As Integer
' Variables pour le calcul
Dim circleValue As Double
Dim circleFound As Boolean
Dim calcValue As Double
Dim calcFound As Boolean
Dim uniquearc As Integer
Dim nbbalayage As Integer
nbbalayage = 0
' Variables pour la gestion des indices (à utiliser dans TrouverIndices)
dupIndex1 = -1
uniqueIndex = -1
Dim profondeur As Double
Dim lignezz As Variant ' Variable à transmettre à TrouverIndices si nécessaire
' Tableaux dynamiques pour stocker les valeurs d'arcs et de lignes
Dim arc() As Double
Dim ligne() As Double
' Initialiser SolidWorks et récupérer le document actif
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
MsgBox "Aucun document n'est ouvert.", vbCritical
Exit Sub
End If
sketchIndex = 0
Set swFeature = swModel.FirstFeature
' Parcourir toutes les fonctionnalités de la pièce
Do While Not swFeature Is Nothing
' Traiter uniquement les fonctionnalités de type Balayage (Sweep)
If swFeature.GetTypeName2 = "Sweep" Then
' ****************************************************
' Vérification préalable des subfeatures (esquisses)
' ****************************************************
Dim profileCount As Integer, threeDSketchCount As Integer
profileCount = 0
threeDSketchCount = 0
Set swSubFeature = swFeature.GetFirstSubFeature
Do While Not swSubFeature Is Nothing
Dim subFeatType As String
subFeatType = swSubFeature.GetTypeName2
' Compter les esquisses planes
If subFeatType = "ProfileFeature" Then
profileCount = profileCount + 1
' Compter les esquisses 3D (adapter la chaîne si besoin)
ElseIf subFeatType = "3D Sketch" Or subFeatType = "3DSketch" Then
threeDSketchCount = threeDSketchCount + 1
End If
Set swSubFeature = swSubFeature.GetNextSubFeature
Loop
' Vérifier que le balayage contient exactement 2 esquisses planes et aucune esquisse 3D
If profileCount = 2 And threeDSketchCount = 0 Then
' Le balayage est conforme, on le traite
nbbalayage = nbbalayage + 1
circleValue = 0
circleFound = False
calcValue = 0
calcFound = False
Set swSubFeature = swFeature.GetFirstSubFeature
Do While Not swSubFeature Is Nothing
If swSubFeature.GetTypeName2 = "ProfileFeature" Then
sketchIndex = sketchIndex + 1
Set swSketch = swSubFeature.GetSpecificFeature2 ' Obtenir l'objet Sketch
If Not swSketch Is Nothing Then
vSketchSegments = swSketch.GetSketchSegments
If Not IsEmpty(vSketchSegments) Then
Dim arcCount As Integer, lineCount As Integer
Dim totalArcValue As Double, totalLineValue As Double
arcCount = 0
lineCount = 0
totalArcValue = 0
totalLineValue = 0
' Parcourir tous les segments de l'esquisse
For i = LBound(vSketchSegments) To UBound(vSketchSegments)
Set swSketchSegment = vSketchSegments(i)
segType = swSketchSegment.GetType
Select Case segType
Case 1 ' Arc
Dim arcVal As Double
arcVal = Round(swSketchSegment.GetRadius * 1000, 2)
Debug.Print " Esquisse " & sketchIndex & ", Segment " & (i + 1) & " : Arc, Rayon = " & arcVal & " mm"
If arcCount = 0 Then
ReDim arc(0)
Else
ReDim Preserve arc(arcCount)
End If
arc(arcCount) = arcVal
arcCount = arcCount + 1
totalArcValue = totalArcValue + arcVal
Case 0 ' Ligne
Dim lineVal As Double
lineVal = Round(swSketchSegment.GetLength * 1000, 2)
Debug.Print " Esquisse " & sketchIndex & ", Segment " & (i + 1) & " : Ligne = " & lineVal & " mm"
If lineCount = 0 Then
ReDim ligne(0)
Else
ReDim Preserve ligne(lineCount)
End If
ligne(lineCount) = lineVal
lineCount = lineCount + 1
totalLineValue = totalLineValue + lineVal
Case Else
Debug.Print " Esquisse " & sketchIndex & ", Segment " & (i + 1) & " : Type inconnu (" & segType & ")"
End Select
Next i
' Traitement selon le nombre de segments détectés
If arcCount = 1 And lineCount = 0 Then
' Par exemple, on récupère l'unique arc
uniquearc = arc(0)
Debug.Print "Unique arc trouvé : " & arc(0) & " mm"
ElseIf arcCount = 0 And lineCount = 1 Then
Debug.Print "Profondeur = " & ligne(0) & " mm"
ElseIf arcCount = 2 And lineCount = 4 Then
Call TrouverIndices(ligne, lignezz)
Debug.Print "aaaaaaaaaaaaaaaaaaaaa"
Debug.Print dupIndex1 & uniqueIndex
If dupIndex1 <> -1 And uniqueIndex <> -1 Then
profondeur = 2 * ligne(dupIndex1) + 4 * arc(0) + ligne(uniqueIndex)
Debug.Print "Profondeur calculée : " & profondeur & " mm"
Dim pli1 As Double
pli1 = ligne(dupIndex1) + arc(0) + ligne(uniqueIndex) + 2 * arc(0)
Debug.Print "pli à " & ligne(dupIndex1) + arc(0) & "pli à :" & pli1
End If
ElseIf arcCount = 1 And lineCount = 2 Then
calcValue = totalLineValue + 2 * totalArcValue
' Ajustement supplémentaire selon la valeur de l'arc unique
If uniquearc = 6 Then
calcValue = calcValue - 7
Debug.Print "pli à : " & lineVal + arcVal
Debug.Print " Ajustement : Arc = 6 mm, soustraction de 7."
ElseIf uniquearc = 5 Then
calcValue = calcValue - 6
Debug.Print " Ajustement : Arc = 5 mm, soustraction de 6."
Debug.Print "pli à : " & lineVal + arcVal
Else
Debug.Print " Pas d'ajustement sur l'arc."
End If
calcFound = True
Debug.Print " Esquisse " & sketchIndex & " (Calcul) : Valeur calculée = " & calcValue & " mm"
Else
Debug.Print "Balayage non traité pour cette esquisse (arcCount = " & arcCount & ", lineCount = " & lineCount & ")"
End If
Else
Debug.Print " Esquisse " & sketchIndex & " : Aucune entité trouvée."
End If
Else
Debug.Print " Esquisse " & sketchIndex & " : Esquisse non valide."
End If
End If
Set swSubFeature = swSubFeature.GetNextSubFeature
Loop
Else
Debug.Print "profondeur = N/A"
Exit Sub
End If
End If
Set swFeature = swFeature.GetNextFeature
Loop
' Affichage du contenu des tableaux pour vérification
Dim z As Integer
If Not IsEmpty(arc) Then
For z = LBound(arc) To UBound(arc)
Debug.Print "arc " & z & " --- " & arc(z)
Next z
End If
If Not IsEmpty(ligne) Then
For z = LBound(ligne) To UBound(ligne)
Debug.Print "ligne " & z & " --- " & ligne(z)
Next z
End If
End Sub
Sub TrouverIndices(ByRef arr() As Double, ByVal arrayName As String)
Dim i As Long
Dim L As Long, U As Long
L = LBound(arr)
U = UBound(arr)
' On suppose ici que le tableau contient exactement 4 valeurs.
If (U - L + 1) <> 4 Then
Debug.Print "Le tableau " & arrayName & " ne contient pas 4 valeurs."
Exit Sub
End If
' Recherche de l'indice de la valeur minimale
Dim minIndex As Long
minIndex = L
For i = L To U
If arr(i) < arr(minIndex) Then
minIndex = i
End If
Next i
' On va maintenant repérer les indices des 3 valeurs restantes
Dim idx1 As Long, idx2 As Long, idx3 As Long
Dim compteur As Long
compteur = 0
For i = L To U
If i <> minIndex Then
Select Case compteur
Case 0: idx1 = i
Case 1: idx2 = i
Case 2: idx3 = i
End Select
compteur = compteur + 1
End If
Next i
' Vérification parmi les 3 valeurs restantes pour trouver une paire identique
Dim trouveDupli As Boolean
trouveDupli = False
If (arr(idx1) = arr(idx2)) And (arr(idx1) <> arr(idx3)) Then
dupIndex1 = idx1
dupIndex2 = idx2
uniqueIndex = idx3
trouveDupli = True
ElseIf (arr(idx1) = arr(idx3)) And (arr(idx1) <> arr(idx2)) Then
dupIndex1 = idx1
dupIndex2 = idx3
uniqueIndex = idx2
trouveDupli = True
ElseIf (arr(idx2) = arr(idx3)) And (arr(idx2) <> arr(idx1)) Then
dupIndex1 = idx2
dupIndex2 = idx3
uniqueIndex = idx1
trouveDupli = True
End If
' Affichage des résultats dans la fenêtre Immediate
Debug.Print "------ Tableau " & arrayName & " ------"
Debug.Print "Indice de la valeur minimale : " & minIndex & " (valeur : " & arr(minIndex) & ")"
If trouveDupli Then
Debug.Print "Indices des valeurs identiques : " & dupIndex1 & " et " & dupIndex2 & " (valeur : " & arr(dupIndex1) & ")"
Debug.Print "Indice de la valeur unique : " & uniqueIndex & " (valeur : " & arr(uniqueIndex) & ")"
Else
Debug.Print "Aucune paire de valeurs identiques n'a été trouvée parmi les 3 restantes."
End If
End Sub
