10.3. Вычерчивание линий

Ниже представлена простейшая программа для вычерчивания линии.

Пример 5.

Sub Line1()

Dim Lin As AcadLine

Dim Coord As Variant

Dim Coord2 As Variant

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

ThisDrawing.Application.Update

End Sub

Чтобы вычертить ломаную линию необходимо несколько видоизменить код программы.

Пример 6.

Sub Line2()

Dim Lin As AcadLine

Dim Coord As Variant

Dim Coord2 As Variant

Dim count As Integer

Count = 0

Do

On Error GoTo Line

If count = 0 Then

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

Count = count + 1

Else

Coord = coord2

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите следующую точку:»)

Set Lin = ThisDrawing.ModeSpace.AddLine(Coord,Coord2)

ThisDrawing.Application.Update

End If

Loop

Line:

End Sub

Вот пример кода, рисующего мультилинию, то есть двойную линию.

Пример 7.

Sub Line3()

Dim Lin As AcadMLine

Dim Coord As Variant

Dim Coord2 As Variant

Dim count As Integer

Dim vertList(0 To 5) As Double

Count = 0

Do

On Error GoTo Line

If count = 0 Then

Coord = ThisDrawing.Utility.GetPoint(, «Введите первую точку:»)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите вторую точку:»)

vertList(0) = Coord(0)

vertList(1) = Coord(1)

vertList(2) = Coord(2)

vertList(3) = Coord2(0)

vertList(4) = Coord2(1)

vertList(5) = Coord2(2)

Set Lin = ThisDrawing.ModeSpace.AddMLine(vertList)

Count = count + 1

Else

Coord = coord2

vertList(0) = Coord(0)

vertList(1) = Coord(1)

vertList(2) = Coord(2)

Coord2 = ThisDrawing.Utility.GetPoint(, «Введите следующую точку:»)

vertList(3) = Coord2(0)

vertList(4) = Coord2(1)

vertList(5) = Coord2(2)

Set Lin = ThisDrawing.ModeSpace.AddMLine(vertList)

ThisDrawing.Application.Update

End If

Loop

Line:

End Sub

10.4. Вычерчивание дуги

Вот пример программы, рисующей дугу.

Пример 8.

Option Explicit

Sub TheePointArc()

Dim pt1 As Variant, pt2 As Variant, pt3 As Variant

Dim arcobj As AcadArc

On Error GoTo ErrTrap:

Pt1 = ThisDrawing.Utility.GetPoint(, «Начало кривой:»)

pt2 = ThisDrawing.Utility.GetPoint(, «Конец кривой:»)

pt3 = ThisDrawing.Utility.GetPoint(, «Середина кривой:»)

On Error GoTo 0

Set arcobj = TheePointArc(pt1, pt2, pt3)

ErrTrap:

End Sub

Function TheePointArc(startpt As Variant), Endpt As_

Variant, Bulgept (As Variant) As AcadArc

On Error GoTo ErrTrap:

Dim util As AcadUtility

Set util = ThisDrawing.Utility

Dim xa, xb, xc, ya, yb, yc

xa = endpt(0): ya = endpt(1)

xb = bulgept(0): yb = bulgept(1)

xc = startpt(0): yc = startpt(1)

Dim A As Double, B As Double, C As Double, D As Double

Dim E As Double, F As Double, G As Double, H As Double

Dim I As Double, J As Double, X As Double, Y As Double

A = (yc – ya) / 2

B = (xc – xb) / (yc – yb)

C = (xb + xc) / 2

D = (xb – xa) / (ya – yb)

E = (xa + xb) / 2

F = (xb – xa) / (ya – yb)

G = (xc – xb) / (yc – yb)

H = (ya +yb) / 2

I = A + B * C + D * E

J = F + G

X = I / J

Y = x * D + H – F * E

Dim center(0 To 2) As Double

Center(0) = x: center(1) = y: center(2) = 0

Dim starangle As Double, endangle As Double, radius As Double

Radius = Sqr((center(0) – startpt(0)) ^ 2 + (center(1) – starrpt(1)) ^ 2)

Startangle = util.AnfleFromXAxis(center, startpt)

Endangle = util.AngleFromXAxis(center, startpt)

Set TheePointArc = ThisDrawing.ModelSpaсe.AddArc(center,_

Radius, startangle, endangle)

On Error GoTo 0

Exit Function

ErrTrap:

MsgBox «Ошибка! Операция завершена.»

End Function