Bonjour,
Je voudrais ajouter à la fin de ma macro que j’ai créé, la fonction Rassembler tout.
mais je n’arrive pas à trouver comment faire en VBA pour appeler cette fonction et l’utiliser. impossible a trouver dans l’API
Est-ce que quelqu’un aurait une idée ?
Existe t’il un fichier simplifier qui répertorie toutes les fonction SW et comment elles sont en VBA ?
Bonjour,
J’ai (longtemps) cherché cette fonction vba en vain.
Pour finir avec ce code qui n’est pas ce que je souhaitais du tout mais qui fonctionne:
'Rassembler l'arbre de création
SendKeys "{ESC}"
SendKeys "+{R}"
Et dans les racccourcis:
Bien entendu c’est un moyen détourner puisque ce code ne fait que lancer un raccourcis. Attention en mode édition ce code écrit un R dans le code!.
Donc loin d’être optimal mais rien trouvé de mieux.
Tout les autre code vba pour rassemblé l’arbre étant beaucoup trop long en temps
Exemple:
'---------------------------------------------------------------------------
' Preconditions:
' 1. Open a part or assembly document.
' 2. Open the Immediate window.
'
' Postconditions:
' 1. Expands all of the FeatureManager design tree nodes.
' 2. Click OK to collapse all nodes.
' 3. Inspect the Immediate window.
'--------------------------------------------------------------------------
Option Explicit
Dim traverseLevel As Integer
Dim expandThis As Boolean
Sub main()
Dim i As Integer
Dim swApp As SldWorks.SldWorks
Dim myModel As SldWorks.ModelDoc2
Dim featureMgr As SldWorks.FeatureManager
Dim rootNode As SldWorks.TreeControlItem
Set swApp = Application.SldWorks
Set myModel = swApp.ActiveDoc
Set featureMgr = myModel.FeatureManager
Set rootNode = featureMgr.GetFeatureTreeRootItem2(swFeatMgrPaneBottom)
expandThis = True
For i = 0 To 1
If Not rootNode Is Nothing Then
Debug.Print
traverseLevel = 0
traverse_node rootNode
End If
expandThis = False
If i = 0 Then
MsgBox "OK to collapse all nodes?"
End If
Next
End Sub
Private Sub traverse_node(node As SldWorks.TreeControlItem)
Dim childNode As SldWorks.TreeControlItem
Dim featureNode As SldWorks.Feature
Dim componentNode As SldWorks.Component2
Dim nodeObjectType As Long
Dim nodeObject As Object
Dim restOfString As String
Dim indent As String
Dim i As Integer
Dim displayNodeInfo As Boolean
Dim compName As String
Dim suppr As Long, supprString As String
Dim vis As Long, visString As String
Dim fixed As Boolean, fixedString As String
Dim componentDoc As Object, docString As String
Dim refConfigName As String
displayNodeInfo = False
nodeObjectType = node.ObjectType
Set nodeObject = node.Object
Select Case nodeObjectType
Case SwConst.swTreeControlItemType_e.swFeatureManagerItem_Feature:
displayNodeInfo = True
If Not nodeObject Is Nothing Then
Set featureNode = nodeObject
restOfString = "[FEATURE: " & featureNode.Name & "]"
Else
restOfString = "[FEATURE: object Null?!]"
End If
Case SwConst.swTreeControlItemType_e.swFeatureManagerItem_Component:
displayNodeInfo = True
If Not nodeObject Is Nothing Then
Set componentNode = nodeObject
compName = componentNode.Name2
If (compName = "") Then
compName = "???"
End If
suppr = componentNode.GetSuppression
Select Case (suppr)
Case SwConst.swComponentSuppressionState_e.swComponentFullyResolved
supprString = "Resolved"
Case SwConst.swComponentSuppressionState_e.swComponentLightweight
supprString = "Lightweight"
Case SwConst.swComponentSuppressionState_e.swComponentSuppressed
supprString = "Suppressed"
End Select
vis = componentNode.Visible
Select Case (vis)
Case SwConst.swComponentVisibilityState_e.swComponentHidden
visString = "Hidden"
Case SwConst.swComponentVisibilityState_e.swComponentVisible
visString = "Visible"
End Select
fixed = componentNode.IsFixed
If fixed = 0 Then
fixedString = "Floating"
Else
fixedString = "Fixed"
End If
Set componentDoc = componentNode.GetModelDoc2
If componentDoc Is Nothing Then
docString = "NotLoaded"
Else
docString = "Loaded"
End If
refConfigName = componentNode.ReferencedConfiguration
If (refConfigName = "") Then
refConfigName = "???"
End If
restOfString = "[COMPONENT: " & compName & " " & docString & " " & supprString & " " & visString & " " & refConfigName & "]"
Else
restOfString = "[COMPONENT: object Null?!]"
End If
Case Else:
displayNodeInfo = True
If Not nodeObject Is Nothing Then
restOfString = "[object type not handled]"
Else
restOfString = "[object Null?!]"
End If
End Select
For i = 1 To traverseLevel
indent = indent & " "
Next i
If (displayNodeInfo) Then
Debug.Print indent & node.Text & " : " & restOfString
End If
' Expand the node
node.Expanded = expandThis
traverseLevel = traverseLevel + 1
Set childNode = node.GetFirstChild
While Not childNode Is Nothing
Debug.Print indent & "Node is expanded: " & childNode.Expanded
traverse_node childNode
Set childNode = childNode.GetNext
Wend
traverseLevel = traverseLevel - 1
End Sub
Bon courage dans ta recherche et si tu trouves mieux merci de partager!
Bonjour, merci pour la réponse.
Actuellement je fais pareil : SendKeys « +c » sauf que quand j’exécute le code il me désactive mon verr Num ou désactive mon caplock. alors j’ai rajouter SendKeys « {NUMLOCK} » juste en dessous mais de temps en temps il ne passe pas et désactive quand même c’est horrible…
Je vais essayé de creuser pour voir si je trouve
Cela fait pareil sur le poste d’un collègue, sur tout les autres poste pas de soucis.
Jamais compris pourquoi…
Bonjour,
Oui @Cyril_f ce code est celui que j’ai mis dans mon 1er post, il fonctionne bien mais il est beaucoup plus lent que la fonction demandé (parcours toute l’arborescence).
@Edouard_B il semblerais que en ajoutant , true à sendkeys cela évite le déverrouillage du caps lock:
SendKeys "+c", True
Je viens de faire le test en rajoutant le True et je n’ai aucun changement sur mon PC 
il désactive toujours le mon VerrNum
J’ai tester cette commande:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "+R", True
En lieu et place de :
SendKeys "+c", True
Et cela fonctionne aussi et il semblerait que cette méthode évite le bug, comme je ne peux pas tester sur mon PC n’ayant pas ce bug, à toi d’essayer et de faire le cobaye!
Je viens de faire le cobaye, et le résultat est toujours pareil
j’ai trouvé un code qui fonctionne et ne désactive plus mon verrNum et caplock :
' === Déclarations Windows API (64 bits uniquement) ===
Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
' === Fonction pour vérifier si une touche est active ===
Function IsLockOn(vkKey As Long) As Boolean
IsLockOn = CBool(GetKeyState(vkKey) And 1)
End Function
' === Fonction pour activer ou désactiver une touche de verrouillage ===
Sub SetLockKey(vkKey As Long, shouldBeOn As Boolean)
If IsLockOn(vkKey) <> shouldBeOn Then
keybd_event vkKey, &H45, KEYEVENTF_EXTENDEDKEY, 0
keybd_event vkKey, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
End Sub
Sub Rassembler()
Const VK_NUMLOCK As Long = &H90
Const VK_CAPITAL As Long = &H14
Const VK_SCROLL As Long = &H91
Const KEYEVENTF_EXTENDEDKEY As Long = &H1
Const KEYEVENTF_KEYUP As Long = &H2
' Sauvegarder les états initiaux
Dim initialNumLock As Boolean
Dim initialCapsLock As Boolean
Dim initialScrollLock As Boolean
initialNumLock = IsLockOn(VK_NUMLOCK)
initialCapsLock = IsLockOn(VK_CAPITAL)
initialScrollLock = IsLockOn(VK_SCROLL)
' Envoi de touches
SendKeys "+c", True
' Restaurer les états initiaux
SetLockKey VK_NUMLOCK, initialNumLock
SetLockKey VK_CAPITAL, initialCapsLock
SetLockKey VK_SCROLL, initialScrollLock
End sub
Merci pour le partage je vais tester la méthode en interne, si mon collègue ne râle plus, c’est que cela fonctionne!
j’ai aussi trouvé ça 
qui rassemble l’arbre au 1er niveau sans utiliser de sendkeys
Sub CollapseTopLevelOnly()
Dim swApp As SldWorks.SldWorks
Dim model As SldWorks.ModelDoc2
Dim featMgr As SldWorks.FeatureManager
Dim rootNode As SldWorks.TreeControlItem
Dim childNode As SldWorks.TreeControlItem
Set swApp = Application.SldWorks
Set model = swApp.ActiveDoc
If model Is Nothing Then
MsgBox "Aucun document actif"
Exit Sub
End If
Set featMgr = model.FeatureManager
Set rootNode = featMgr.GetFeatureTreeRootItem2(swFeatMgrPaneBottom)
If Not rootNode Is Nothing Then
Set childNode = rootNode.GetFirstChild
Do While Not childNode Is Nothing
childNode.Expanded = False
Set childNode = childNode.GetNext
Loop
End If
End Sub