Hallo
Ich habe mehrere Baugruppen mit 150 Teilen und suche nach einem Makro, das alle Teile durchläuft, sie bearbeitet, die Funktionserkennung durchführt, speichert, schließt und zum nächsten übergeht. um nicht alles manuell zu machen.
Ich habe mehrere Dinge ausprobiert, aber ich kann meinen Importkörper nicht auswählen, um die Erkennung zu starten. ect, was Sie eine Lösung hätten.
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 „Gefällt mir“
Hallo
Das Problem scheint in der Aktivierung von FeatureWorks zu liegen.
Wie codiert (und auch in der API-Hilfe dargestellt), ist SW nicht in der Lage, das Add-In zu aktivieren, daher der Fehler des Makros (das in dieser Zeile stoppt: If featApp Is Nothing Then GoTo CleanUp)
Bearbeiten: Durch manuelles Aktivieren von FeatureWorks wird die Verarbeitung des Makros fortgesetzt
1 „Gefällt mir“
Mein FeatureWorks-Add-In ist jedoch standardmäßig aktiviert
1 „Gefällt mir“
Re
Ich habe erneut getestet, daher erwartet die Funktion auf den ersten Blick eine Auswahl des Gesichts und nicht des Körpers.
Es ist daher notwendig, eine Änderung vorzunehmen, um eine Fläche wiederherzustellen.
2 „Gefällt mir“
Wenn Sie nicht nur Würfel oder Zylinder haben, ist es gewagt, die automatische Erkennung auf eine Charge von Teilen anzuwenden.
Schon in manueller Arbeit Stück für Stück (und Funktion für Funktion) habe ich es noch nie geschafft, etwas Sauberes wiederherzustellen.
1 „Gefällt mir“
Das habe ich geschafft.
Es funktioniert gut, aber ich würde nicht wollen, dass die Blechfunktionen nur die Standardfunktionen sind.
und ich kann sie nicht ausziehen. Wenn ich die Blechfunktion aus dem Code in Block 5 entferne, wird sie überhaupt nicht erkannt. Ich verstehe nicht, warum
' 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 „Gefällt mir“
Ich bin in der Tischlerei, es sind nur Möbel, also rechteckige Paneele mit grundlegenden Bohrungen und Bearbeitungen, und ich brauche die Anerkennung, um meine Bearbeitung mit SWOODCAM dahinter anzuwenden
1 „Gefällt mir“
Hallo, durch das Entfernen von fwSketchedBend habe ich immer noch die Blechfunktion
Im Idealfall bräuchte ich nur das:
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs
featApp.RecognizeFeatureAutomatic optAll
außer dass es nicht mehr funktioniert, wenn ich die anderen entferne, nichts in der Behandlung passiert
Hallo;
Ich frage mich, ob wir nicht damit beginnen sollten, die Funktionen zu sortieren, die in den feaureWorks-Optionen erkannt werden sollen.
Was sind die Einstellungen zu Hause (oder " zu Hause ", ich weiß nie, ob es einfacher/herzlicher ist, "tu" oder "tu" zu verwenden)...
Hallo
Ich habe derzeit die gleichen Einstellungen wie Sie, was die Standardeinstellungen sein müssen, denke ich