Работа с дугой

Работа с дугой · 12.06.2009, 09:53

Подскажите как начертить дугу по трем точкам, а не указывать центр, радиус и углы повотора.

И есть ли в VBA привязки?

Вот мой код.
Проблема в неточности построения.

Код:

[Выделить все]

Option Explicit
Const Pi = 3.1416
Sub CL()
Dim E, K As Integer
Dim H As Long
E = 7841 'габариты
K = 95
H = 80734 'радиус
Dim F, L, G As Integer
Dim I As Long
F = 7612  'габариты
L = 92
I = 78374 'радиус
G = 2453
' Построение дуги (нижняя)
' Описываем используемые переменные для дуги (нижняя)
Dim arcObj_1 As AcadArc
Dim Center_1(0 To 2) As Double
Dim StartAngle_1 As Double
Dim EndAngle_1 As Double
Dim radius_1 As Double
' параметры дуги
Center_1(0) = 0: Center_1(1) = H: Center_1(2) = 0
radius_1 = H
StartAngle_1 = Atn(((H - K) / (E / 2))) + Pi

EndAngle_1 = ((Pi / 2 - (Atn((H - K) / (E / 2)))) * 2) + Atn(((H - K) / (E / 2))) + Pi

' Команда построения дуги по заданным параметрам (нижняя)
Set arcObj_1 = ThisDrawing.ModelSpace.AddArc(Center_1, radius_1, StartAngle_1, EndAngle_1)


' Описываем используемые переменные для дуги (верхняя)
Dim arcObj_2 As AcadArc
Dim Center_2(0 To 2) As Double
Dim StartAngle_2 As Double
Dim EndAngle_2 As Double
Dim radius_2 As Double
' параметры дуги (верхняя)
Center_2(0) = 0: Center_2(1) = I + G - L: Center_2(2) = 0
radius_2 = I
StartAngle_2 = Atn(((I - L) / (F / 2))) + Pi

EndAngle_2 = ((Pi / 2 - (Atn((I - L) / (F / 2)))) * 2) + Atn(((I - L) / (F / 2))) + Pi

' Команда построения дуги по заданным параметрам (верхняя)
Set arcObj_2 = ThisDrawing.ModelSpace.AddArc(Center_2, radius_2, StartAngle_2, EndAngle_2)


'Прорисовываем боковые линии

' Описываем все точки
Dim A1(0 To 2) As Double
Dim A2(0 To 2) As Double
Dim B1(0 To 2) As Double
Dim B2(0 To 2) As Double

' Вычисляем координаты каждой точки

A1(0) = -(E / 2): A1(1) = K: A1(2) = 0
A2(0) = -(F / 2): A2(1) = G: A2(2) = 0
B1(0) = E / 2: B1(1) = K: B1(2) = 0
B2(0) = F / 2: B2(1) = G: B2(2) = 0

' Вычислим координаты точек H1 и H2

' Строим отрезки, соединяя соответствующие точки
Dim lineObj As AcadLine

Set lineObj = ThisDrawing.ModelSpace.AddLine(A1, A2)
Set lineObj = ThisDrawing.ModelSpace.AddLine(B1, B2)

ZoomAll
End Sub

Мой код не совершенен. Я vba изучаю только неделю в свободное время

.

zamtmn · 12.06.2009, 19:41

кусок кода на паскале, расчет центра, радиуса, углов дуги по 3м точкам (p1,p2,p3), на tarcrtmodify, pgdbobjarc внимания не обращай, это преобразования типов на математику не влияющие:

Код:

[Выделить все]

        A:= tarcrtmodify(ptdata^).p2.x - tarcrtmodify(ptdata^).p1.x;
        B:= tarcrtmodify(ptdata^).p2.y - tarcrtmodify(ptdata^).p1.y;
        C:= tarcrtmodify(ptdata^).p3.x - tarcrtmodify(ptdata^).p1.x;
        D:= tarcrtmodify(ptdata^).p3.y - tarcrtmodify(ptdata^).p1.y;

        E:= A*(tarcrtmodify(ptdata^).p1.x + tarcrtmodify(ptdata^).p2.x) + B*(tarcrtmodify(ptdata^).p1.y + tarcrtmodify(ptdata^).p2.y);
        F:= C*(tarcrtmodify(ptdata^).p1.x + tarcrtmodify(ptdata^).p3.x) + D*(tarcrtmodify(ptdata^).p1.y + tarcrtmodify(ptdata^).p3.y);

        G:= 2*(A*(tarcrtmodify(ptdata^).p3.y - tarcrtmodify(ptdata^).p2.y)-B*(tarcrtmodify(ptdata^).p3.x - tarcrtmodify(ptdata^).p2.x));
        if abs(g)>eps then
        begin
        p_x:= (D*E - B*F) / G;
        p_y:= (A*F - C*E) / G;
        rr:= sqrt(sqr(tarcrtmodify(ptdata^).p1.x - p_x) + sqr(tarcrtmodify(ptdata^).p1.y - p_y));
        pgdbobjarc(tobj)^.r:=rr;
        pgdbobjarc(tobj)^.Local.p_insert.x:=p_x;
        pgdbobjarc(tobj)^.Local.p_insert.y:=p_y;
        pgdbobjarc(tobj)^.Local.p_insert.z:=0;
        tv.x:=p_x;
        tv.y:=p_y;
        pgdbobjarc(tobj)^.startangle:=vertexangle(tv,tarcrtmodify(ptdata^).p1);
        pgdbobjarc(tobj)^.endangle:=vertexangle(tv,tarcrtmodify(ptdata^).p3);
        if pgdbobjarc(tobj)^.startangle>pgdbobjarc(tobj)^.endangle then
        begin
                                                                                      rr:=pgdbobjarc(tobj)^.startangle;
                                                                                      pgdbobjarc(tobj)^.startangle:=pgdbobjarc(tobj)^.endangle;
                                                                                      pgdbobjarc(tobj)^.endangle:=rr
        end;
        rr:=vertexangle(tv,tarcrtmodify(ptdata^).p2);
        if (rr>pgdbobjarc(tobj)^.startangle) and (rr<pgdbobjarc(tobj)^.endangle) then
                                                                                 begin
                                                                                 end
                                                                             else
                                                                                 begin
                                                                                      rr:=pgdbobjarc(tobj)^.startangle;
                                                                                      pgdbobjarc(tobj)^.startangle:=pgdbobjarc(tobj)^.endangle;
                                                                                      pgdbobjarc(tobj)^.endangle:=rr
                                                                                 end;

Victor · 14.06.2009, 13:54

А нельзя использовать стандартную автокадовскую команду из VBA? Или это приципиальный вопрос.

vovkam · 15.06.2009, 09:16

Цитата:

Сообщение от Victor

А нельзя использовать стандартную автокадовскую команду из VBA? Или это приципиальный вопрос.

Вот это я и хочу узнать.
В автокаде можно же строить дугу как по трем точкам, так и по (центр, радиус, углы). Как это сделать в VBA?

Victor · 15.06.2009, 10:34

Да я такой же как и ты
Sub ArcVBA()
SendCommand ("arc 1,1 2.8,2.0 3,4")
End Sub

Кулик Алексей aka kpblc · 15.06.2009, 11:29

Тогда уж

Код:

[Выделить все]

Sub ArcVBA()
ThisDrawing.SendCommand "_.arc" & "_none" & "1,1" & "_none" & "2.8,2" & "_none" & "3,4"

а еще лучше:

Код:

[Выделить все]

Sub ArcVBA(pt1 As Variant, pt2 As Variant, pt3 As Variant)
  ThisDrawing.SendCommand "_.arc" & _
    "_none" & CStr(pt1(0)) & "," & CStr(pt1(1)) & _
    "_none" & CStr(pt2(0)) & "," & CStr(pt2(1)) & _
    "_none" & CStr(pt3(0)) & "," & CStr(pt3(1))
End Sub

Коды не проверял.

vovkam · 15.06.2009, 12:06

Вот мой ламеровский код

Код:

[Выделить все]

Sub ArcVBA()
Dim pt1(0 To 1) As Double, pt2(0 To 1) As Double, pt3(0 To 1) As Double
pt1(0) = -100: pt1(1) = 50
pt2(0) = 0: pt2(1) = 0
pt3(0) = 100: pt3(1) = 50

  ThisDrawing.SendCommand "_arc" & _
    "_none" & CStr(pt1(0)) & "," & CStr(pt1(1)) & _
    "_none" & CStr(pt2(0)) & "," & CStr(pt2(1)) & _
    "_none" & CStr(pt3(0)) & "," & CStr(pt3(1))
End Sub

В результате в командной строке получается вот такая фигня:

Код:

[Выделить все]

Команда: _arc_none-100,50_none0,0_none100,50

Кулик Алексей aka kpblc · 15.06.2009, 12:09

Ну значит проставь просто пробелы или добавь vbCr где надо Enter'ы ставить...

vovkam · 15.06.2009, 12:29

Ставлю, но ни как не получается. Может не туда ставлю.

Если не сложно, поставьте куда нужно.

Кулик Алексей aka kpblc · 15.06.2009, 12:46

Код:

[Выделить все]

Sub ArcVBA(pt1 As Variant, pt2 As Variant, pt3 As Variant)
  ThisDrawing.SendCommand "_.arc" & vbCr & _
    "_none" & vbCr & Replace(CStr(pt1(0)), ",", ".") & "," & Replace(CStr(pt1(1)), ",", ".") & vbCr & _
    "_none" & vbCr & Replace(CStr(pt2(0)), ",", ".") & "," & Replace(CStr(pt2(1)), ",", ".") & vbCr & _
    "_none" & vbCr & Replace(CStr(pt3(0)), ",", ".") & "," & Replace(CStr(pt3(1)), ",", ".") & vbCr
End Sub

Sub test()
Dim pt1 As Variant, pt2 As Variant, pt3 As Variant
  With ThisDrawing.Utility
    pt1 = .GetPoint(, "Point 1")
    pt2 = .GetPoint(, "Point 2")
    pt3 = .GetPoint(, "Point 3")
  End With
  ArcVBA pt1, pt2, pt3
End Sub

vovkam · 15.06.2009, 12:56

Большое спасибо

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Сдельная работа или сколько платят?	Экологика	Профессии и трудовые отношения	18	05.12.2008 15:09
Совместная работа крана и швинга.	drug	Технология и организация строительства	6	17.08.2008 10:53
Работа в испании	ASLYS	Профессии и трудовые отношения	12	21.10.2007 17:04
Лира и работа с моделями грунтов	rust-resisting	Лира / Лира-САПР	9	25.02.2006 23:06