Pb auf Makro SolidWorks

Hallo

Ich habe ein Problem beim Erstellen der Ebene auf diesem VBA-Makro für SW 2020 (das eine Ebene erstellen und alle Dimensionen des MEP auf dieser Ebene verschieben soll).
Das Makro friert auf der Ebene " AddLayer " ein: Die Funktion ist entweder falsch konfiguriert oder falsch deklariert, wie es scheint. Ich habe versucht, die Einstellungen zwischen () mit Dingen aus dem Internet zu ändern, aber in diesem Fall ändert sich der Fehler. So kann es auch bei der Deklaration von Variablen zu Problemen kommen.

Wenn jemand im Voraus eine Idee hat, danke.

Sub MoveDimensionsToLayer()

' Déclaration des variables
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDrawing As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim swView As SldWorks.View
Dim swDim As SldWorks.Dimension
Dim swLayerMgr As SldWorks.LayerMgr
Dim swLayer As SldWorks.Layer
Dim swAnn As SldWorks.Annotation
Dim vViews As Variant
Dim i As Integer
Dim layerName As String

' Initialisation de l'application SOLIDWORKS
Set swApp = Application.SldWorks

' Récupération du document actif
Set swModel = swApp.ActiveDoc

' Vérification si un document est ouvert et est une mise en plan
If swModel Is Nothing Then
    MsgBox "Aucun document n'est ouvert dans SOLIDWORKS.", vbExclamation
    Exit Sub
End If

If swModel.GetType <> swDocDRAWING Then
    MsgBox "Le document actif n'est pas une mise en plan.", vbExclamation
    Exit Sub
End If

' Initialisation de la mise en plan et de la gestion des calques
Set swDrawing = swModel
Set swLayerMgr = swDrawing.GetLayerManager

' Nom du calque cible
layerName = "cotes"

' Vérifie si le calque 'cotes' existe, sinon le crée
Set swLayer = swLayerMgr.GetLayer(layerName)
If swLayer Is Nothing Then
    Set swLayer = swLayerMgr.AddLayer(layerName, 1, RGB(0, 0, 0), 0, False, False)
    MsgBox "Le calque 'cotes' a été créé."
End If

' Parcours de toutes les vues de la mise en plan
vViews = swDrawing.GetViews

For i = 0 To UBound(vViews)
    Set swView = vViews(i)

    ' Parcours de toutes les annotations de la vue
    Set swAnn = swView.GetFirstAnnotation2

    Do While Not swAnn Is Nothing
        If swAnn.GetType = swDimension Then
            ' Récupération de la dimension
            Set swDim = swAnn.GetSpecificAnnotation

            ' Déplacement de la dimension vers le calque 'cotes'
            swDim.Layer = layerName
        End If

        ' Récupération de l'annotation suivante
        Set swAnn = swAnn.GetNext
    Loop
Next i

' Confirmation de la fin du traitement
MsgBox "Toutes les dimensions ont été déplacées vers le calque 'cotes'.", vbInformation

Ende Sub

Inspiriert von einem meiner Makros habe ich ersetzt:

Set swLayer = swLayerMgr.AddLayer(layerName, 1, RGB(0, 0, 0), 0, False, False)

bis:

    swLayerMgr.AddLayer layerName, "", 0, 0, 0
    swLayerMgr.SetCurrentLayer layerName

Und die Erstellung der Ebene ist funktional (auf der anderen Seite müssen Sie die Farbe und die Option überprüfen, die ich nicht zurückgesetzt habe)

1 „Gefällt mir“

Der Rest Ihres Makros scheint auch zu nerven, um die Dimensionen zu verschieben, habe ich diesen Code, der funktional ist.
Es liegt an Ihnen, mit der richtigen Ebene zu modifizieren:

Option Explicit
Const ToLayer               As String = "Cotation"
Sub moveDimensionsToLayer()
    Dim swApp               As SldWorks.SldWorks
    Dim swModel             As SldWorks.ModelDoc2
    Dim swDraw              As SldWorks.DrawingDoc
    Dim vSheets             As Variant
    Dim vSheet              As Variant
    Dim swView              As SldWorks.View
    Dim swAnn               As SldWorks.Annotation
    Dim swNote              As SldWorks.Note
    Dim swDispDim           As SldWorks.DisplayDimension
    Dim swGtol              As SldWorks.Gtol
    Dim swDatum             As SldWorks.DatumTag
    Dim swAnnSFSymbol       As SldWorks.SFSymbol
    Dim swTables            As Variant
    Dim swTable             As Variant
    Dim swTableAnn          As SldWorks.TableAnnotation
    Dim swSketch            As SldWorks.Sketch
    Dim vSegs               As Variant
    Dim vSeg                As Variant
    Dim swSkSeg             As SldWorks.SketchSegment
    Dim vPts                As Variant
    Dim vPt                 As Variant
    Dim swSkPt              As SldWorks.SketchPoint
    Dim bRet                As Boolean
    
    Set swApp = Application.SldWorks
    SuppressLayers.SuppressLayers
    
    Set swModel = swApp.ActiveDoc
    If swModel Is Nothing Then
        MsgBox "Ouvrir une mise en plan"
        Exit Sub
    End If
    If swModel.GetType <> swDocumentTypes_e.swDocDRAWING Then
        MsgBox "Ouvrir une mise en plan"
        Exit Sub
    End If
    
    Set swDraw = swModel
    
        'On active le calque cotation
    bRet = swModel.SetCurrentLayer(ToLayer)
    
    vSheets = swDraw.GetSheetNames
    
    For Each vSheet In vSheets
        swDraw.ActivateSheet vSheet
    
        Set swView = swDraw.GetFirstView
    
        If swView.GetTableAnnotationCount > 0 Then
            swTables = swView.GetTableAnnotations
            For Each swTable In swTables
               Set swTableAnn = swTable
               Set swAnn = swTableAnn.GetAnnotation
               swAnn.Layer = ToLayer
            Next
        End If

        Set swView = swView.GetNextView
            While Not swView Is Nothing
                Set swNote = swView.GetFirstNote
                While Not swNote Is Nothing
                    Set swAnn = swNote.GetAnnotation
                    swAnn.Layer = ToLayer
                    Set swNote = swNote.GetNext
                Wend
    
                Set swDatum = swView.GetFirstDatumTag
                While Not swDatum Is Nothing
                    Set swAnn = swDatum.GetAnnotation
                    swAnn.Layer = ToLayer
                    Set swDatum = swDatum.GetNext
                Wend
            
                Set swGtol = swView.GetFirstGTOL
                While Not swGtol Is Nothing
                    Set swAnn = swGtol.GetAnnotation
                    swAnn.Layer = ToLayer
                    Set swGtol = swGtol.GetNextGTOL
                Wend
    
                Set swAnnSFSymbol = swView.GetFirstSFSymbol
                While Not swAnnSFSymbol Is Nothing
                    Set swAnn = swAnnSFSymbol.GetAnnotation
                    swAnn.Layer = ToLayer
                    Set swAnnSFSymbol = swAnnSFSymbol.GetNext
                Wend
            
                Set swDispDim = swView.GetFirstDisplayDimension5
                While Not swDispDim Is Nothing
                    Set swAnn = swDispDim.GetAnnotation
                    swAnn.Layer = ToLayer
                    Set swDispDim = swDispDim.GetNext5
                Wend
                
            Set swView = swView.GetNextView
        Wend
    Next
    
    'On active le calque cotation
    'bRet = swModel.SetCurrentLayer(ToLayer)

    swModel.ClearSelection2 True
Debug.Print "Fin de move dimension to layer"
End Sub

4 „Gefällt mir“