[ArtemYa]

Задачка следующая: макрос выбирает координату Х вставки блоков на чертеже, записывает их в массив, сортирует, далее нужно каждую цифру массива вынести отдельным текстом (не MTEXT) на чертеж в столбец с определенным расстоянием между строк, каким образом это можно сделать, подскажите пожалуйста!!!

[Олег (jr.)]

Сообщение от ArtemYa Задачка следующая: макрос выбирает координату Х вставки блоков на чертеже, записывает их в массив, сортирует, далее нужно каждую цифру массива вынести отдельным текстом (не MTEXT) на чертеж в столбец с определенным расстоянием между строк, каким образом это можно сделать, подскажите пожалуйста!!!

Попробуй

Код:

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

Option Explicit

Sub BlockTable()
Dim oEnt As AcadEntity
Dim oBlock As AcadBlockReference
Dim oText As AcadEntity
Dim varpt As Variant
Dim ftype(1) As Integer
Dim fdata(1) As Variant
Dim dxfCode, dxfValue
Dim txtHeight As Double
Dim txtSpace As Double
Dim counter

     Dim oSset As AcadSelectionSet
          With ThisDrawing.SelectionSets
               While .Count > 0
                    .Item(0).Delete
               Wend
          Set oSset = .Add("Blocks")
          End With

   ftype(0) = 0: ftype(1) = 66
   fdata(0) = "INSERT": fdata(1) = 1
   dxfCode = ftype: dxfValue = fdata
   
oSset.SelectOnScreen dxfCode, dxfValue
MsgBox oSset.Count
ReDim blockdata(0 To oSset.Count - 1, 0 To 1) As Variant

For Each oEnt In oSset
Set oBlock = oEnt
blockdata(counter, 0) = counter
blockdata(counter, 1) = oBlock.InsertionPoint(0)
counter = counter + 1
Next

Dim sortedData As Variant
sortedData = CoolSort(blockdata, 2)
varpt = ThisDrawing.Utility.GetPoint(, vbLf & "Верхняя левая точка")
txtHeight = CDbl(InputBox("Высота текста", "", 200))
txtSpace = CDbl(InputBox("Промежуток между строками", "", 150))

For counter = 0 To UBound(sortedData)
Dim inspt(2) As Double
inspt(0) = CDbl(varpt(0))
inspt(1) = CDbl(varpt(1) - (counter * (txtHeight + txtSpace)))
inspt(2) = CDbl(varpt(2))

Set oText = ThisDrawing.ActiveLayout.Block.AddText( _
Format(CStr(sortedData(counter, 1)), "0.000"), inspt, txtHeight)
Next

End Sub
' see also:
'  http://forum.developing.ru/showthread.php?p=53799#post53799
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed '
' SourceArr - two dimensional array '
' iPos - physical column number (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant

Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer

iPos = iPos - 1
Check = False

Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop

CoolSort = SourceArr

End Function

~'J'~

[ArtemYa]

спасибо, Олег, разобрался!!