Hallo
Ik heb verschillende assemblages van 150 onderdelen, en ik ben op zoek naar een macro die door alle onderdelen gaat, ze bewerkt, de functieherkenning doet, opslaat, sluit en doorgaat naar de volgende. om niet alles handmatig te doen.
Ik heb verschillende dingen geprobeerd, maar ik kan mijn importbody niet selecteren om de herkenning te starten. ect wat je zou hebben een oplossing.
Option Explicit
' ------------------------------------------------------------------
' Macro : Reconnaissance_Fonctions_Assemblage.swp
' ------------------------------------------------------------------
Dim swApp As SldWorks.SldWorks
Dim processed As Collection
Const swActivateDocOptions_Silent As Long = 1
Const swActivateDocError_NoError As Long = 0
'====================== Point d’entrée ============================
Sub main()
Dim swModel As ModelDoc2
Dim swAssy As AssemblyDoc
Dim vComps As Variant
Dim swComp As Component2
Dim compPath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Or swModel.GetType <> swDocASSEMBLY Then
MsgBox "Veuillez d’abord ouvrir un assemblage (*.SLDASM).", vbExclamation
Exit Sub
End If
Set swAssy = swModel
vComps = swAssy.GetComponents(True)
Set processed = New Collection
Dim i As Long
For i = LBound(vComps) To UBound(vComps)
Set swComp = vComps(i)
If Not swComp.IsSuppressed Then
compPath = swComp.GetPathName
If LCase$(compPath) Like "*.sldprt" Then
AddIfNewAndProcess compPath
End If
End If
Next i
MsgBox "Traitement terminé !", vbInformation
End Sub
'=================== Ajout + dispatch pièce ======================
Sub AddIfNewAndProcess(partPath As String)
On Error Resume Next
processed.Add partPath, partPath
If Err.Number = 0 Then
On Error GoTo 0
ProcessPart partPath
Else
Err.Clear
End If
End Sub
'================== Traitement individuel pièce ==================
Sub ProcessPart(partPath As String)
Dim partDoc As ModelDoc2
Dim featApp As FeatureWorks.IFeatureWorksApp
Dim feat As Feature
Dim errs As Long, warns As Long, actErr As Long, loadStat As Long
'--- 1. Ouvrir la pièce
Set partDoc = swApp.OpenDoc6(partPath, swDocPART, swOpenDocOptions_Silent, "", errs, warns)
If partDoc Is Nothing Then Exit Sub
'--- 2. Activer la pièce
Dim activated As ModelDoc2
Set activated = swApp.ActivateDoc3(partDoc.GetTitle, False, swActivateDocOptions_Silent, actErr)
If actErr <> swActivateDocError_NoError Then GoTo CleanUp
partDoc.ClearSelection2 True
'--- 3. Charger FeatureWorks
Set featApp = swApp.GetAddInObject("FeatureWorks.FeatureWorksApp")
If featApp Is Nothing Then
loadStat = swApp.LoadAddIn("FeatureWorks")
If loadStat = 0 Then
Set featApp = swApp.GetAddInObject("FeatureWorks.FeatureWorksApp")
End If
End If
If featApp Is Nothing Then GoTo CleanUp
'--- 4. Trouver et sélectionner la fonction "Imported"
Set feat = FindImportedFeature(partDoc)
If feat Is Nothing Then GoTo CleanUp
feat.Select2 False, 0 ' Sélectionne le corps importé
'--- 5. Lancer la reconnaissance automatique
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs + fwBaseFlange + fwSketchedBend + _
fwAutoEdgeFlange + fwAutoHemFlange
Dim vRes As Variant
vRes = featApp.RecognizeFeatureAutomatic(optAll)
'--- 6. Créer les fonctions reconnues
Const createOpt As Long = fwAllowFailFeatureCreation
featApp.CreateFeatures createOpt
CleanUp:
'--- 7. Sauvegarder et fermer
partDoc.Save3 swSaveAsOptions_Silent, errs, warns
swApp.CloseDoc partDoc.GetTitle
End Sub
'============= Trouver la fonction "Imported" dans l'arbre =========
Function FindImportedFeature(doc As ModelDoc2) As Feature
Dim feat As Feature
Set feat = doc.FirstFeature
Do While Not feat Is Nothing
Debug.Print "Feature : " & feat.Name & " / Type = " & feat.GetTypeName2
If feat.GetTypeName2 = "Imported" Or feat.GetTypeName2 = "BaseBody" Then
Debug.Print "? Fonction Importée trouvée : " & feat.Name
Set FindImportedFeature = feat
Exit Function
End If
Set feat = feat.GetNextFeature
Loop
Debug.Print "Aucune fonction 'Imported' ou 'BaseBody' trouvée dans : " & doc.GetPathName
Set FindImportedFeature = Nothing
End Function
1 like
Hallo
Het probleem lijkt te zitten in de activering van FeatureWorks.
Zoals gecodeerd (en ook gepresenteerd in de API-help) is SW niet in staat om de invoegtoepassing te activeren, vandaar het mislukken van de macro (die stopt op deze regel: If featApp Is Nothing Then GoTo CleanUp)
Bewerken: Door FeatureWorks handmatig in te schakelen, gaat de macro door met verwerken
1 like
De invoegtoepassing My featureworks is echter standaard ingeschakeld
1 like
Re
Ik heb het opnieuw getest, dus de functie verwacht op het eerste gezicht een selectie van het gezicht en niet van het lichaam.
Het is daarom noodzakelijk om aan te passen om een gezicht te herstellen.
2 likes
Tenzij je alleen kubussen of cilinders hebt, is het gedurfd om automatische herkenning te gebruiken op een batch onderdelen.
Al in de handmatigheid, stuk voor stuk (en functie voor functie) ben ik er nooit in geslaagd om iets schoons terug te krijgen.
1 like
Dat heb ik weten te krijgen.
Het werkt goed, maar ik zou niet de plaatwerkfuncties willen, alleen de standaardfuncties.
en ik kan ze niet uitdoen. Als ik de plaatwerkfunctie uit de code in blok 5 haal, herkent deze helemaal niets. Ik begrijp niet waarom
' 5. Reconnaissance automatique avec tolerie
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs + fwBaseFlange + fwSketchedBend + _
fwAutoEdgeFlange + fwAutoHemFlange
featApp.RecognizeFeatureAutomatic optAll
' 5. Reconnaissance automatique sans tolerie
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs
featApp.RecognizeFeatureAutomatic optAll
Option Explicit
' ------------------------------------------------------------------
' Macro : Reconnaissance_Fonctions_Assemblage.swp
' ------------------------------------------------------------------
Dim swApp As SldWorks.SldWorks
Dim processed As Collection
Const swActivateDocOptions_Silent As Long = 1
Const swActivateDocError_NoError As Long = 0
'====================== Point d’entrée ============================
Sub main()
Dim swModel As ModelDoc2, swAssy As AssemblyDoc
Dim vComps As Variant, swComp As Component2
Dim compPath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Or swModel.GetType <> swDocASSEMBLY Then
MsgBox "Ouvrez d’abord un assemblage (*.SLDASM).", vbExclamation
Exit Sub
End If
Set swAssy = swModel
vComps = swAssy.GetComponents(True) ' récursif
Set processed = New Collection
Dim i As Long
For i = LBound(vComps) To UBound(vComps)
Set swComp = vComps(i)
If Not swComp.IsSuppressed Then
compPath = swComp.GetPathName
If LCase$(compPath) Like "*.sldprt" Then _
AddIfNewAndProcess compPath
End If
Next i
MsgBox "Traitement terminé !", vbInformation
End Sub
'=================== Évite les doublons ===========================
Sub AddIfNewAndProcess(partPath As String)
On Error Resume Next
processed.Add partPath, partPath
If Err.Number = 0 Then
On Error GoTo 0
ProcessPart partPath
Else
Err.Clear
End If
End Sub
'================== Traitement individuel =========================
Sub ProcessPart(partPath As String)
Dim partDoc As ModelDoc2, featApp As FeatureWorks.IFeatureWorksApp
Dim errs As Long, warns As Long, actErr As Long
' 1. Ouvrir la pièce
Set partDoc = swApp.OpenDoc6(partPath, swDocPART, _
swOpenDocOptions_Silent, "", errs, warns)
If partDoc Is Nothing Then Exit Sub
' 2. Activer la fenêtre
Dim activated As ModelDoc2
Set activated = swApp.ActivateDoc3(partDoc.GetTitle, False, _
swActivateDocOptions_Silent, actErr)
If actErr <> swActivateDocError_NoError Then GoTo CleanUp
partDoc.ClearSelection2 True
partDoc.ForceRebuild3 False ' assure noms & corps
' 3. Obtenir FeatureWorks (déjà chargé)
Set featApp = swApp.GetAddInObject("FeatureWorks.FeatureWorksApp")
If featApp Is Nothing Then GoTo CleanUp
' 4. Sélectionner la première face du premier corps solide
Dim swPart As partDoc, body As Body2, faces As Variant, face As Face2
Dim status As Boolean
Set swPart = partDoc
faces = Empty
Dim bodies As Variant
bodies = swPart.GetBodies2(swSolidBody, False)
If IsEmpty(bodies) Then GoTo CleanUp
Set body = bodies(0)
faces = body.GetFaces
If IsEmpty(faces) Then GoTo CleanUp
Set face = faces(0)
status = face.Select2(False, 0)
If Not status Then GoTo CleanUp ' impossible de sélectionner
' 5. Reconnaissance automatique
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs + fwBaseFlange + fwSketchedBend + _
fwAutoEdgeFlange + fwAutoHemFlange
featApp.RecognizeFeatureAutomatic optAll
' 6. Créer les fonctions
Const createOpt As Long = fwAllowFailFeatureCreation
featApp.CreateFeatures createOpt
CleanUp:
' 7. Sauvegarder & fermer
partDoc.Save3 swSaveAsOptions_Silent, errs, warns
swApp.CloseDoc partDoc.GetTitle
End Sub
1 like
Ik zit in de timmerindustrie, het zijn alleen meubels, dus rechthoekige panelen met basis boren en bewerken, en ik heb de erkenning nodig om mijn bewerking toe te passen met SWOODCAM erachter
1 like
Hallo, door het verwijderen van fwSketchedBend heb ik nog steeds de plaatwerkfunctie
Idealiter zou ik gewoon dit nodig hebben:
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs
featApp.RecognizeFeatureAutomatic optAll
behalve dat als ik de andere verwijder, het niet meer werkt, er gebeurt niets tijdens de behandeling
Hallo;
Ik vraag me af of we niet moeten beginnen met het ordenen van de functies die moeten worden herkend in de feaureWorks-opties.
Wat zijn de instellingen thuis (of " thuis ", ik weet nooit of het eenvoudiger/hartelijker is om "tu" of "tu") te gebruiken)...
Hallo
Ik heb momenteel dezelfde instellingen als jij, wat volgens mij de standaard moeten zijn