Тема: Как вставить координаты блока в его атрибуты?
Помогите реализовать программный код, посредством которого в атрибуты блока вписываются значения его координат. Заранее благодарен!
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → VBA → Как вставить координаты блока в его атрибуты?
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Помогите реализовать программный код, посредством которого в атрибуты блока вписываются значения его координат. Заранее благодарен!
> KyCOK
Возьми за основу
Устанавливает значение атрибутов для всех блоков
рисунка с указанным именем
Option Explicit ' Выставить в опциях: ' Tools->Options->General->Break on Unhandled Errors Sub ChAttByInsPoint() Dim oSset As AcadSelectionSet Dim oBlkRef As AcadBlockReference Dim oAttRef() As AcadAttributeReference Dim ftype(2) As Integer Dim fdata(2) As Variant Dim dxfCode, dxfValue Dim bname As String Dim i As Long On Error GoTo Error_Control With ThisDrawing.SelectionSets While .Count > 0 .Item(0).Delete Wend Set oSset = .Add("XYZ_Blocks") ' приемлемо любое имя для набора End With bname = InputBox("Введите имя блока:", "Редактирование атрибутов") If StrComp(bname, "") = 0 Then Exit Sub If Not BlockExists(ThisDrawing, bname) Then MsgBox "Блок с именем " & Chr(34) & bname & Chr(34) & "не существует" Exit Sub End If ftype(0) = 0: ftype(1) = 2: ftype(2) = 66 fdata(0) = "INSERT": fdata(1) = bname: fdata(2) = 1 dxfCode = ftype: dxfValue = fdata oSset.Select acSelectionSetAll, , , dxfCode, dxfValue If oSset.Count = 0 Then Exit Sub For Each oBlkRef In oSset If oBlkRef.HasAttributes = True Then oAttRef = oBlkRef.GetAttributes Dim InsPt As Variant InsPt = oBlkRef.InsertionPoint For i = LBound(oAttRef) To UBound(oAttRef) Dim objAtt As AcadAttributeReference Set objAtt = oAttRef(i) Select Case UCase(oAttRef(i).TagString) Case "X" ' атрибут для Х координаты objAtt.TextString = CStr(Round(CDbl(InsPt(0)), 3)) Case "Y" ' атрибут для Y координаты objAtt.TextString = CStr(Round(CDbl(InsPt(1)), 3)) Case "Z" ' атрибут для Z координаты objAtt.TextString = CStr(Round(CDbl(InsPt(2)), 3)) End Select objAtt.Update Next Erase oAttRef End If Next Exit_Here: oSset.Delete If Not oBlkRef Is Nothing Then Set oBlkRef = Nothing Exit Sub Error_Control: Select Case Err.Number Case -2147024809 Resume Exit_Here Case Else MsgBox Err.Description, vbCritical Err.Clear Resume Exit_Here End Select End Sub Public Function BlockExists(aDoc As AcadDocument, blkName As String) As Boolean Dim oBlock As AcadBlock On Error Resume Next Set oBlock = aDoc.Blocks(blkName) BlockExists = (Err.Number = 0) End Function
~'J'~
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → VBA → Как вставить координаты блока в его атрибуты?
Форум работает на PunBB, при поддержке Informer Technologies, Inc