VBA - Ręczny wybór części do wytłoczenia

Out of category
1

Witam

Mam pewne pojęcia o VBA, wiedząc, że zrobiłem już wiele aplikacji w Excelu.

Z drugiej strony VBA SolidWorks, trochę się gówniam...

Mam jednego z moich klientów, który regularnie zamawia u mnie kadzie do ciągnięcia. Na wierzchu mam większość moich szwów. Tworzę makro, które automatycznie utworzy JEDNO ściegi. Otwieram formularz użytkownika z różnymi informacjami do wypełnienia, takimi jak kąt wiercenia, średnica, grubość kranu itp.

Jak na razie wszystko idzie dobrze, dostaję informacje, tworzę swój szkic, który cytuję. 

I tu właśnie się to zacina: chcę wybrać obiekt, w którym chcę zrobić dziurę, ponieważ nie mogę go nazwać bezpośrednio. Rzeczywiście, kiedy chcę umieścić kolejny ścieg, przedmiot, o którym mowa, zmieni swoją nazwę (idiota)!

Niestety, kiedy wybieram część, nie ma sposobu, aby odnieść sukces w wytłaczaniu!  i nie mogę znaleźć dlaczego!

Przedstawiam Wam fragment mojego kodu, który zawiera błędy (włożyłem cały skrypt, ale przekroczyłem limit 6000 znaków)

Jeśli ktoś ma pomysł i może mi go wytłumaczyć, jestem jak najbardziej za...


'*****************************************************
'Enlèvement matière
'*****************************************************

MsgBox "Sélection du cône à extruder"

Dim Feature As Object
Set Feature = Part.SelectionManager.GetSelectedObject6(1, 0)
Do While Feature Is Nothing
    DoEvents
    Set Feature = Part.SelectionManager.GetSelectedObject6(1, 0)
Loop

Dim myFeature As Object
Set myFeature = Part.FeatureManager.FeatureCut4(True, False, False, 1, 0, 0.01, 0.01, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, False, True, False, True, True, False, 0, 0, False, False)

 

2

Witam

Aby obejść limit liczby znaków, najprostszym sposobem jest udostępnienie pliku swp bezpośrednio jako załącznik.

Pozwoliłoby nam to przetestować i pomóc zrozumieć bez przerabiania całego fragmentu kodu :)

3

Witam

 

Ze swojej strony, gdy muszę wybrać elementy, używam tego typu kodu.

Dim featmananger As SldWorks.FeatureManager
Set featmananger = noeud.FeatureManager
Dim feat As SldWorks.Feature
Set feat = noeud.FirstFeature
Dim subfeat As SldWorks.Feature


Do While Not feat Is Nothing
    If feat.GetTypeName2 = "RefPlane" Then
        nb_plan = nb_plan + 1
    End If
    If feat.GetTypeName2 = "FtrFolder" Then
        Set subfeat = feat.GetFirstSubFeature
        Do While Not subfeat Is Nothing
            If subfeat.GetTypeName2 = "RefPlane" Then
                nb_plan = nb_plan + 1
            End If
        
        Loop
    End If
Set feat = feat.GetNextFeature
Loop

 

 

W tym przypadku wybieram płaszczyznę, ale to samo dzieje się ze ścianą, z którą pobierasz powiązaną funkcję.

 

Mam nadzieję, że to ci pomoże.

 

A. Mendes

 

4

Dziękuję za odpowiedź. 

@Cyril.F : Rzeczywiście, od razu to poprawię.

W PJ .prt, na którym eksperymentuję, i .swt

@A.Mendes : dzięki za fragment. Zamierzam to przetestować dziś wieczorem z wypoczętą głową, aby to zrozumieć.


00000000_test_cpr.sldprt
test_piquage.swp
5

@A.Mendes po przejrzeniu i przetestowaniu Twojego kodu nie sądzę, aby spełniał moje potrzeby: Próbuję kliknąć na obiekt, na który chcę wyciągnąć. Jeśli dobrze zrozumiałem Twój kod, sprawdza, czy Twój wybór jest typu, którego chcesz.

6

Wydaje się, że nie inspiruje wielu ludzi... Nadal patrzę w bok, ale wysycham z mocą! A to, co nie pomaga, to to, że w Internecie nie ma zbyt wielu samouczków ani wyjaśnień...

7

Witam

W tej chwili nie ma zbyt wiele czasu na testy. Miałem pierwszy przystanek makro na poniższej linii:

myDimension.SystemValue = Part.Parameter("rayon_ext@Esquisse1").SystemValue - (Distance_Bord_ / 1000)

Nie miałem czasu na dalsze śledztwo.

8

Oglądam dziś wieczorem, ale myślę, że musiałem się zawiesić w jednym z 2 dostarczonych plików. Pracuję nad 2 wersjami pomiędzy 2 szt... Krótko mówiąc, nie pomaga to w rozwiązaniu problemu. 

9

Witam;

Do wyboru części (w złożeniu) używam:

    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim SelObj As Object
    Dim swComp As SldWorks.Component2
    Dim sActiveConfigName As String
    Dim SelecNameS As String


Set SelObj = swSelMgr.GetSelectedObject6(1, -1)
    If TypeOf SelObj Is SldWorks.Component2 Then Set swComp = swSelMgr.GetSelectedObject6(1, -1) 'Si la selection est faite depuis l'arbre de creation
    If TypeOf SelObj Is SldWorks.Face2 Then Set swComp = swSelMgr.GetSelectedObjectsComponent3(1, -1) 'Si la selection est faite depuis une face
   
    SelecNameS = swComp.GetSelectByIDString      'Recuperation du Nom de la selection et du Nom du fichier actif
    sActiveConfigName = swComp.ReferencedConfiguration 'Recuperation du Nom de la configuration Active

 

Pozdrowienia

1 polubienie
10

Wczoraj wieczorem byłem trochę zajęty...

Dam Ci odpowiednie elementy w komputerze.

@Maclane: Nie wiem, czy to rozwiązuje mój problem, ale przetestuję. 


test_piquage.swp
test_piquage.sldprt
11

  @Ixxs71 Przepraszamy za opóźnienie w odpowiedzi.

Tak, w moim kodzie sprawdzam, czy wybór odpowiada moim potrzebom. Ale muszę go znaleźć, muszę mieć kod, który po kliknięciu na twarz go dostanie. Następnie powinieneś być w stanie odzyskać funkcję związaną z twarzą.

Staram się patrzeć jak najszybciej.

 

12

RE: Przyjrzałem się temu od razu, bo potem będzie to dla mnie bardzo skomplikowane

            ' boucle pour attente selection
    
                bool1 = False
                Do Until bool1 = True
                    If Selectmanager.GetSelectedObjectType3(1, -1) = 2 Then
                    bool1 = True
                    End If
                    For y = 1 To 50000
                    DoEvents
                    Next y
                Loop
    
            'recup le nom de la piece selectionnée
    
            Set face = Selectmanager.GetSelectedObject6(1, -1)
            Set faceEntity = face
            Set comp = faceEntity.GetComponent
            'Debug.Print comp.Name2
            Set ossature = comp
            Set ossaturemodeldoc = ossature.GetModelDoc2
            oss = comp.Name2

 

Dla mnie, jeśli testujesz zamiast faceentity.getcomponent linię

set function = face.getfeature z funkcją zmiennej function = zmienną typu feature powinieneś zacząć być w stanie wylądować na własnych nogach.

Mam nadzieję, że to poprowadzi Cię we właściwym kierunku.

 

A. Mendes

 

13

Witam

Nie mogłem załadować twojej części z powodu przyszłej wersji...

Zobaczmy, czy to może ci pomóc i zaczynając od przykładu obecnego w pomocy (ICI):

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swSketchManager As SldWorks.SketchManager
Dim swSketchSegment As SldWorks.SketchSegment
Dim swFeatureManager As SldWorks.FeatureManager
Dim swFeature As SldWorks.Feature
Dim swExtrudeFeatureData As SldWorks.ExtrudeFeatureData2
Dim status As Boolean
Dim errors As Long
Dim warnings As Long

Sub main()

    Set swApp = Application.SldWorks
    Set swModel = swApp.OpenDoc6("C:\Users\Public\Documents\SOLIDWORKS\SOLIDWORKS 2019\samples\tutorial\api\2012-sm.sldprt", swDocumentTypes_e.swDocPART, swOpenDocOptions_e.swOpenDocOptions_Silent, "", errors, warnings)

    Set swSelMgr = swModel.SelectionManager
    Set swEnt = swSelMgr.GetSelectedObject6(1, -1)
    
    Do While swEnt Is Nothing
        DoEvents
        Set swEnt = swSelMgr.GetSelectedObject6(1, -1)
    Loop
    
    Set swSelData = swSelMgr.CreateSelectData

    swModel.ClearSelection2 True
    
    status = swEnt.Select4(True, swSelData)
    
    'Sketch a circle
    Set swSketchManager = swModel.SketchManager
    Set swSketchSegment = swSketchManager.CreateCircle(0#, 0#, 0#, 0.004122, -0.003029, 0#)

    Set swFeatureManager = swModel.FeatureManager
    Set swFeature = swFeatureManager.FeatureCut4(True, False, False, 1, 0, 0.01, 0.01, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, True, True, True, True, True, False, 0, 0, False, False)

    swModel.ClearSelection2 True

    MsgBox "Terminé"
End Sub

Spowoduje to załadowanie przykładowego pliku (nie do zapisania po przejściu makra), a następnie makro zostanie wstrzymane podczas wybierania powierzchni, a następnie utworzy szkic z okręgiem na tej powierzchni i przebije go.

Pozdrowienia

1 polubienie
14

Będę Was informował na bieżąco, co uda mi się zrobić, a czego nie.

Na razie wieczory spędzam na projektach dla klientów, więc moje projekty usprawniające są trochę drugorzędne, ale nie rozpaczam, że wrócę do nich w ten weekend. W każdym razie dziękuję za czas, który mi poświęciłeś.

15

Witam

A oto przykład z wyborem na aktywnej części w oprogramowaniu i sprawdzeniem, czy geometria dla wyciągnięcia przecina model:

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSketchSegment As SldWorks.SketchSegment
Dim swFeature As SldWorks.Feature
Dim swEnt As SldWorks.Entity
Dim swSelData As SldWorks.SelectData
Dim status As Boolean

Sub main()

    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc

    Set swEnt = swModel.SelectionManager.GetSelectedObject6(1, -1)
    
    Do While swEnt Is Nothing
        DoEvents
        Set swEnt = swModel.SelectionManager.GetSelectedObject6(1, -1)
    Loop
    
    Set swSelData = swModel.SelectionManager.CreateSelectData

    swModel.ClearSelection2 True
    
    status = swEnt.Select4(True, swSelData)
    
    Set swSketchSegment = swModel.SketchManager.CreateCircle(0.023541, -0.016804, 0#, 0.029591, -0.01168, 0#)

    Set swFeature = swModel.FeatureManager.FeatureCut4(True, False, False, 1, 0, 0.01, 0.01, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, False, True, True, True, True, False, 0, 0, False, False)

    swModel.ClearSelection2 True
    
    If Not swFeature Is Nothing Then
        MsgBox "Terminé"
    Else
        MsgBox "La géométrie ne croise pas le modèle."
        swModel.EditUndo2 3
    End If
End Sub

Pozdrowienia

1 polubienie
16

W końcu udało mi się rozwiązać mój problem: dzięki czytaniu twoich fragmentów skryptów i robieniu testów zrozumiałem, że muszę uzyskać nazwę ciała wybranej twarzy, aby wyciągnięcie zadziałało.  

Wygląda to tak: 

Dim swEnt As SldWorks.Face2
Dim swSelData As SldWorks.SelectData
Set swEnt = Part.SelectionManager.GetSelectedObject6(1, 0)
Do While swEnt Is Nothing
    DoEvents
    Set swEnt = Part.SelectionManager.GetSelectedObject6(1, 0)
Loop


Dim swBody As SldWorks.Body2
Set swBody = swEnt.GetBody

boolstatus = Part.Extension.SelectByID2(swBody.Name, "SOLIDBODY", 0, 0, 0, True, 8, Nothing, 0)

Dim myFeature As Object
Set myFeature = Part.FeatureManager.FeatureCut4(True, False, False, 1, 0, 0.01, 0.01, False, False, False, False, 1.74532925199433E-02, 1.74532925199433E-02, False, False, False, False, False, True, False, True, True, False, 0, 0, False, False)
Part.ClearSelection2 True

 

Dziękuję wszystkim za pomoc.