Тема: создать слой в Акаде
кто-нибудь может помочь, нужно создать какай-нибудь слой и поместить в этот слой текст програмно из VB 6.0.
Заранее спасибо!
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → создать слой в Акаде
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
кто-нибудь может помочь, нужно создать какай-нибудь слой и поместить в этот слой текст програмно из VB 6.0.
Заранее спасибо!
Вот рабочая процедура создания слоя:
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)
Михаил, не совсем понятно как эту функцию применить, чтобы появился новый слой?
Все просто, вы вызываете эту функуцию:
где 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) ...
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → создать слой в Акаде
Форум работает на PunBB, при поддержке Informer Technologies, Inc