VBA and new layer

[gazzalp]

Ive finally worked out a bit of basic coding. My problem now is with text. Ive got the code to add text, but what i need it to do is put the text on a layer called "dimensions" and if that layer is not currently in the drawing i want to create it. ive got the code to add the layer, but for some reason it is not putting the text on the layer. Here is what i have:

 

Public Sub AddText()
Dim objNewLayer As AcadLayer
Dim varStart As Variant
Dim dblHeight As Double
Dim strText As String
Dim objEnt As AcadText
On Error Resume Next
Set objNewLayer = ThisDrawing.Layers.Add("Dimensions")
objNewLayer.color = acWhite
''Get Input from user
With ThisDrawing.Utility
varStart = .GetPoint(, vbCr & "Pick the start point: ")
dblHeight = .GetDistance(varStart, vbCr & "Indicate the height: ")
strText = .GetString(True, vbCr & "Enter the text: ")
End With
''Create the text
If ThisDrawing.ActiveSpace = acModelSpace Then
Set objEnt = ThisDrawing.ModelSpace.AddText(strText, varStart, dblHeight)
Else
Set objEnt = ThisDrawing.PaperSpace.AddText(strText, varStart, dblHeight)
ObjstrText.Layer = "Dimensions"
ObjstrText.Update
End If
End Sub

[SEANT]

Ive finally worked out a bit of basic coding. My problem now is with text. Ive got the code to add text, but what i need it to do is put the text on a layer called "dimensions" and if that layer is not currently in the drawing i want to create it. ive got the code to add the layer, but for some reason it is not putting the text on the layer. Here is what i have:

 

Public Sub AddText()
Dim objNewLayer As AcadLayer
Dim varStart As Variant
Dim dblHeight As Double
Dim strText As String
Dim objEnt As AcadText
On Error Resume Next
Set objNewLayer = ThisDrawing.Layers.Add("Dimensions")
objNewLayer.color = acWhite
''Get Input from user
With ThisDrawing.Utility
varStart = .GetPoint(, vbCr & "Pick the start point: ")
dblHeight = .GetDistance(varStart, vbCr & "Indicate the height: ")
strText = .GetString(True, vbCr & "Enter the text: ")
End With
''Create the text
If ThisDrawing.ActiveSpace = acModelSpace Then
Set objEnt = ThisDrawing.ModelSpace.AddText(strText, varStart, dblHeight)
Else
Set [color="SeaGreen"]objEnt[/color] = ThisDrawing.PaperSpace.AddText(strText, varStart, dblHeight)
[color="Red"]ObjstrText[/color].Layer = "Dimensions"
[color="red"]ObjstrText[/color].Update
End If
End Sub

 

ObjstrText should be objEnt.

[SEANT]

Actually, there were a couple of issues with the original. Try this:

 

Public Sub AddText()
Dim objNewLayer As AcadLayer
Dim varStart As Variant
Dim dblHeight As Double
Dim strText As String
Dim objEnt As AcadText
  Set objNewLayer = ThisDrawing.Layers.Add("Dimensions")
  objNewLayer.color = acWhite
  ''Get Input from user
  With ThisDrawing.Utility
     varStart = .GetPoint(, vbCr & "Pick the start point: ")
     dblHeight = .GetDistance(varStart, vbCr & "Indicate the height: ")
     strText = .GetString(True, vbCr & "Enter the text: ")
  End With
''Create the text
  If ThisDrawing.ActiveSpace = acModelSpace Then
     Set objEnt = ThisDrawing.ModelSpace.AddText(strText, varStart, dblHeight)
  Else
     If ThisDrawing.MSpace Then
        Set objEnt = ThisDrawing.ModelSpace.AddText(strText, varStart, dblHeight)
     Else
        Set objEnt = ThisDrawing.PaperSpace.AddText(strText, varStart, dblHeight)
     End If
  End If
     objEnt.Layer = "Dimensions"
     objEnt.Update
End Sub

[gazzalp]

Thanks heaps for your help, ill have a look at both codes now and see where i went wrong. Also does anyone know how to do a basic hatch in VBA? Ive got Joe Stuphin's book, it shows how to add the hatch between two circles (like a donut kind of thing) but not just the basic one for picking an internal point (and i want the autocad block with all the hatch patterns to pop up). The problem im finding with learning codes is figuring out the things i need to define (the code at the top, ie: with dimensions you need two points, text location etc.)

[TommyG]

look for the layer, if it doesnt exist, make it, with the attributes you need, and set it to that

 

Public Sub NewLayer()
On Error Resume Next
Set olayer = ThisDrawing.Layers.Item("YourNewLayerName")
'If that raises an error then it doesn't exist, now create it
If Err.Number <> 0 Then Set olayer = ThisDrawing.Layers.Add("YourNewLayerName")
olayer.color = 1
olayer.Description = "Something in the description"
ThisDrawing.ActiveLayer = olayer
Err.Clear
On Error GoTo 0 'Or where ever your error handler is
End Sub

Some other options for the Layer control are:

 

olayer.Freeze
olayer.LayerOn
olayer.Lock
olayer.Linetype

[SEANT]

I have to agree that checking for a naming conflict prior to creating a named object is a sensible precaution. This is one of the rare instances where it is not absolutely required, however.

[TommyG]

Depends on how he wants to work it.

 

That code is early work in our development, mine now looks at an XML file containing all the layer setup, and when someone wants a new layer, it calls it up from the XML. Plus we are enforcing our standards hard, so any layer changes get reverted each time there is a check on the layers.

 

If only AutoCAD was like Microstation where you could restrict layer management to one or more particular people, and general designers couldnt create layers, only Admin could.

[SEANT]

I certainly have nothing against rigorous “standards compliance”, though I’m not sure so much about this:

 

If only AutoCAD was like Microstation where you could restrict layer management to one or more particular people, and general designers couldnt create layers, only Admin could.

 

 

The point I was referring to, though, was that

Set objNewLayer = ThisDrawing.Layers.Add("Dimensions")

would not error if a layer Dimensions already exists. AutoCad/VBA will readily create the reference whether it has to create it new or not.