Witam
Na końcu utworzonego przeze mnie makra chciałbym dodać funkcję Zbierz wszystko.
ale nie mogę wymyślić, jak wywołać tę funkcję w VBA i jej używać. nie można znaleźć w API
Czy ktoś ma pomysł?
Czy istnieje uproszczony plik, który zawiera listę wszystkich funkcji oprogramowania i ich przebieg w VBA?
Witam
Na próżno szukałem (długo) tej funkcji vba.
Kończąc z tym kodem, który wcale nie jest tym, czego chciałem, ale który działa:
'Rassembler l'arbre de création
SendKeys "{ESC}"
SendKeys "+{R}"
A w skrótach:
Oczywiście jest to okrężna droga, ponieważ ten kod uruchamia tylko skrót. Bądź ostrożny w trybie edycji, ten kod zapisuje R w kodzie!.
Tak daleko od optymalnego, ale nic lepszego.
Cały inny kod vba do zebrania drzewa jest o wiele za długi w czasie
Przykład:
'---------------------------------------------------------------------------
' 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
Powodzenia w poszukiwaniach, a jeśli znajdziesz lepsze, podziel się!
Witam, dziękuję za odpowiedź.
Obecnie robię to samo: SendKeys " + c "z tą różnicą, że kiedy wykonuję kod, dezaktywuje mój Num lock lub wyłącza mój caplock. więc dodałem SendKeys " {NUMLOCK} " tuż poniżej, ale od czasu do czasu nie działa i nadal dezaktywuje się, to okropne...
Postaram się kopać, aby zobaczyć, czy znajdę
Robi to samo na stacji roboczej kolegi, na wszystkich innych stacjach roboczych bez obaw.
Nigdy nie rozumiałem dlaczego...
Bonjour
Kod CE nie? Rozwijanie lub zwijanie węzłów drzewa operacji FeatureManager — przykład (VBA) - 2024 - Pomoc SOLIDWORKS API
Tak , @Cyril_f ten kod jest tym, który umieściłem w moim 1. poście, działa dobrze, ale jest znacznie wolniejszy niż żądana funkcja (przechodzi przez całe drzewo).
@Edouard_B wydawać by się mogło, że dodając do sendkeys , true unika się odblokowania Caps Locka:
SendKeys "+c", True
Właśnie zrobiłem test, dodając True i nie mam żadnych zmian na moim komputerze 
, nadal dezaktywuje mój NumLock
Przetestowałem to polecenie:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "+R", True
Zamiast:
SendKeys "+c", True
I to też działa i wygląda na to, że ta metoda pozwala uniknąć błędu, ponieważ nie mogę przetestować na moim komputerze bez tego błędu, to od Ciebie zależy, czy spróbujesz zostać królikiem doświadczalnym!
Właśnie grałem w królika doświadczalnego, a wynik jest zawsze taki sam
Znalazłem kod, który działa i już nie wyłącza mojego Numlocka i caplocka:
' === 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
Dziękuję za udostępnienie, przetestuję metodę wewnętrznie, jeśli kolega już nie narzeka, to dlatego, że działa!
Znalazłem również to 
, co zbiera drzewo do 1. poziomu bez użycia kluczy wysyłania
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