Witam
Mam kilka zespołów po 150 części i szukam makra, które przechodzi przez wszystkie części, działa je, rozpoznaje funkcję, zapisuje, zamyka i przechodzi do następnej. aby nie robić wszystkiego ręcznie.
Próbowałem kilku rzeczy, ale nie mogę wybrać treści importu, aby rozpocząć rozpoznawanie. ect, jakie miałbyś rozwiązanie.
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 polubienie
Witam
Wydaje się, że problem tkwi w aktywacji FeatureWorks.
Zgodnie z kodem (i również przedstawionym w pomocy API) oprogramowanie nie jest w stanie aktywować dodatku, stąd awaria makra (które zatrzymuje się w tym wierszu: If featApp Is Nothing Then GoTo CleanUp)
Edycja: Po ręcznym włączeniu funkcji FeatureWorks, makro kontynuuje przetwarzanie
1 polubienie
Mój dodatek featureworks jest jednak domyślnie włączony
1 polubienie
Ponownie
Ponownie przetestowałem, więc funkcja oczekuje na pierwszy rzut oka wyboru twarzy, a nie ciała.
W związku z tym konieczna jest modyfikacja w celu odzyskania twarzy.
2 polubienia
O ile nie masz tylko sześcianów lub cylindrów, odważne jest użycie automatycznego rozpoznawania partii części.
Już w manualu kawałek po kawałku (i funkcja po funkcji) nigdy nie udało mi się odzyskać czegoś czystego.
1 polubienie
Udało mi się to zdobyć.
Działa dobrze, ale nie chciałbym, aby funkcje blachy były tylko standardowe funkcje.
i nie mogę ich zdjąć. Gdy usunę funkcję arkusza blachy z kodu w bloku 5, w ogóle nie rozpoznaje. Nie rozumiem dlaczego
' 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 polubienie
Zajmuję się stolarstwem, to tylko meble, a więc prostokątne panele z podstawowym wierceniem i obróbką skrawaniem, a ja potrzebuję uznania, aby zastosować moją obróbkę za pomocą SWOODCAM z tyłu
1 polubienie
Witam, usuwając fwSketchedBend nadal mam funkcję blachy
Idealnie byłoby mi po prostu tego:
Const optAll As Long = _
fwExtrudeOption + fwVolume + fwRevolve + fwHoles + _
fwChamfils + fwRibs
featApp.RecognizeFeatureAutomatic optAll
z tym, że jak usunę inne to już nie działa, nic się nie dzieje w kuracji
Witam;
Zastanawiam się, czy nie powinniśmy zacząć od uporządkowania funkcji, które mają być rozpoznawane w opcjach feaureWorks.
Jakie są ustawienia w domu (lub " w domu ", nigdy nie wiem, czy prościej / serdecznie jest używać "tu" czy "tu")...
Witam
Obecnie mam takie same ustawienia jak ty, które muszą być domyślne, jak sądzę