Hallo
Ik wil graag aan het einde van mijn macro die ik heb gemaakt, de functie Alles verzamelen toevoegen.
maar ik kan er niet achter komen hoe ik deze functie in VBA moet aanroepen en gebruiken. niet te vinden in de API
Heeft iemand een idee?
Is er een vereenvoudigd bestand dat alle SW-functies opsomt en hoe ze zich in VBA bevinden?
Hallo
Ik heb (lang) tevergeefs gezocht naar deze vba functie.
Om af te sluiten met deze code die helemaal niet is wat ik wilde, maar die werkt:
'Rassembler l'arbre de création
SendKeys "{ESC}"
SendKeys "+{R}"
En in de snelkoppelingen:
Dit is natuurlijk een omweg, aangezien deze code alleen een snelkoppeling lanceert. Wees voorzichtig: in de bewerkingsmodus schrijft deze code een R in de code!.
Zo verre van optimaal, maar niets beters.
Alle andere VBA-code om de boom te verzamelen is veel te lang in de tijd
Voorbeeld:
'---------------------------------------------------------------------------
' 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
Veel succes met je zoektocht en als je beter vindt, deel het dan alsjeblieft!
Hallo, bedankt voor het antwoord.
Momenteel doe ik hetzelfde: SendKeys " +c ", behalve dat wanneer ik de code uitvoer, het mijn Num-vergrendeling deactiveert of mijn caplock uitschakelt. dus ik heb SendKeys " {NUMLOCK} " net hieronder toegevoegd, maar van tijd tot tijd werkt het niet en deactiveert het nog steeds, het is verschrikkelijk ...
Ik zal proberen te graven om te zien of ik het vind
Het doet hetzelfde op de werkplek van een collega, op alle andere werkstations geen zorgen.
Nooit begrepen waarom...
Bonjour
Ce code non? Voorbeeld van FeatureManager-ontwerpstructuurknooppunten (VBA) uitvouwen of samenvouwen - 2024 - SOLIDWORKS API Help
Ja, @Cyril_f deze code is degene die ik in mijn 1e bericht heb gezet, het werkt goed, maar het is veel langzamer dan de gevraagde functie (gaat door de hele boom).
@Edouard_B lijkt het erop dat door het toevoegen van , trouw aan sendkeys, het ontgrendelen van de caps lock wordt vermeden:
SendKeys "+c", True
Ik heb net de test door het toevoegen van de True en ik heb geen verandering op mijn pc, 
het deactiveert nog steeds de mijn NumLock
Ik heb dit commando getest:
Set WshShell = CreateObject("WScript.Shell")
WshShell.SendKeys "+R", True
In plaats van:
SendKeys "+c", True
En het werkt ook en het lijkt erop dat deze methode de bug vermijdt, aangezien ik niet kan testen op mijn pc die deze bug niet heeft, het is aan jou om te proberen het proefkonijn te zijn!
Ik heb net de cavia gespeeld en het resultaat is altijd hetzelfde
Ik heb een code gevonden die werkt en mijn Numlock en caplock niet meer uitschakelt:
' === 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
Bedankt voor het delen, ik zal de methode intern testen, als mijn collega niet meer klaagt, is dat omdat het werkt!
Ik heb ook dit 
gevonden dat de boom naar het 1e niveau verzamelt zonder sendkeys te gebruiken
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