Тема: создать слой в Акаде

кто-нибудь может помочь, нужно создать какай-нибудь слой и поместить в этот слой текст програмно из VB 6.0.
Заранее спасибо!

Re: создать слой в Акаде

Вот рабочая процедура создания слоя:

Function DrwCreateLayer(LayerName As String, lineWidth As Long, Color As Long, plotable As Boolean) As String
' функция создает слой, елси такого слоя нет
' если имя слоя пустое("" или "   "), вернет имя активного слоя
'
' по блоку -2, по слою -1
' по умолчанию -3
' остальные толщины линий
' 0,5,9,13,15,18,20,25,30,35,40,50,53,60,70,80,90,100,106,120,140,158,200,211
' цвета: по блоку = 0, по слою = 256

    Dim LayerObj As AcadLayer
    Dim Layers   As AcadLayers
    Dim noLayer  As Boolean
    Dim ObjColor As New AcadAcCmColor
    
    On Error GoTo Err_Control
        ' создаем слой
        Set Layers = ThisDrawing.Layers
        ' перебираем все слои
        noLayer = True
        For Each LayerObj In Layers
            If LayerObj.Name = LayerName Then
                noLayer = False
                Exit For
            End If
        Next
        
        ' если такого слоя нет, и его имя не пустое
        If (LayerName <> "") And noLayer = True Then
            Set LayerObj = ThisDrawing.Layers.Add(LayerName)
            LayerObj.Lineweight = lineWidth
    
           'layerObj.TrueColor.SetColorBookColor
            ObjColor.ColorIndex = Color
            'ObjColor.ColorIndex = 255
            LayerObj.TrueColor = ObjColor
            LayerObj.Plottable = plotable
        ElseIf (noLayer = False) And LayerObj.Plottable = False Then
            LayerObj.Lineweight = lineWidth
            
        ElseIf Trim(LayerName) = "" Then
            LayerName = ThisDrawing.ActiveLayer.Name
        End If
        DrwCreateLayer = LayerName

Err_Control:
    ' обработчик ошибок
    If Err.Number <> 0 Then
        ' обрабатываем исключение
        'ObjErr.ErrOutLog ("tUtility_CreateLayer_:_err_" + str(Err.Number) + "_" + Err.Description)
        DrwCreateLayer = "0"
    End If
End Function

Вот пример добавления мультитекста в чертеж

  Dim Mtext       As AcadMText
  dim p1(2)       as double
...
  ' задаем координаты текста
  p1(0)=0 'x
  p1(1)=0 'y
  p1(2)=0 'z
  ' добавляем текст
  Set Mtext = ThisDrawing.ModelSpace.AddMText(p1, 0, text)

Re: создать слой в Акаде

Михаил, не совсем понятно как эту функцию применить, чтобы появился новый слой?

Re: создать слой в Акаде

Все просто, вы вызываете эту функуцию:
где LayerName - имя желаемого слоя
    lineWidth - толщина линий слоя
    Color - цвет слоя
    plotable - печатаемый ли слой или нет   

Function DrwCreateLayer(LayerName As String, lineWidth As Long, Color As Long, plotable As Boolean) As String

и она вам возвращает слой, который получился, т.е. либо то имя которое вы указывали в параметре LayerName, если все получилось, либо "0"!

Пример:

...
   dim lrName as string
   dim ln     as acadline
   
   dim p1
   dim p2
...
   ' запрашиваем точки у пользователя
   p1 = ThisDrawing.Utility.GetPoint(, "Укажите первую точку: ")
   p2 = ThisDrawing.Utility.GetPoint(p1, "Укажите вторую точку: ")
   ' создаем линию
   Set ln = ThisDrawing.ModelSpace.AddLine(p1, p2)
   ' создаем слой, с именем "LineLayer", толщиной линий 0,7мм, красного цвета, не печатаемый
   ' и назначаем линии этот слой
   ln.layer= DrwCreateLayer("LineLayer",70,1,false)
...

Re: создать слой в Акаде

спасибо