---

Liebes Forum,

ich möchte per VBA einen Layer mit all seinen Eigenschaften duplizieren.

Derzeit mache ich das indem ich einen neuen Layer einfüge und die einzelnen Eigenschaften des ursprünglichen Layers auf die Eigenschaften des neuen Layers einzeln übertrage.
Gerade hänge ich daran, wie ich eine RGB-Farbe übertragen kann und da stellt sich mir die Frage, ob es nicht eine Funktion Duplizieren eines Layers gibt.

So in etwa, wie wenn ich den Layer im Layermanager von Hand dupliziere. Da gehe ich zu dem gewünschten Layer, drücke ENTER, erhalte einen Layer, der alle Eigenschaften übernommen hat und muss dem neuen nur noch einen Namen eingeben.

Gibt es so etwas auch in VBA?

------------------
Grüße aus München
Christian

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

mit VBA kann man Layer bloß mit der Methode ADD hinzufügen ... eine Möglichkeit wäre noch über copyobjects und ein temporäres andere Dokument ... --> GetInterfaceObject "ObjectDBX.AxDbDocument"

------------------
Also ich finde Unities gut ... und andere sicher auch
---------------------------------------
  - Thomas -          
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Meinst sowas ? 

Function layer_clone(ByVal layername As String, ByVal template As String, Optional Show As Integer = -1, Optional FORCE As Boolean = False) As AcadLayer

    Dim LoseReturn As Long
    Dim newLayer As AcadLayer
    Dim oldlayer As AcadLayer
    Dim TESTlayer As AcadLayer
    Set layer_clone = Nothing
    If LayerExist(layername) And FORCE = False Then Exit Function
    Set oldlayer = Layer_find(template)
    Set newLayer = Layer_find(layername)
    If newLayer Is Nothing Then
        If layername = "" Then layername = "GHOST"
        Set newLayer = ThisDrawing.LAYERS.Add(Trim(layername))
        If Layer_Exist_fast(template) = False Then template = "0"
        newLayer.Color = ThisDrawing.LAYERS(template).Color
        newLayer.linetype = ThisDrawing.LAYERS(template).linetype
        newLayer.lineweight = ThisDrawing.LAYERS(template).lineweight
        newLayer.Material = ThisDrawing.LAYERS(template).Material
        newLayer.DESCRIPTION = ThisDrawing.LAYERS(template).DESCRIPTION
    End If

    Set layer_clone = newLayer
    If Show <> -1 Then
        If Show = 1 Then newLayer.LAYERON = True
        If Show = 0 Then newLayer.LAYERON = False
    End If

End Function
Function Layer_find(ByRef layername As String) As AcadLayer
    Set Layer_find = Nothing
    If layername = "" Then Exit Function
    Dim objLayer As AcadLayer
    For Each objLayer In ThisDrawing.LAYERS
        If UCase(objLayer.name) = UCase(layername) Then
            Set Layer_find = objLayer
            Exit Function
        End If
    Next objLayer

End Function

Function layer_find_fast(ByRef s_lay_name As String) As AcadLayer
    Set layer_find_fast = Nothing
    On Error GoTo not_found
    Set layer_find_fast = ThisDrawing.LAYERS(s_lay_name)
    Exit Function
not_found:
    err.Clear
    Set layer_find_fast = Nothing
End Function

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Genau das meint er! Aber das ist das "Haben", nicht das wollen 

------------------
CAD on demand GmbH - Beratung und Programmierung rund um AutoCAD

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Ja richtig,
das meine ich und das habe ich bis jetzt auch in etwa so.

Da es aber nun mal nur so zu gehen scheint, eine weitere Frage.

Wie übernehme ich eine RGB-Farbangabe des Layers?
bisher geht es nicht und mache ich es so:

Code:

---

Public Sub LayAdd(LayName As String, Optional LayColor As Integer = 2, Optional LayColorRGB As AcadAcCmColor, Optional LayOn As Boolean = True, Optional layfreeze As Boolean = False, Optional laylock As Boolean = False, Optional strLayBeschr As String = "xx")

    If LayName = "" Then Exit Sub
   
    If LayExists(LayName) = False Then
   
        Dim layerObj As AcadLayer
   
        ' Layer der Layerliste hinzufügen
        Set layerObj = ThisDrawing.Layers.Add(LayName)
       
        'Farbe einstellen. Wenn nichts angegeben, wird die Standardfarbe eingestellt.
        layerObj.color = LayColor 'Farbindex
        layerObj.TrueColor = LayColorRGB 'RGB-Farbe geht nicht
       
        'LayerAn/Aus
        layerObj.LayerOn = LayOn
       
        'LayerGefroren
        layerObj.Freeze = layfreeze
       
        'LayerGesperrt
        layerObj.Lock = laylock
       
        'LayerBeschreibung
        layerObj.Description = strLayBeschr
   
        ' Display the status of the new layer
        MsgBox "Der Layer " & layerObj.Name & " wurde hinzugefügt." & vbCrLf & _
              "An Status: " & layerObj.LayerOn & vbCrLf & _
              "Gefroren Status: " & layerObj.Freeze & vbCrLf & _
              "Gesperrt Status: " & layerObj.Lock & vbCrLf & _
              "Farbe: " & layerObj.color & vbCrLf & _
              "Beschreibung: " & layerObj.Description, vbInformation, "LayAdd"
    Else
        MsgBox "Der Layer " & LayName & " existiert bereits." & vbCrLf & "Es wurde kein neuer Layer hinzugefügt.", vbInformation, "LayAdd"
    End If
   
End Sub

---

Muss ich noch ein Farbbuch angeben?

------------------
Grüße aus München
Christian

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

LayColorRGB (AcadAcCmColor) ist ein Object mit Methoden und Properties .. Das man sich mit GetInterfaceObject ("AutoCAD.AcCmColor.18") holt befüllt und dann übergibt .... oder das direkt vom erzeugten Layer holt und dann dort die Properties setzt ...

------------------
Also ich finde Unities gut ... und andere sicher auch
---------------------------------------
  - Thomas -          
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke für den Hinweis.
Ich versuch's mal.

------------------
Grüße aus München
Christian

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Die Sach hat nur nen minimalen Haken ...

Sub testcolor()
Dim layer As AcadLayer
Dim r As Long
Dim g As Long
Dim b As Long
r = 255
Dim color As New AcadAcCmColor
Dim V As Long
err.Clear
Dim version As String
For I = 16 To 99
err.Clear
version = Trim(str(I))

Debug.Print GetVerticalAppName()

On Error Resume Next
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor." & version)
If err.Number = 0 Then Exit Sub
Next
Call color.SetRGB(r, g, b)
Set layer = ThisDrawing.LAYERS("0")
'Dim RGB As Long
'RGB = 164 * r + 162 * g + b
layer.TrueColor = color
End Sub
Public Function GetVerticalAppName() As String
    Dim strName As String
    strName = AcadApplication.Caption
    'strip the dwg from the caption
    strName = LEFT(strName, InStr(1, strName, " -"))
    GetVerticalAppName = strName
   
End Function

Beim ersten aufruf wür ich die versionsnumemr ermitteln und dann zur gefällige verwendung in einer üffentlichen variablen speichern

------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP