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“