[gizmo_zx]

Здраствуйте.
Подскажите как сделать мультивыноску, у которой в качестве мультитекста было бы поле, отображающее свойство конкретной полилинии, например цвет.
Т.Е. программа запрашивает полилинию (выберите объект), а далее запускает команду мультивыноска в которой автоматом создается "поле: привязанное к свойству цвет"
И еще вопросик, можно ли к полилинии добавить "дополнительное" свойство, где-то видел такой ActiveX, сейчас не могу найти...

Подсобите с кодом на VBA.

[Олег (jr.)]

Добавить свойство можно с помощью XData (расширенных данных)

Пара примеров как добавлять и считывать расширенные
данные, в данном случае примитивы должны быть
облегченными полилиниями

Код:

[Выделить все]

'добавление расширенных данных
Sub SetPipeXdata()
Dim osset As AcadSelectionSet
Dim oEnt
Dim oPline As AcadLWPolyline
Dim fcode(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfdata
Dim i As Integer
Dim setName As String

Open Replace(ThisDrawing.FullName, ".dwg", ".txt", 1, -1) For Output As #1
Write #1, "PipeSpec"
Close #1

DoEvents

     fcode(0) = 0
     fdata(0) = "LWPOLYLINE"
     
     dxfCode = fcode
     dxfdata = fdata
     setName = "$PipeSet$"

          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set osset = .Add(setName)
          End With

osset.SelectOnScreen dxfCode, dxfdata

    Dim DataType(0 To 5) As Integer
    Dim Data(0 To 5) As Variant
    Dim appName As String
    Dim dia As Double
    Dim n As Integer
    n = 1
    
    MsgBox "Выбрано: " & CStr(osset.Count) & " полилиний"

For Each oEnt In osset
    dia = CDbl(InputBox("Введите диаметр для" & vbNewLine & _
    "участка №" & CStr(n) & ":", "Ввод данных"))
    Set oPline = oEnt
    DataType(0) = 1001: Data(0) = "PipeSpec"
    DataType(1) = 1000: Data(1) = CStr(n)
    DataType(2) = 1003: Data(2) = oPline.Layer
    DataType(3) = 1071: Data(3) = oEnt.color
    DataType(4) = 1041: Data(4) = dia
    DataType(5) = 1041: Data(5) = oPline.Length
    
    
    oPline.SetXData DataType, Data
    
    n = n + 1
  
Next

ThisDrawing.Regen acActiveViewport

End Sub

Код:

[Выделить все]

' считывание расширенных данных и добавление
' их в таблицу
Sub GetPipeXData()
Dim osset As AcadSelectionSet
Dim oEnt
Dim oPline As AcadLWPolyline
Dim fcode(0) As Integer
Dim fdata(0) As Variant
Dim dxfCode, dxfdata
Dim i As Integer
Dim setName As String
Dim xdataOut As Variant
Dim xtypeOut As Variant
Dim appName As String

Open Replace(ThisDrawing.FullName, ".dwg", ".txt", 1, -1) For Input As #1
Input #1, appName
Debug.Print appName 'debug only
Close #1

     
DoEvents

     fcode(0) = 0
     fdata(0) = "LWPOLYLINE"
     
     dxfCode = fcode
     dxfdata = fdata
     setName = "$PipeSet$"

          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set osset = .Add(setName)
          End With

osset.SelectOnScreen dxfCode, dxfdata

    Dim DataType(0 To 5) As Integer
    Dim Data(0 To 5) As Variant

    MsgBox "Выбрано: " & CStr(osset.Count) & " полилиний"
    
Dim oTable As AcadTable
Dim insPt
Dim iRows As Long, iCols As Long
Dim rowHgt As Double, colWid As Double
Dim m As Long, n As Long
Dim tmpStr As String
Dim sumLen As Double
insPt = ThisDrawing.Utility.GetPoint(, vbCr & "Точка вставки таблицы:")
iRows = osset.Count + 3
iCols = 5
rowHgt = 1.5
colWid = 35.6
Set oTable = ThisDrawing.ModelSpace.AddTable(insPt, iRows, iCols, rowHgt, colWid)
m = 0
n = 0
tmpStr = "Спецификация"
oTable.SetText m, n, tmpStr
m = 1
Dim headArr
headArr = Array("Позиция", "Слой", "Цвет", "Диаметр", "Длина")
For n = 0 To UBound(headArr)
tmpStr = headArr(n)
oTable.SetText m, n, tmpStr
Next n

m = 2
n = 0
sumLen = 0#
For Each oEnt In osset
Set oPline = oEnt
   oPline.GetXData appName, xtypeOut, xdataOut
With oTable
tmpStr = xdataOut(1)
.SetText m, n, tmpStr
n = n + 1
tmpStr = xdataOut(2)
.SetText m, n, tmpStr
n = n + 1
tmpStr = xdataOut(3)
.SetText m, n, tmpStr
n = n + 1
tmpStr = xdataOut(4)
.SetText m, n, tmpStr
n = n + 1
sumLen = sumLen + xdataOut(5)
tmpStr = ThisDrawing.Utility.RealToString(xdataOut(5), acDecimal, 2)
.SetText m, n, tmpStr
n = n + 1
End With
m = m + 1
n = 0
Next

n = 3
tmpStr = "Общая длина:"
oTable.SetText m, n, tmpStr
n = n + 1
tmpStr = ThisDrawing.Utility.RealToString(sumLen, acDecimal, 2)
oTable.SetText m, n, tmpStr

oTable.RecomputeTableBlock True
ThisDrawing.Regen acActiveViewport

End Sub

Не бог весть что но для примера покатит

~'J'~

[Кулик Алексей aka kpblc]

Олег, а насколько здесь нужны XData? Ведь там же можно поле обычное создавать.

[Олег (jr.)]

Сообщение от Кулик Алексей aka kpblc Олег, а насколько здесь нужны XData? Ведь там же можно поле обычное создавать.

Алексей, я чую что не цвет ему нужен, а именно
XData, которое кстати в поле не вытащишь, поэтому обычный
лидер с мтекстом самое оно
Чем проще тем и лучше

[Олег (jr.)]

И вдогонку насчет мультилидера - выбирай полилинии с расширенными
данными по одной и рисуй мультилидер:

Код:

[Выделить все]

Sub AddMleaderEx()

'' request check "Break on Unhandled Errors" in Tools-> Options-> General

Dim varPt As Variant
Dim oEnt As AcadEntity
Dim oPline As AcadLWPolyline
Dim appname As String
appname = "PipeSpec"
Dim xdataOut As Variant
Dim xtypeOut As Variant
Dim oSpace As AcadBlock

With ThisDrawing
If .ActiveSpace = acModelSpace Then
Set oSpace = .ModelSpace
Else
Set oSpace = .PaperSpace
End If
End With

Do
On Error Resume Next
ThisDrawing.Utility.GetEntity oEnt, varPt, "Выбрать полилинию (Enter для выхода из цикла): "
If Err Then
Err.Clear
Exit Do
End If
On Error GoTo 0

If Not oEnt Is Nothing Then
If TypeOf oEnt Is AcadLWPolyline Then
Set oPline = oEnt
oPline.GetXData appname, xtypeOut, xdataOut
If Not IsEmpty(xdataOut) Then
Dim nxtPt As Variant
nxtPt = ThisDrawing.Utility.GetPoint(varPt, vbCr & "Точка полки текста:")
Dim ptArr(5) As Double
ptArr(0) = varPt(0): ptArr(1) = varPt(1): ptArr(2) = 0#
ptArr(3) = nxtPt(0): ptArr(4) = nxtPt(1): ptArr(5) = 0#
Dim oLeader As AcadMLeader
Dim c As Long
c = 0
Set oLeader = oSpace.AddMLeader(ptArr, c)
oLeader.ContentType = acMTextContent
oLeader.TextString = "%%c" & CStr(xdataOut(4))
Set oEnt = Nothing
Else
MsgBox "Объект не содержит расширенных данных"
End If
Else
MsgBox "Объект не является облегченной полилинией"
End If
End If
Loop
On Error GoTo 0

End Sub

~'J'~

[Кулик Алексей aka kpblc]

Олег (jr.), ну, я отвечал именно на вопрос - там-то спрашивали про поле цвета
P.S. В твой код даже влезать не буду - голову точно сломаю

[Олег (jr.)]

Сообщение от Кулик Алексей aka kpblc Олег (jr.), ну, я отвечал именно на вопрос - там-то спрашивали про поле цвета P.S. В твой код даже влезать не буду - голову точно сломаю

Зря, с головой твоей ничего не случится, там запасу
на долгие годы
А код пустяшный - все из Хэлпа

~'J'~

[Олег (jr.)]

Сообщение от gizmo_zx Здраствуйте. Подскажите как сделать мультивыноску, у которой в качестве мультитекста было бы поле, отображающее свойство конкретной полилинии, например цвет. Т.Е. программа запрашивает полилинию (выберите объект), а далее запускает команду мультивыноска в которой автоматом создается "поле: привязанное к свойству цвет" И еще вопросик, можно ли к полилинии добавить "дополнительное" свойство, где-то видел такой ActiveX, сейчас не могу найти... Подсобите с кодом на VBA.

Я подымаю эту тему чтобы ты лучше объснил конкретику
новой задачи (см. подробности в личке)
Плюс, это нужно на VBA?

~'J'~

[Boxa]

Как то так....
За код сильно не пинать, это компиляция из хелпа....
В Sub-е AddMLeader проставьте свои наименования Слоя и масштаб

Код:

[Выделить все]

Sub PolylineColorToFields()
    Dim returnObj As AcadObject
    Dim basePnt As Variant
    Dim returnPnt1 As Variant
    Dim returnPnt2 As Variant
    Dim pnt(0 To 5) As Double
    Dim text_str As String
    
    On Error Resume Next
RETRY:
    ThisDrawing.Utility.GetEntity returnObj, basePnt, _
                "Полилиния откуда читаем цвет: "
    If Err <> 0 Then
        Err.Clear
        GoTo endScript
    End If
    returnPnt1 = ThisDrawing.Utility.GetPoint(, _
                "Точка вставки текста с полем (стрелочка): ")
    If Err <> 0 Then
        Err.Clear
        GoTo endScript
    End If
    returnPnt2 = ThisDrawing.Utility.GetPoint(returnPnt1, _
                "Точка вставки текста с полем (сам текст): ")
    If Err <> 0 Then
        Err.Clear
        GoTo endScript
    End If
    If TypeName(returnObj) = acPolyline Then
        '%<\AcObjProp Object(%<\_ObjId 2028248696>%).TrueColor>%
        'Строка взята из редактора полей
        'В ней нужно заменить только ObjID на ID выбранной полилинии
        text_str = CStr("%<\AcObjProp Object(%<\_ObjId " & _
                            returnObj.ObjectID & ">%).TrueColor>%")
    End If
      pnt(0) = returnPnt1(0)
      pnt(1) = returnPnt1(1)
      pnt(2) = 0
      pnt(3) = returnPnt2(0)
      pnt(4) = returnPnt2(1)
      pnt(5) = 0
      Call AddMLeader(text_str, pnt)
    GoTo RETRY

endScript:
    MsgBox "Программка кончилась.", , "Program ended."
    'Обновляю чертеж что бы обновить поля
    ThisDrawing.SendCommand ("_regenall ")
End Sub


Sub AddMLeader(str As String, pnt As Variant)
    'Отрисовка Мультивыноски
    Dim oML As AcadMLeader
    Dim i As Long
    Set oML = ThisDrawing.ModelSpace.AddMLeader(pnt, i)
        oML.textString = str
        oML.TextJustify = acAttachmentPointMiddleCenter
        oML.ScaleFactor = 50
        oML.Layer = "0"
        oML.Update
End Sub

[CAHTEXHuK]

Странно, может кто сталкивался, или знает от чего может быть...
одну и ту же строку

Layer = "%<\AcObjProp Object(%<\_ObjId 2130398624>%).Layer>%"

Использую в обычном тексте - получается поле... а в мультивыноске обычным текстом пишет "####", не поле... (