Usuwanie otworów makr Solidworks

Macro
1

Witam

Jestem początkujący w tej dziedzinie, w ramach stażu chciałbym zrobić makro w VBA, które usunęłoby w części Solidworks. Aby to zrobić, napisałem następujący program:

Dim swApp As Object
Sub RemoveHoles()
Dim swApp jako SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeature jako SldWorks.Feature

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

If swModel.GetType = swDocPART Then
    Set swFeature = swModel.FirstFeature
    Do While Not swFeature Is Nothing
        If swFeature.GetType = swHoleFeature Then
            swFeature.Select2 True, -1
            swModel.DeleteSelection2 swDelete_Absorbed
        End If
        Set swFeature = swFeature.GetNextFeature
    Loop
Else
    MsgBox "Le document actif n'est pas une pièce."
End If

Koniec subwoofera

Sub main()

Ustaw swApp = Application.SldWorks
Usuń otwory
Koniec subwoofera

Program kompiluje się bez błędów, jednak gdy go uruchamiam, nic się nie dzieje. Z góry dziękuję za pomoc.

2

Witam
Witaj na forum, w obecnej formie Twój kod jest niepoprawny pod kilkoma parametrami.
Ten typ kodu usuwa wszystkie funkcje stukania/wiercenia wykryte w drzewie:

Dim swApp As Object
Sub RemoveHoles()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swFeature As SldWorks.Feature
Dim swFeature2 As SldWorks.Feature
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim bret As Boolean
Dim bDone As Boolean

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

If swModel.GetType = swDocPART Then
    Set swFeature = swModel.FirstFeature
    Set swModelDocExt = swModel.Extension
    Do While Not swFeature Is Nothing
        If swFeature.GetTypeName2 = "HoleWzd" Then
            Set swFeature2 = swFeature
            Set swFeature = swFeature.GetNextFeature
            swFeature2.Select2 True, -1
            bDone = True
            bret = swModelDocExt.DeleteSelection2(swDelete_Absorbed)
        End If
        If Not bDone Then
        Set swFeature = swFeature.GetNextFeature
        End If
        bDone = False
    Loop
Else
    MsgBox "Le document actif n'est pas une pièce."
End If
End Sub

Sub main()

Set swApp = Application.SldWorks
RemoveHoles
End Sub

Główna procedura jest w tej chwili mało przydatna, chyba że chcesz użyć innych funkcji w kodzie.

2 polubienia
3

Dobry wieczór, dziękuję za powitanie i odpowiedź :slightly_smiling_face: