Macro Gat Verwijderen Solidworks

Macro
1

Hallo

Ik ben een beginner op dit gebied, als onderdeel van mijn stage zou ik graag een macro in VBA willen maken die de gaten van een Solidworks-onderdeel zou verwijderen. Om dit te doen, heb ik het volgende programma geschreven:

Dim swApp als object
Sub RemoveHoles()
Dim swApp als SldWorks.SldWorks
Dim swModel als SldWorks.ModelDoc2
Dim swFeature als 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

Einde Sub

Sub hoofd()

Stel swApp = Toepassing.SldWorks in
Gaten verwijderen
Einde Sub

Het programma compileert zonder fouten, maar als ik het uitvoer, gebeurt er niets. Bij voorbaat dank voor uw hulp.

2

Hallo
Welkom op het forum, zoals het er nu uitziet, is uw code onjuist op verschillende parameters.
Dit type code verwijdert alle tap-/boorfuncties die in de boom zijn gedetecteerd:

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

De hoofdprocedure heeft op dit moment weinig zin, tenzij je andere functies in de code wilt gebruiken.

2 likes
3

Goedenavond, dank u voor uw welkom en uw antwoord :slightly_smiling_face: