Аналог команды AutoCad "Команда:_3dalign" на VBA

[Vladimir]

Доброго времени суток!
Подскажите аналог команды AutoCad "Команда:_3dalign" на VBA ?
Примеры, ссылки приветствуются!

[Александр Ривилис]

Средствами ObjectARX это делается так:

Код - C++ [Выбрать]

1. static void ALIGN3(void)
2. {
3.   ads_name en; ads_point p1; ads_point p2;
4.   if (acedEntSel(_T("\nВыберите объект: "),en,p1)         != RTNORM ||
5.     acedGetPoint(NULL,_T("\nПервая исходная точка: "),p1) != RTNORM ||
6.     acedGetPoint(p1,  _T("\nПервая целевая точка: "), p2) != RTNORM) return;
7.   acdbUcs2Wcs(p1,p1,false); acdbUcs2Wcs(p2,p2,false);
8.   AcGePoint3d pSrcPt1(p1[X],p1[Y],p1[Z]); AcGePoint3d pDestPt1(p2[X],p2[Y],p2[Z]);
9.   if (acedGetPoint(NULL,_T("\nВторая исходная точка: "),p1) != RTNORM ||
10.       acedGetPoint(p1,  _T("\nВторая целевая точка: "), p2) != RTNORM) return;
11.   acdbUcs2Wcs(p1,p1,false); acdbUcs2Wcs(p2,p2,false);
12.   AcGePoint3d pSrcPt2(p1[X],p1[Y],p1[Z]); AcGePoint3d pDestPt2(p2[X],p2[Y],p2[Z]);
13.   if (acedGetPoint(NULL,_T("\nТретья исходная точка: "),p1) != RTNORM ||
14.       acedGetPoint(p1,  _T("\nТретья целевая точка: "), p2) != RTNORM) return;
15.   acdbUcs2Wcs(p1,p1,false); acdbUcs2Wcs(p2,p2,false);
16.   AcGePoint3d pSrcPt3(p1[X],p1[Y],p1[Z]); AcGePoint3d pDestPt3(p2[X],p2[Y],p2[Z]);
17.   AcGeVector3d v1(pSrcPt1  - pSrcPt2);
18.   AcGeVector3d v2(pDestPt1 - pDestPt2);
19.   AcDbObjectId id; acdbGetObjectId(id,en);
20.   AcDbEntityPointer pEnt(id,AcDb::kForWrite);
21.   if (pEnt.openStatus() != Acad::eOk) return;
22.   AcGeMatrix3d mMatScale, mMatRot, mMatTrans;
23.   mMatScale.setToScaling(v2.length()/v1.length(),pSrcPt1);
24.   pEnt->transformBy(mMatScale); // Масштабируем
25.   AcGePlane pl1(pSrcPt1,pSrcPt1-pSrcPt2,pSrcPt1-pSrcPt3),
26.             pl2(pDestPt1,pDestPt1-pDestPt2,pDestPt1-pDestPt3);
27.   AcGePoint3d pOrig1,pOrig2; AcGeVector3d vX1,vX2,vY1,vY2,vZ1,vZ2;
28.   pl1.getCoordSystem(pOrig1,vX1,vY1); pl2.getCoordSystem(pOrig2,vX2,vY2);
29.   mMatTrans.setToAlignCoordSys(pSrcPt1,vX1,vY1,pl1.normal(),pDestPt1,vX2,vY2,pl2.normal());
30.   pEnt->transformBy(mMatTrans); // Остальные преобразования
31.   pEnt->close();
32. }

На VBA не пишу. Думаю, что для тебя проще будет подготовить данные (точки и имя  примитива) и запустить команду _3dalign через SendCommand. Ну или придётся переписывать работу с матрицами с ObjectARX на VBA.

[Vladimir]

Ок, спасибо.
По получению результата отпишусь.

[Vladimir]

Подготовил следующий код...

Код - Visual Basic [Выбрать]

1. Sub ALIGN_3D()
2. 'Создаем конус с целью его выравнивания
3. Dim Object_Cone As AcadObject
4. Dim Point_Center(0 To 2) As Double
5.     Point_Center(0) = x0: Point_Center(1) = y0: Point_Center(2) = z0
6. Set Object_Cone = ThisDrawing.ModelSpace.AddCone(Point_Center, 5#, 20#) '  создан конус
7.  
8. 'Создаем линию с целью  выравнивания по ней конуса
9. Dim Object_line As AcadObject
10. Dim Point_start(0 To 2) As Double
11. Dim Point_end(0 To 2) As Double
12.     Point_start(0) = 5: Point_start(1) = 5: Point_start(2) = 5
13.     Point_end(0) = 25: Point_start(1) = 25: Point_start(2) = 25
14. Set Object_line = ThisDrawing.ModelSpace.AddLine(Point_start, Point_end) ' создана линия
15. end sub
16.  

  Далее нам нужно через SendCommand запустить "Команда:_3dalign"
А это повлечет за собой выбор объекта в ручную, как собственно и

Код - Visual Basic [Выбрать]

1. ThisDrawing.Utility.GetEntity obj, pt, "Выберите примитив: "
2.  

Вот от сюда пожалуйста поподробнее....
Как программно загнать в "Команда:_3dalign" Object_Cone и координаты точек выранивания.
Пример если можно.

[Александр Ривилис]

1. Получаешь метку Object_Cone (я так понимаю, что именно его ты и собираешься выравнивать): Object_Cone.Handle
2. Линия для выравнивания тебе не нужна - нужны просто точки.
3. Формируешь строку вида '(command "_3dalign" (handent "' + Object_Cone.Handle + '") "" x01,y01,z01 x11,y11,z11 x21,y21,z21 ...)" '
где x,y,z соответствующие координаты точек (превращенные в строки), как в команде _3DALIGN
4. Эту строку в SendCommand
Пробуй.

[Vladimir]

Код для метки я написал...

Код - Visual Basic [Выбрать]

1. Dim id_code As String
2. id_code = Object_Cone.Handle ' определяем уникальный ид созданого конуса для последующего обращения к нему
3. Dim object_id As AcadObject
4. Set object_id = ThisDrawing.HandleToObject(id_code)

Потом засомневался.....
А нужен ли он?
Ведь объектная переменная Object_Cone еще жива.
Поправьте если ошибаюсь.
Про линиию и точки само собой, просто с линией нагляднее....
Пробую, отпишусь.

[Александр Ривилис]

А нужен ли он?
Ведь обектная переменная Object_Cone еще жива.

Ты в команду передаешь не переменную, а строковое значение её метки - ни lisp, ни команда не умеют оперировать переменными. Так что можешь передавать или Object_Cone.Handle или id_code. Разницы нет.

[Vladimir]

Заплутал в "кавычках"
Строчку

3. Формируешь строку вида '(command "_3dalign" (handent "' + Object_Cone.Handle + '") "" x01,y01,z01 x11,y11,z11 x21,y21,z21 ...)" '

Дайте в строковом формате, какой она должна быть.
Я ее сам склею.

[Александр Ривилис]

Что-то такое:

Код - Visual Basic [Выбрать]

1. Sub ALIGN_3D()
2. 'Создаем конус с целью его выравнивания
3. Dim Object_Cone As AcadObject
4. Dim Point_Center(0 To 2) As Double
5.     Point_Center(0) = 0: Point_Center(1) = 0: Point_Center(2) = 0
6. Set Object_Cone = ThisDrawing.ModelSpace.AddCone(Point_Center, 5#, 20#) '  создан конус
7.  
8. Dim P0(0 To 2) As Double: P0(0) = Point_Center(0): P0(1) = Point_Center(1): P0(2) = Point_Center(2)
9. Dim P1(0 To 2) As Double: P1(0) = Point_Center(0): P1(1) = Point_Center(1): P1(2) = Point_Center(2) + 20
10. Dim P2(0 To 2) As Double: P2(0) = 0: P2(1) = 690: P2(2) = 0
11. Dim P3(0 To 2) As Double: P3(0) = 1010: P3(1) = 1050: P3(2) = 0
12.  
13. Dim cmd As String
14. cmd = "(command ""_3DALIGN"" (handent """ + Object_Cone.Handle + """) """" "
15. cmd = cmd + PointToString(P0) + " "
16. cmd = cmd + PointToString(P1) + " "
17. cmd = cmd + """_C"" "
18. cmd = cmd + PointToString(P2) + " "
19. cmd = cmd + PointToString(P3)
20. cmd = cmd + """_X"""
21. cmd = cmd + ") "
22. MsgBox cmd
23. ThisDrawing.SendCommand cmd
24.  
25. End Sub
26.  
27. Function PointToString(p() As Double) As String
28.   PointToString = """" + CStr(p(0)) + "," + CStr(p(1)) + "," + CStr(p(2)) + """"
29. End Function
30.  

Надеюсь дальше сам доведёшь до ума?

[Vladimir]

Спасибо.
Тут уже все доведено....

[Vladimir]

Доброго дня!
Александр, в решении закралась ошибка....
При получении координаты точки через функцию GetPoint, в случае наличия в ней десятичных значений, возвращает координату с разделителем ","
А команда _3dalign требует разделитель "."
Пробуй пример....

Код - Visual Basic [Выбрать]

1. Sub ALIGN_3D_error()
2.  
3. 'Создаем конус с целью его выравнивания
4.  
5. Dim Object_Cone As AcadObject
6. Dim Point_Center(0 To 2) As Double
7.  
8.     Point_Center(0) = 0: Point_Center(1) = 0: Point_Center(2) = 0
9.  
10. Set Object_Cone = ThisDrawing.ModelSpace.AddCone(Point_Center, 5#, 20#) '  создан конус
11.  
12. 'создаем две линии для проверки
13. Dim line_1 As AcadLine 'с целыми числами в координатах концов отрезков
14. Dim line_2 As AcadLine 'с наличием десятичных чисел в координатах концов отрезков
15.  
16. Dim pt1(0 To 2) As Double: pt1(0) = 100: pt1(1) = 0: pt1(2) = 0:
17. Dim pt2(0 To 2) As Double: pt2(0) = 100: pt2(1) = 0: pt2(2) = 100:
18. Set line_1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2) '
19.  
20. Dim pt21(0 To 2) As Double: pt21(0) = -100: pt21(1) = 0: pt21(2) = 0:
21. Dim pt22(0 To 2) As Double: pt22(0) = -100: pt22(1) = 0: pt22(2) = 99.123: ' вот эта подлая координата
22. Set line_2 = ThisDrawing.ModelSpace.AddLine(pt21, pt22) '
23. '
24.  
25. 'передаем координаты конуса
26. Dim P0(0 To 2) As Double: P0(0) = Point_Center(0): P0(1) = Point_Center(1): P0(2) = Point_Center(2)
27. Dim P1(0 To 2) As Double: P1(0) = Point_Center(0): P1(1) = Point_Center(1): P1(2) = Point_Center(2) + 10
28.  
29.  
30. Dim P2 As Variant
31. Dim P3 As Variant
32. P2 = ThisDrawing.Utility.GetPoint(, "Укажите координаты начала линии: ")
33. P3 = ThisDrawing.Utility.GetPoint(, "Укажите координаты конца линии: ")
34.  
35. Dim P22(0 To 2) As Double: P22(0) = P2(0): P22(1) = P2(1): P22(2) = P2(2)
36. Dim P32(0 To 2) As Double: P32(0) = P3(0): P32(1) = P3(1): P32(2) = P3(2)
37.  
38.  
39. Dim cmd As String
40.  
41. cmd = "(command ""_3DALIGN"" (handent """ + Object_Cone.Handle + """) """" "
42.  
43. cmd = cmd + PointToString(P1) + " "
44.  
45. cmd = cmd + PointToString(P0) + " "
46.  
47. cmd = cmd + """_C"" "
48.  
49. cmd = cmd + PointToString(P22) + " "
50.  
51. cmd = cmd + PointToString(P32)
52.  
53. cmd = cmd + """_X"""
54.  
55. cmd = cmd + ") "
56.  
57. MsgBox cmd
58.  
59. ThisDrawing.SendCommand cmd
60.  
61.  
62.  
63. End Sub
64.  
65.  
66.  
67. Function PointToString(p() As Double) As String
68.  
69.   PointToString = """" + CStr(p(0)) + "," + CStr(p(1)) + "," + CStr(p(2)) + """"
70.  
71. End Function
72.  

Конечно, можно в 34 строке создать обработчик с поиском и заменой "," -->"."
Будет ли это единственно правильным и не тривиальным решением?

[Александр Ривилис]

Конечно, можно в 34 строке создать обработчик с поиском и заменой "," -->"."
Будет ли это единственно правильным и не тривиальным решением?

В 34 строке кода у тебя еще нет строк с координатами. Всё нужно сделать тривиальнее. Нужно лишь заменить функцию PointToString на эту:

Код - Visual Basic [Выбрать]

1. Function PointToString(p() As Double) As String
2.      
3.       PointToString = """" + _
4.         Replace(CStr(p(0)), ",", ".") + "," + _
5.         Replace(CStr(p(1)), ",", ".") + "," + _
6.         Replace(CStr(p(2)), ",", ".") + """"
7.      
8. End Function

[Vladimir]

Ок, спасибо!
Это красивое решение.