Private Sub F_Block_Load(sender As Object, e As EventArgs) Handles MyBase.Load
SetDoubleBuffered(grdBlock)
acApp = Autodesk.AutoCAD.ApplicationServices.Application.AcadApplication
CadDoc = acApp.ActiveDocument
CadSelectionSet = CadDoc.SelectionSets.Add("SpecBlockSelect") ' создаю именнованный выбор
Refresh_Load()
End Sub
Private Sub tsFind_Click(sender As Object, e As EventArgs) Handles tsFind.Click
CadDoc.SendCommand("РЕГЕН" & vbCr) ' пытаюсь обновить атрибуты, так как угол считывается только после регенерации модели
Dim F1(0) As Short
Dim F2(0) As Object
If tsBlock.Text <> "" Then
' для выбора по блоку и по слою
' F1(0) = 0 ' поиск по слою
' F2(0) = "INSERT" ' "BLOCK"
' F1(1) = 8 ' поиск по имени 2
' F2(1) = tsLayer.Text ' tsBlock.Text ' F2(1) = "`*U*," & tsBlock.Text
' для выбора по блоку
F1(0) = 0 ' поиск по слою
F2(0) = "INSERT" ' "BLOCK"
Else
MsgBox("Блок не выбран, продолжеие не возможно", vbOKOnly + vbCritical, "Сбор данных")
Exit Sub
End If
CadSelectionSet.Select(AcSelect.acSelectionSetAll, , , F1, F2)
lblFind.Text = "Всего блоков на слое " & CStr(CadSelectionSet.Count)
Dim CadBlock As AcadBlockReference
pbStatus.Visible = True
tsStatus.Text = "Чтение данных блоков"
tsStatus.Visible = True
pbStatus.Value = 0
pbStatus.Maximum = CadSelectionSet.Count
grdBlock.Rows.Clear()
grdBlock.Columns(9).HeaderText = ""
grdBlock.Columns(10).HeaderText = ""
grdBlock.Columns(11).HeaderText = ""
grdBlock.Columns(12).HeaderText = ""
grdBlock.Columns(13).HeaderText = ""
grdBlock.Columns(14).HeaderText = ""
grdBlock.Columns(15).HeaderText = ""
grdBlock.Columns(16).HeaderText = ""
grdBlock.Columns(17).HeaderText = ""
grdBlock.Columns(18).HeaderText = ""
grdBlock.Columns(19).HeaderText = ""
grdBlock.Columns(20).HeaderText = ""
For i = 0 To CadSelectionSet.Count - 1 'для всех объектов в простр. модели
' If (CadSelectionSet.Item(i).ObjectName = "AcDbBlockReference") Then ' выбираю именно блоки
CadBlock = CadSelectionSet.Item(i) ' назначаю так как только объекты можно перебирать
If (CadBlock.EffectiveName = tsBlock.Text) Then ' получаю видимое в свойствах имя блока
grdBlock.Rows.Add()
grdBlock.Rows(grdBlock.RowCount - 1).HeaderCell.Value = Str(grdBlock.RowCount)
grdBlock.Rows(grdBlock.RowCount - 1).Cells(0).Value = CadBlock.Name & " слой " & CadBlock.Layer
grdBlock.Rows(grdBlock.RowCount - 1).Cells(1).Value = CadBlock.EffectiveName
grdBlock.Rows(grdBlock.RowCount - 1).Cells(2).Value = FormatNumber(CadBlock.InsertionPoint(0), 2) ' координата Х
grdBlock.Rows(grdBlock.RowCount - 1).Cells(3).Value = FormatNumber(CadBlock.InsertionPoint(1), 2) ' координата Y
grdBlock.Rows(grdBlock.RowCount - 1).Cells(4).Value = FormatNumber(CadBlock.InsertionPoint(2), 2) ' координата Z
grdBlock.Rows(grdBlock.RowCount - 1).Cells(5).Value = CadBlock.XScaleFactor ' масштаб блока по Х
grdBlock.Rows(grdBlock.RowCount - 1).Cells(6).Value = CadBlock.YScaleFactor ' масштаб блока по Y
grdBlock.Rows(grdBlock.RowCount - 1).Cells(7).Value = CadBlock.ZScaleFactor ' масштаб блока по Z
grdBlock.Rows(grdBlock.RowCount - 1).Cells(8).Value = FormatNumber(CadBlock.Rotation * 180 / Math.PI, 2) ' угол
' получаю параметры
Dim oBlockRef As IAcadBlockReference = CadBlock
Dim Props
With oBlockRef
If .IsDynamicBlock = True Then
Props = .GetDynamicBlockProperties
Y = 9
For Index = LBound(Props) To UBound(Props)
Dim oProp As AcadDynamicBlockReferenceProperty
oProp = Props(Index)
'is the value an array for an insertion point
If IsArray(oProp.Value) Then
Dim SubIndex As Long
For SubIndex = LBound(oProp.Value) To UBound(oProp.Value)
' grdBlock.Rows(grdBlock.RowCount - 1).Cells(10).Value = grdBlock.Rows(grdBlock.RowCount - 1).Cells(10).Value & oProp.PropertyName & ", " & oProp.Value(SubIndex)
Next SubIndex
Else
grdBlock.Rows(grdBlock.RowCount - 1).Cells(Y).Value = oProp.Value
grdBlock.Columns(Y).HeaderText = oProp.PropertyName
If Len(oProp.PropertyName) > 4 Then ' пробую отловить и перевести углы из ражианов в градусы
If Mid(oProp.PropertyName, 1, 4) = "Угол" Then
grdBlock.Rows(grdBlock.RowCount - 1).Cells(Y).Value = FormatNumber(grdBlock.Rows(grdBlock.RowCount - 1).Cells(Y).Value * 180 / Math.PI, 2) ' угол
End If
End If
Y = Y + 1
End If
Next Index
End If
End With
End If
' End If
pbStatus.Value = i
Windows.Forms.Application.DoEvents()
Next
lblFind.Text = lblFind.Text & ". Выбрано - " & grdBlock.RowCount
Y = 0
Do Until Y = grdBlock.ColumnCount
If grdBlock.Columns(Y).HeaderText = "" Then
grdBlock.Columns(Y).Visible = False
Else
grdBlock.Columns(Y).Visible = True
End If
Y = Y + 1
Loop
CadSelectionSet.Clear() ' Почистим выборку
tsStatus.Visible = False
pbStatus.Visible = False
End Sub
' ещё часть кода, заполняю combobox именами просто я искал именно определённые блоки, есть ещё пример, но там много информации считывается в общем код чистить устану
Private Sub Refresh_Load()
' форматирую картинки блокоВ, так как далее буду обрабатывать
picCapka.Enabled = False
picCapka.BorderStyle = Windows.Forms.BorderStyle.None
picCol.Enabled = False
picCol.BorderStyle = Windows.Forms.BorderStyle.None
picFlanecP.Enabled = False
picFlanecP.BorderStyle = Windows.Forms.BorderStyle.None
picFlanecS.Enabled = False
picFlanecS.BorderStyle = Windows.Forms.BorderStyle.None
picGrib.Enabled = False
picGrib.BorderStyle = Windows.Forms.BorderStyle.None
picKrest.Enabled = False
picKrest.BorderStyle = Windows.Forms.BorderStyle.None
picPerehod.Enabled = False
picPerehod.BorderStyle = Windows.Forms.BorderStyle.None
picPG.Enabled = False
picPG.BorderStyle = Windows.Forms.BorderStyle.None
picRamka.Enabled = False
picRamka.BorderStyle = Windows.Forms.BorderStyle.None
picSpusk.Enabled = False
picSpusk.BorderStyle = Windows.Forms.BorderStyle.None
picTroynik.Enabled = False
picTroynik.BorderStyle = Windows.Forms.BorderStyle.None
picZadv.Enabled = False
picZadv.BorderStyle = Windows.Forms.BorderStyle.None
' список блоков документа
X = 0
tsBlock.Items.Clear() ' сразу заполняю блоки и для таблицы
Do Until X = CadDoc.Blocks.Count
If CadDoc.Blocks.Item(X).IsDynamicBlock = True Then
tsBlock.Items.Add(CadDoc.Blocks.Item(X).Name)
' проверяю доступность блока
Select Case CadDoc.Blocks.Item(X).Name
Case "Гребёнка"
picGrib.Enabled = True
picGrib.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Задвижка 30ч39р"
picZadv.Enabled = True
picZadv.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Колодец"
picCol.Enabled = True
picCol.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Крест стальной"
picKrest.Enabled = True
picKrest.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "ПГ"
picPG.Enabled = True
picPG.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Переход"
picPerehod.Enabled = True
picPerehod.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Спускной"
picSpusk.Enabled = True
picSpusk.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Тройник стальной"
picTroynik.Enabled = True
picTroynik.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Фланец ПЭ"
picFlanecP.Enabled = True
picFlanecP.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Фланец стальной"
picFlanecS.Enabled = True
picFlanecS.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Цапковая головка"
picCapka.Enabled = True
picCapka.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
Case "Форматы"
picRamka.Enabled = True
picRamka.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
End Select
End If
X = X + 1
Loop
tsBlock.Sorted = True
' X = 0
' tsLayer.Items.Clear()
' Do Until X = CadDoc.Layers.Count
' tsLayer.Items.Add(CadDoc.Layers.Item(X).Name)
' X = X + 1
' Loop
' tsLayer.Sorted = True
lblFind.Text = ""
grdBlock.Columns(9).HeaderText = ""
grdBlock.Columns(10).HeaderText = ""
grdBlock.Columns(11).HeaderText = ""
grdBlock.Columns(12).HeaderText = ""
grdBlock.Columns(13).HeaderText = ""
grdBlock.Columns(14).HeaderText = ""
grdBlock.Columns(15).HeaderText = ""
grdBlock.Columns(16).HeaderText = ""
grdBlock.Columns(17).HeaderText = ""
grdBlock.Columns(18).HeaderText = ""
grdBlock.Columns(19).HeaderText = ""
grdBlock.Columns(20).HeaderText = ""
End Sub