Добрый день, уважаемые коллеги.
Тема как получить точки привязки повёрнутого размера (объект AcadDimRotated), поднималась
в разное время на разных ресурсах.
При этом были разные результаты, но стабильно работающего
решения не было.
Ниже приведу изыскания и несколько слов:
1 Вариант. При помощи DXF кодов
Function GetPointAcDimrotated(returnObj As AcadDimRotated)
Dim temp, startPnt, endPnt, location As Variant
Dim ResArrPoint(0 To 2) As Variant
'В командную строку передается LISP-выражение, возвращающее первую точку в WCS (код DXF - 13)
ThisDrawing.SendCommand ("(cdr (assoc 13 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
'В переменную startPnt записывается массив с координатами первой точки
startPnt = Split(temp, " ", , vbTextCompare)
'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 14)
ThisDrawing.SendCommand ("(cdr (assoc 14 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
'В переменную endPnt записывается массив с координатами второй точки
endPnt = Split(temp, " ", , vbTextCompare)
'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 10)
ThisDrawing.SendCommand ("(cdr (assoc 10 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
'В переменную endPnt записывается массив с координатами второй точки
location = Split(temp, " ", , vbTextCompare)
ResArrPoint(0) = startPnt
ResArrPoint(1) = endPnt
ResArrPoint(2) = location
GetPointAcDimrotated = ResArrPoint
End Function
Подсказка залетает в переменную "lastprompt"
Вариант 2. С ресурса
https://forums.autodesk.com/t5/visual-basic-customization/geometry-of-rotated-dimension/td-p/2067539Option Explicit
Private VL
Function GetVl() As Object
Dim AcadVer As Integer
Dim VLisp As Object
AcadVer = CInt(Left$(ThisDrawing.GetVariable("ACADVER"), 2))
Select Case AcadVer
Case Is < 16
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
Case 16
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Case Else
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
End Select
Set GetVl = VLisp
End Function
Public Function vbAssoc(pAcadObj As AcadObject, pDXFCode As Integer) As Variant
Dim VLisp As Object
Dim VLispFunc As Object
Dim varRetVal As Variant
Dim obj1 As Object
Dim obj2 As Object
Dim strHnd As String
Dim strVer As String
Dim lngCount As Long
Dim i As Long
Dim j As Long
On Error GoTo vbAssocError
strHnd = pAcadObj.Handle
Dim AcadVer As Integer
AcadVer = CInt(Left$(ThisDrawing.GetVariable("ACADVER"), 2))
Select Case AcadVer
Case Is < 16
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
Case 16
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
Case Else
Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
End Select
Set VLispFunc = VLisp.ActiveDocument.Functions
Set obj1 = VLispFunc.Item("read").funcall("pDXF")
varRetVal = VLispFunc.Item("set").funcall(obj1, pDXFCode)
Set obj1 = VLispFunc.Item("read").funcall("pHandle")
varRetVal = VLispFunc.Item("set").funcall(obj1, strHnd)
Set obj1 = VLispFunc.Item("read").funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
vbAssoc = varRetVal
'clean up the newly created LISP symbols
Set obj1 = VLispFunc.Item("read").funcall("(setq pDXF nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
Set obj1 = VLispFunc.Item("read").funcall("(setq pHandle nil)")
varRetVal = VLispFunc.Item("eval").funcall(obj1)
'release the objects or Autocad gets squirrely
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
Exit Function
vbAssocError:
Set obj2 = Nothing
Set obj1 = Nothing
Set VLispFunc = Nothing
Set VLisp = Nothing
vbAssoc = "ErrEmpty"
' MsgBox "Error occurred " & Err.Description
End Function
В этом методе исключения такого рода
при попытки пропустить исключение, может вызвать fatal
Вариант 3. Поиск точек внутри блока размеров
Пример 1
Sub DimR()
Dim b As AcadBlock
Dim Bs As AcadBlocks
Dim D As AcadDimRotated
Dim Tp As Variant, insPt As Variant
Dim Ent As AcadEntity
Dim i As Integer
Dim Fluff As Double
Dim StartPoint As AcadPoint
Dim EndPoint As AcadPoint
Dim location As AcadPoint
Fluff = 1
ThisDrawing.Utility.GetEntity D, Tp
Tp = D.TextPosition
Set Bs = ThisDrawing.Blocks
For Each b In Bs
If Not Left(b.Name, 2) = "*D" Then GoTo SkipBlock
For Each Ent In b
If TypeOf Ent Is AcadMText Then
' Debug.Print Tp(0)
insPt = Ent.InsertionPoint
For i = 0 To 2
If Abs(insPt(i) - Tp(i)) > Fluff Then GoTo SkipBlock
Next i
Set StartPoint = b.Item(6)
Set EndPoint = b.Item(7)
Set location = b.Item(8)
ThisDrawing.ModelSpace.AddPoint StartPoint.Coordinates
ThisDrawing.ModelSpace.AddPoint EndPoint.Coordinates
ThisDrawing.ModelSpace.AddPoint location.Coordinates
Debug.Print StartPoint.Coordinates(0); StartPoint.Coordinates(1); StartPoint.Coordinates(2)
Debug.Print EndPoint.Coordinates(0); EndPoint.Coordinates(1); EndPoint.Coordinates(2)
Debug.Print location.Coordinates(0); location.Coordinates(1); location.Coordinates(2)
Exit Sub
End If
Next Ent
SkipBlock:
Next b
End Sub
Самое весёлое, что не угадаешь в каком случае в каком Item будет храниться именно StartPoint,
EndPoint, location. Содержание блока размера в одном и другом файле разные см картинку ниже:
Пример 2
;DSub DimR()
Dim b As AcadBlock
Dim Object As AcadObject
Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant
Dim HasContextData As String
' Get the sub entity and a pick point
ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData
Debug.Print "Selected object is a " & Object.ObjectName
' Get the main entity at the picked point
Dim ss1 As AcadSelectionSet
Set ss1 = ThisDrawing.SelectionSets.Add("testSel")
ss1.SelectAtPoint (PickedPoint)
Dim obj2 As Object
Set obj2 = ss1(0)
ss1.Delete
' obj2 is the Main entity at the pick point
Debug.Print obj2.ObjectName
' Ensure the main entity is a rotated dimension
If obj2.ObjectName = "AcDbRotatedDimension" Then
' Get the Owning object, this will be the Block, object is the sub entity selected
Dim obj As Object
Set obj = ThisDrawing.ObjectIdToObject(Object.OwnerID)
Dim myBlk As AcadBlock
Set myBlk = obj
Debug.Print "Selected object owner is a block named " & myBlk.Name
Set b = ThisDrawing.Blocks(myBlk.Name)
Stop
ThisDrawing.ModelSpace.AddCircle b(8).Coordinates, 3
ThisDrawing.ModelSpace.AddCircle b(9).Coordinates, 3
ThisDrawing.ModelSpace.AddCircle b(7).Coordinates, 3
ThisDrawing.Application.Update
Else
MsgBox "Selected entity not a rotated dimension"
End If
End Sub
Коллеги, прошу помочь разобраться. Своим умом не получается. Знаю что из VBA свойства не доступны,
ищу стабильный, альтернативный способ получения точек.
