Hallo
Ich möchte am Ende meines Makros, das ich erstellt habe, die Funktion "Alle sammeln" hinzufügen.
aber ich kann nicht herausfinden, wie ich diese Funktion in VBA aufrufen und verwenden kann. nicht in der API zu finden
Hat jemand eine Idee?
Gibt es eine vereinfachte Datei, die alle SW-Funktionen und deren Zustand in VBA auflistet?
Hallo
Diese VBA-Funktion habe ich (lange) vergeblich gesucht.
Um mit diesem Code abzuschließen, der überhaupt nicht das ist, was ich wollte, der aber funktioniert:
'Rassembler l'arbre de création
SendKeys "{ESC}"
SendKeys "+{R}"
Und in den Tastenkombinationen:
Natürlich ist dies ein Umweg, da dieser Code nur eine Verknüpfung startet. Seien Sie vorsichtig, im Bearbeitungsmodus schreibt dieser Code ein R in den Code!.
So weit davon entfernt, optimal zu sein, aber nichts Besseres.
Alle anderen VBA-Codes zum Sammeln des Baums sind viel zu lang in der Zeit
Beispiel:
'---------------------------------------------------------------------------
' 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
Viel Glück bei Ihrer Suche und wenn Sie etwas Besseres finden, teilen Sie es bitte!
Hallo, danke für die Antwort.
Derzeit mache ich dasselbe: SendKeys " +c ", außer dass beim Ausführen des Codes meine Num-Sperre deaktiviert oder meine Feststelltaste deaktiviert wird. also habe ich SendKeys " {NUMLOCK} " direkt unten hinzugefügt, aber von Zeit zu Zeit funktioniert es nicht und deaktiviert sich immer noch, es ist schrecklich ...
Ich werde versuchen zu graben, um zu sehen, ob ich
Das Gleiche tut es auf dem Arbeitsplatz eines Kollegen, auf allen anderen Arbeitsplätzen keine Sorge.
Ich habe nie verstanden, warum...
Bonjour
CE-Code nicht? Erweitern oder Reduzieren von FeatureManager – Beispiel für Konstruktionsbaumknoten (VBA) - 2024 - SOLIDWORKS API-Hilfe
Ja , @Cyril_f dieser Code ist derjenige, den ich in meinem 1. Beitrag eingefügt habe, er funktioniert gut, aber er ist viel langsamer als die angeforderte Funktion (geht durch den gesamten Baum).
@Edouard_B scheint es, dass durch das Hinzufügen von , true zu sendkeys das Entsperren der Feststelltaste vermieden wird:
SendKeys "+c", True
Ich habe gerade den Test gemacht, indem ich das True hinzugefügt habe, und ich habe keine Änderung auf meinem PC 
, es deaktiviert immer noch mein NumLock
Ich habe diesen Befehl getestet:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "+R", True
Statt:
SendKeys "+c", True
Und es funktioniert auch und es scheint, dass diese Methode den Fehler vermeidet, da ich nicht auf meinem PC testen kann, ohne diesen Fehler zu haben, es liegt an Ihnen, zu versuchen, das Versuchskaninchen zu sein!
Ich habe gerade das Versuchskaninchen gespielt, und das Ergebnis ist immer das gleiche
Ich habe einen Code gefunden, der funktioniert und meine Numlock und Caplock nicht mehr deaktiviert:
' === 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
Vielen Dank für das Teilen, ich werde die Methode intern testen, wenn mein Kollege sich nicht mehr beschwert, liegt das daran, dass sie funktioniert!
Ich habe auch dies 
gefunden, das den Baum auf die 1. Ebene sammelt, ohne Sendkeys zu verwenden
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