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

Автор Тема: Способы вычислить точки привязки размеров, ограничения VBA.  (Прочитано 10831 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Добрый день, уважаемые коллеги.

      Тема как получить точки привязки повёрнутого размера (объект AcadDimRotated), поднималась
в разное время на разных ресурсах.

       При этом были разные результаты, но стабильно работающего
решения не было.
        Ниже приведу изыскания и несколько слов:
1 Вариант. При помощи DXF кодов

Код - Visual Basic [Выбрать]
  1. Function GetPointAcDimrotated(returnObj As AcadDimRotated)
  2. Dim temp, startPnt, endPnt, location  As Variant
  3. Dim ResArrPoint(0 To 2) As Variant
  4.  
  5.        'В командную строку передается LISP-выражение, возвращающее первую точку в WCS (код DXF - 13)
  6.        ThisDrawing.SendCommand ("(cdr (assoc 13 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
  7.         temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
  8.        'В переменную startPnt записывается массив с координатами первой точки
  9.        startPnt = Split(temp, " ", , vbTextCompare)
  10.              
  11.         'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 14)
  12.        ThisDrawing.SendCommand ("(cdr (assoc 14 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
  13.         temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
  14.         'В переменную endPnt записывается массив с координатами второй точки
  15.        endPnt = Split(temp, " ", , vbTextCompare)
  16.          
  17.        'В командную строку передается LISP-выражение, возвращающее вторую точку в WCS (код DXF - 10)
  18.        ThisDrawing.SendCommand ("(cdr (assoc 10 (entget (handent " & """" & returnObj.Handle & """" & "))))" & vbCr)
  19.         temp = Mid(CStr(ThisDrawing.GetVariable("lastprompt")), 2, Len(CStr(ThisDrawing.GetVariable("lastprompt"))) - 2)
  20.         'В переменную endPnt записывается массив с координатами второй точки
  21.        location = Split(temp, " ", , vbTextCompare)
  22.    
  23.         ResArrPoint(0) = startPnt
  24.         ResArrPoint(1) = endPnt
  25.         ResArrPoint(2) = location
  26.         GetPointAcDimrotated = ResArrPoint
  27. End Function
  28.  
  29.  
Вариант решения был предложен http://www.caduser.ru/forum/index.php?PAGE_NAME=read&FID=25&TID=7276
При переборе размеров и получении точек циклом, может вызвать ошибку такого рода:

Подсказка залетает в переменную "lastprompt"

Вариант 2. С ресурса https://forums.autodesk.com/t5/visual-basic-customization/geometry-of-rotated-dimension/td-p/2067539
Код - Visual Basic [Выбрать]
  1. Option Explicit
  2.  
  3. Private VL
  4.  
  5. Function GetVl() As Object
  6. Dim AcadVer As Integer
  7. Dim VLisp As Object
  8. AcadVer = CInt(Left$(ThisDrawing.GetVariable("ACADVER"), 2))
  9. Select Case AcadVer
  10. Case Is < 16
  11. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
  12. Case 16
  13. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
  14. Case Else
  15. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
  16. End Select
  17.  
  18. Set GetVl = VLisp
  19. End Function
  20.  
  21.  
  22. Public Function vbAssoc(pAcadObj As AcadObject, pDXFCode As Integer) As Variant
  23.  
  24. Dim VLisp As Object
  25. Dim VLispFunc As Object
  26. Dim varRetVal As Variant
  27.  
  28. Dim obj1 As Object
  29. Dim obj2 As Object
  30.  
  31. Dim strHnd As String
  32. Dim strVer As String
  33.  
  34. Dim lngCount As Long
  35. Dim i As Long
  36. Dim j As Long
  37.  
  38. On Error GoTo vbAssocError
  39.  
  40. strHnd = pAcadObj.Handle
  41.  
  42. Dim AcadVer As Integer
  43. AcadVer = CInt(Left$(ThisDrawing.GetVariable("ACADVER"), 2))
  44. Select Case AcadVer
  45. Case Is < 16
  46. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.1")
  47. Case 16
  48. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
  49. Case Else
  50. Set VLisp = ThisDrawing.Application.GetInterfaceObject("VL.Application.16")
  51. End Select
  52.  
  53. Set VLispFunc = VLisp.ActiveDocument.Functions
  54.  
  55. Set obj1 = VLispFunc.Item("read").funcall("pDXF")
  56.   varRetVal = VLispFunc.Item("set").funcall(obj1, pDXFCode)
  57. Set obj1 = VLispFunc.Item("read").funcall("pHandle")
  58.   varRetVal = VLispFunc.Item("set").funcall(obj1, strHnd)
  59. Set obj1 = VLispFunc.Item("read").funcall("(vl-princ-to-string (cdr (assoc pDXF (entget (handent pHandle)))))")
  60.   varRetVal = VLispFunc.Item("eval").funcall(obj1)
  61.  
  62. vbAssoc = varRetVal
  63.  
  64. 'clean up the newly created LISP symbols
  65. Set obj1 = VLispFunc.Item("read").funcall("(setq pDXF nil)")
  66.   varRetVal = VLispFunc.Item("eval").funcall(obj1)
  67. Set obj1 = VLispFunc.Item("read").funcall("(setq pHandle nil)")
  68.   varRetVal = VLispFunc.Item("eval").funcall(obj1)
  69.  
  70. 'release the objects or Autocad gets squirrely
  71. Set obj2 = Nothing
  72. Set obj1 = Nothing
  73. Set VLispFunc = Nothing
  74. Set VLisp = Nothing
  75.  
  76. Exit Function
  77.  
  78. vbAssocError:
  79.   Set obj2 = Nothing
  80.   Set obj1 = Nothing
  81.   Set VLispFunc = Nothing
  82.   Set VLisp = Nothing
  83.   vbAssoc = "ErrEmpty"
  84.  ' MsgBox "Error occurred " & Err.Description
  85.  
  86. End Function
  87.  
В этом методе исключения такого рода

при попытки пропустить исключение, может вызвать fatal

Вариант 3. Поиск точек внутри блока размеров
Пример 1
Код - Visual Basic [Выбрать]
  1. Sub DimR()
  2.  
  3. Dim b As AcadBlock
  4. Dim Bs As AcadBlocks
  5. Dim D As AcadDimRotated
  6. Dim Tp As Variant, insPt As Variant
  7. Dim Ent As AcadEntity
  8. Dim i As Integer
  9. Dim Fluff As Double
  10. Dim StartPoint As AcadPoint
  11. Dim EndPoint As AcadPoint
  12. Dim location As AcadPoint
  13.  
  14. Fluff = 1
  15. ThisDrawing.Utility.GetEntity D, Tp
  16. Tp = D.TextPosition
  17.  
  18. Set Bs = ThisDrawing.Blocks
  19.  
  20. For Each b In Bs
  21.    If Not Left(b.Name, 2) = "*D" Then GoTo SkipBlock
  22.    For Each Ent In b
  23.      If TypeOf Ent Is AcadMText Then
  24.       ' Debug.Print Tp(0)
  25.       insPt = Ent.InsertionPoint
  26.        
  27. For i = 0 To 2
  28.     If Abs(insPt(i) - Tp(i)) > Fluff Then GoTo SkipBlock
  29. Next i
  30.  
  31.  Set StartPoint = b.Item(6)
  32.  Set EndPoint = b.Item(7)
  33.  Set location = b.Item(8)
  34.  
  35.     ThisDrawing.ModelSpace.AddPoint StartPoint.Coordinates
  36.     ThisDrawing.ModelSpace.AddPoint EndPoint.Coordinates
  37.     ThisDrawing.ModelSpace.AddPoint location.Coordinates
  38.  
  39.  Debug.Print StartPoint.Coordinates(0); StartPoint.Coordinates(1); StartPoint.Coordinates(2)
  40.  Debug.Print EndPoint.Coordinates(0); EndPoint.Coordinates(1); EndPoint.Coordinates(2)
  41.  Debug.Print location.Coordinates(0); location.Coordinates(1); location.Coordinates(2)
  42.  
  43.  
  44.  Exit Sub
  45. End If
  46. Next Ent
  47. SkipBlock:
  48. Next b
  49.  
  50. End Sub
  51.  
Самое весёлое, что не угадаешь в каком случае в каком Item будет храниться именно StartPoint,
EndPoint, location. Содержание блока размера в одном и другом файле разные см картинку ниже:

Пример 2

Код - Visual Basic [Выбрать]
  1.  ;DSub DimR()
  2.  
  3. Dim b As AcadBlock
  4. Dim Object As AcadObject
  5. Dim PickedPoint As Variant, TransMatrix As Variant, ContextData As Variant
  6. Dim HasContextData As String
  7.  
  8. ' Get the sub entity and a pick point
  9. ThisDrawing.Utility.GetSubEntity Object, PickedPoint, TransMatrix, ContextData
  10. Debug.Print "Selected object is a " & Object.ObjectName
  11.  
  12. ' Get the main entity at the picked point
  13. Dim ss1 As AcadSelectionSet
  14. Set ss1 = ThisDrawing.SelectionSets.Add("testSel")
  15. ss1.SelectAtPoint (PickedPoint)
  16. Dim obj2 As Object
  17. Set obj2 = ss1(0)
  18. ss1.Delete
  19. ' obj2 is the Main entity at the pick point
  20. Debug.Print obj2.ObjectName
  21. ' Ensure the main entity is a rotated dimension
  22. If obj2.ObjectName = "AcDbRotatedDimension" Then
  23. ' Get the Owning object, this will be the Block, object is the sub entity selected
  24. Dim obj As Object
  25. Set obj = ThisDrawing.ObjectIdToObject(Object.OwnerID)
  26.  
  27. Dim myBlk As AcadBlock
  28. Set myBlk = obj
  29. Debug.Print "Selected object owner is a block named " & myBlk.Name
  30.  
  31. Set b = ThisDrawing.Blocks(myBlk.Name)
  32. Stop
  33. ThisDrawing.ModelSpace.AddCircle b(8).Coordinates, 3
  34. ThisDrawing.ModelSpace.AddCircle b(9).Coordinates, 3
  35. ThisDrawing.ModelSpace.AddCircle b(7).Coordinates, 3
  36. ThisDrawing.Application.Update
  37. Else
  38. MsgBox "Selected entity not a rotated dimension"
  39. End If
  40.  
  41. End Sub
  42.  
  43.  

Коллеги, прошу помочь разобраться. Своим умом не получается. Знаю что из VBA свойства не доступны,
ищу стабильный, альтернативный способ получения точек.


Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Знаю что из VBA свойства не доступны,
ищу стабильный, альтернативный способ получения точек.
Стабильный альтернативный способ - перейти на .NET
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Увы, в данном проекте пока не могу. Большая часть кода на VBA. Такое количество не перепишу

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Увы, в данном проекте пока не могу. Большая часть кода на VBA. Такое количество не перепишу
Зачем переписывать всё? Только те функции, которые нельзя реализовать на VBA.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Как альтернатива использовать метод Export выбранного размера в dxf и потом анализировать DXF-файл
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Если не затруднит... Как допустим отдельно в составе VBA отработать код VB.net ?
Метод Export что даст? Если не трудно кусочек кода.
Допустим на данный момент я обрабатываю DXF в котором после экспорта специализированного
ПО размеры получились плохими - битыми,если просто поменять им стиль, то слетает положение размеров (не в рядок, а в разброс).
Вот и приходится считывать с начало точки, а потом перерисовывать размер
 Ниже приведу файл и картинку, может мысль подкините (может что то я не то делаю)?



Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Метод Export что даст?
Это если только на VBA (без .NET) делать. Метод EXPORT даст создать dxf-файл, ты его читаешь как текстовый файл и находишь координаты точек. Типа вариант 2., но через файл.
Как допустим отдельно в составе VBA отработать код VB.net ?
Загрузить .NET-сборку в которой будет определена команда (или функция) и вызвать эту команду/функцию через SendCommand
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Цитировать
Загрузить .NET-сборку в которой будет определена команда (или функция) и вызвать эту команду/функцию через SendCommand

В этом варианте нужно постоянно обмениваться, с начало считать координаты- записать куда-то-потом вернуться в VBA считать и так
столько, сколько размеров

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Прошу подсказать как выбрать всё что касается размера в dxf  в файле. При экспорте получилось 180000 строк- глаза разбегаются

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
AcDbDimension
  2
*D19
 10
190.0000000000001
 20
-5.0
 30
0.0
 11
190.0000000000002
 21
292.0000000000002
 31
0.0
 70
    32
  1
 
 71
     5
 42
594.0000000000004
 73
     0
 74
     0
 75
     0
  3
Standard
100
AcDbAlignedDimension
 13
190.0000000000002
 23
589.0000000000005
 33
0.0
 14
190.0000000000004
 24
-5.0
 34
0.0
 50
90.0
100
По каким признакам отсеивать нужные точки

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Прошу подсказать как выбрать всё что касается размера в dxf  в файле. При экспорте получилось 180000 строк- глаза разбегаются
Пример из документации:

Код - Visual Basic [Выбрать]
  1. Sub Example_Export()
  2.     ' This example exports the current drawing to DXF format.
  3.    ' Note that a valid selection set must be provided, even
  4.    ' though the contents of the selection set are ignored.
  5.    
  6.     ' Define the name for the exported file
  7.    Dim exportFile As String
  8.     exportFile = "C:\AutoCAD\DXFExport"     ' Adjust path to match your system
  9.    
  10.     ' Create an empty selection set
  11.    Dim sset As AcadSelectionSet
  12.     Set sset = ThisDrawing.SelectionSets.Add("TEST")
  13.    
  14.     ' Export the current drawing to the file specified above.
  15.    ThisDrawing.Export exportFile, "DXF", sset
  16.    
  17. End Sub
  18.  
В sset нужно загнать только один размер.
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Уже написал....
Код - Visual Basic [Выбрать]
  1. Sub Export()
  2.   Dim oDimSset As AcadSelectionSet
  3.   Dim intDXF(0) As Integer
  4.   Dim varVal(0) As Variant
  5.   Dim D As AcadDimRotated
  6.   Dim Tp As Variant, insPt As Variant
  7.  
  8.    With ThisDrawing.SelectionSets
  9.        While .Count > 0
  10.              .Item(0).Delete
  11.        Wend
  12.           Set oDimSset = .Add("DimOnly")
  13.    End With
  14.    
  15.       intDXF(0) = 0
  16.       varVal(0) = "DIMENSION"
  17.       Mode = acSelectionSetAll
  18.       oDimSset.Select Mode, , , intDXF, varVal
  19.   Dim exportFile As String
  20.   exportFile = "C:\DXFExprt"
  21.   ThisDrawing.Export exportFile, "DXF", oDimSset
  22.  
  23. End Sub
  24.  

Самый смак как отсеить...!
Застрял на том как  определить в dxf файле сам размер AcadDimRotated.
По сути сделал набор в нём смотрю TextPosition от размера,
лезу в файл и ищу сам размер по этому признаку и вот тут затык - как найти?
Есть анонимный блок и в нём нет кодов 13, 14 и 10.....



Оффлайн Александр Ривилис

  • Administrator
  • *****
  • Сообщений: 13829
  • Карма: 1784
  • Рыцарь ObjectARX
  • Skype: rivilis
Застрял на том как  определить в dxf файле сам размер AcadDimRotated.
Ищи AcDbRotatedDimension
Не забывайте про правильное Форматирование кода на форуме
Создание и добавление Autodesk Screencast видео в сообщение на форуме
Если Вы задали вопрос и на форуме появился правильный ответ, то не забудьте про кнопку Решение

Оффлайн ВасилийАвтор темы

  • ADN OPEN
  • Сообщений: 26
  • Карма: 0
Не вопрос нашёл
AcDbRotatedDimension
1001
AcadAnnotative
1000
AnnotativeData
1002
{
1070
     1
1070
     0
1002
}
1001
ACAD
1000
DSTYLE
1002
{
1070
    40
1040
1.0
1070
   279
1070
     0
1070
   289
1070
     3
1070
   174
1070
     0
1070
   175
1070
     0
1070
   172
1070
     1
1070
   145
1040
1.0
1002
}
  0
Нет намёка на координаты.
Не могу сообразить парсинг....