Neuer Layer zu erzeugen ist nicht so wirklich das Problem
Anbei ein paar VBA routinen zum Einstieg 
Wenn ich heute richtig gelesen habe ist vba bei autodesk neuerdings nicht mehr so ganz tot
ACAD 2014 hat nen neuen nativen 64 Bit interpreter - schaut aus als waers der selbe wie in office ...
OK hier ein paar routinen zum spielen
Es ist definitiv auch moeglich alle diese Layerinformationen in einer Tabelle etc vorzuhalten.
Fuer diejenigen die nicht scripten wollen.
Layer kann man auch mit bloecken erzeugen.
Einfach z.B. Punkte mit jeweils einem Punkt auf einem eingestellten layer erzeugen.
Den Block einladen = alle Layer da.
Block loeschen und _purge = alle unbenutzen Layer weg.
Ich weis auch nicht warum man hunderte layer braucht.
Sehr komplexe Informationen lassen sich leicht mit Dictionarys an an Elemente binden und auch auslesen.
Sofern man das einmal durchgearbeitet hat. Die ACAd VBA Hilfe ist ein wirklich guter Start Punkt
Dim x as acaddictionary und dann auf acaddictionary mal F1 loslassen.
anyhow:
Sub Layer_create()
Dim layCurrent As AcadLayer
On Error Resume Next
Dim PREFIX As String
Dim SUFFIX As String
Dim layername As String
Dim P() As String
Dim S() As String
PREFIX = InputBox("LAYERPREFIX", "LAYER CREATE", "")
SUFFIX = InputBox("LAYERSUFFIX", "LAYER CREATE", "")
If SUFFIX = "" Then Exit Sub
PREFIX = UCase(PREFIX)
SUFFIX = UCase(SUFFIX)
P = Split(PREFIX)
S = Split(SUFFIX)
On Error Resume Next
For I = LBound(P) To UBound(P)
Set layCurrent = ThisDrawing.layers.ADD(strLayer)
For j = LBound(S) To UBound(S)
Debug.Print layername
Call ThisDrawing.layers.ADD(layername)
Next
Next
On Error GoTo 0
End Sub
Layr namen verfrickeln auch kein problem 
Sub LayertoLowerCase()
'This routine reformats all layer names to all lowercase.
Dim DwgLayer As AcadLayer
For Each DwgLayer In ThisDrawing.layers
DwgLayer.Name = LCASE(DwgLayer.Name)
Next DwgLayer
End Sub
Sub LayertoUpperCase()
'This routine reformats all layer names to all uppercase.
Dim DwgLayer As AcadLayer
For Each DwgLayer In ThisDrawing.layers
DwgLayer.Name = UCase(DwgLayer.Name)
Next DwgLayer
End Sub
Schick ist auch layer zu clonen
Function Layer_exist(ByRef layername As String) As Boolean
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.layers
If UCase(objLayer.Name) = UCase(layername) Then
Layer_exist = True
Exit Function
End If
Next objLayer
Layer_exist = False
End Function
Function Layer_find(ByRef layername As String) As AcadLayer
Set Layer_find = Nothing
If S = "" Then Exit Function
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.layers
If UCase(objLayer.Name) = UCase(layername) Then
Layer_find = objLayer
Exit Function
End If
Next objLayer
End Function
Sub Layer_clone(ByVal layername As String, ByVal template As String, Optional Show As Integer = -1)
Dim LoseReturn As Long
Dim NewLayer As AcadLayer
Dim OldLayer As AcadLayer
Dim TESTlayer As AcadLayer
Set OldLayer = Layer_find(template)
Set NewLayer = Layer_find(layername)
If NewLayer Is Nothing Then
Set NewLayer = ThisDrawing.layers.ADD(layername)
If LayerExist(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
End If
If Show <> -1 Then
If Show = 1 Then NewLayer.LAYERON = True
If Show = 0 Then NewLayer.LAYERON = False
End If
End Sub
und umbenennen und status setzen ist auch kein hexenwerk
Sub layer_rename(ByVal selectionsetobject As AcadSelectionSet)
Dim objLayer As AcadLayer
Dim entity As AcadEntity
For Each entity In selectionsetobject
layername = entity.LAYER
newname = InputBox("Layername", layerrename, layername)
For Each objLayer In ThisDrawing.layers
If objLayer.Name = layername Then
On Error Resume Next
objLayer.Name = newname
objLayer.Freeze = False
objLayer.LAYERON = True
objLayer.Lock = False
ThisDrawing.ActiveLayer = objLayer
On Error GoTo 0
Exit Sub
End If
Next
Next
End Sub
------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
- 
