Add layer with VBA

[Huibert]

I have a simple question:

 

How can I add new layer to a drawing called "voorkandscherm" with a certain linetype = "continuous"; Lineweight = "0.25 mm" Color = "white"

If the layer already exsist in the drawing than the excisting layer should be used.

The layer should be the current layer so the next line will be drawn in this layer.

 

I now only have:

 

Friend Sub AddLayer(ByVal Name As String, ByVal LineType As sting, ByVal Lineweight As sting, ByVal Color As sting)
   Dim Layer As AcadLayer
   Set Layer = ThisDrawing.Layers.Add(Name)
   Layer.LineType = LineType
   Layer.Lineweight = Lineweight
   Layer.TrueColor <===== how do I continue this one????
'    Layer.Delete
End Sub

[Huibert]

ehm.... Byval xx as String

[SEANT]

Can you pass the color as an object, such as:

 

. . . ., ByVal Color As AcadAcCmColor)

[Huibert]

and then:

 

layer.truecolor = color ???

[CmdrDuh]

do you want a function to check for the layer exists, or do you want to recreate it, meaning reset to default values, and use it that way?

[CmdrDuh]

code to check if a layer exists

Private Function DoesLayerExist(ByRef LayerName As String) As Boolean
     Dim objLayer As AcadLayer
     For Each objLayer In ThisDrawing.Layers
           If UCase(objLayer.Name) = UCase(LayerName) Then
                 DoesLayerExist = True
                 Exit Function
           End If
     Next objLayer
     DoesLayerExist = False
End Function

[CmdrDuh]

And code to create a layer and you can pass arguments to the function for name, color, lineweight

Public Sub LayerSet(ByRef Lname As String, Optional Lcolor As Integer, Optional Ltype As String)
     Dim objLayer As AcadLayer
     On Error GoTo ErrorHandler
     If DoesLayerExist(Lname) = False Then
           Set objLayer = ThisDrawing.Layers.Add(UCase(Lname))
           objLayer.color = Lcolor
           objLayer.Linetype = Ltype
           ThisDrawing.ActiveLayer = objLayer
     Else
           Set objLayer = ThisDrawing.Layers.Item(Lname)
           objLayer.Freeze = False
           objLayer.LayerOn = True
           ThisDrawing.ActiveLayer = objLayer
     End If
     GoTo Clean_Up
ErrorHandler:
     Select Case Err
     Case -2145320939:
           Err.Clear
           Resume Next
     Case -2145386493:
           Err.Clear
           Resume Next
     Case -2145386476:
           Err.Clear
           ThisDrawing.Linetypes.Load Ltype, "acad.lin"
           Err.Clear
           Resume
     Case Else:
           Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
     End Select
Clean_Up:
     Set objLayer = Nothing
     Exit Sub
End Sub

[CmdrDuh]

Use it like this

Call LayerSet("SITE-FNDN", acRed)

or

Call LayerSet(""SITE-BASE", 7, "Phantom")

or

Call LayerSet(""SITE-Piling", , "Phantom")

Notice I am calling the same function, but passing different arguments as I need them

[SEANT]

Currently, I don’t bother with .TrueColor either, but if the code is to be used in an unknown environment then it may be prudent to allow for the advanced color models. Here is a snippet to illustrate TrueColor.

 

 

Sub ColorTest()

Dim objLayer As AcadLayer
Dim objColor As New AcadAcCmColor
Dim entLine As AcadLine
Dim dblStPt(0 To 2) As Double
Dim dblNdPt(0 To 2) As Double
  dblNdPt(0) = 4
  dblNdPt(1) = 3
  Set entLine = ThisDrawing.ModelSpace.AddLine(dblStPt, dblNdPt)
  Call objColor.SetRGB(243, 122, 61)
  entLine.TrueColor = objColor
  AddLayer "TestLayer", "Continuous", acLnWt009, entLine.TrueColor
  entLine.Layer = "Testlayer"
  objColor.ColorIndex = acByLayer 'or acWhite or whatever
  entLine.TrueColor = objColor
End Sub

Sub AddLayer(ByVal Name As String, ByVal LineType As String, ByVal Lineweight As Integer, ByVal Color As AcadAcCmColor)
  Dim Layer As AcadLayer
   Set Layer = ThisDrawing.Layers.Add(Name)
   Layer.LineType = LineType
   Layer.Lineweight = Lineweight
   Layer.TrueColor = Color
End Sub