Public Function Dpp(P1, P2)

'oblicza odleglosc midzy 2 puntkami

If UBound(P1) = 2 And UBound(P2) = 2 Then

Dpp = Sqr((P2(0) - P1(0)) ^ 2# + (P2(1) - P1(1)) ^ 2# + (P2(2) - P1(2)) ^ 2#)

Else

Dpp = Sqr((P2(0) - P1(0)) ^ 2# + (P2(1) - P1(1)) ^ 2#)

End If

End Function

Public Function PLD(IP1, IP2, IDist)

'zwraca punkt (tablica współrzędnych) w określonej odległosci od 1 punktu w kierunku drugiego

distance = Dpp(IP1, IP2)

Dim TmpVec(2) As Double

If IDist = 0 Then

readyVec = IP1

Else

If distance > 0 Then

DispVec = Array(IP2(0) - IP1(0), IP2(1) - IP1(1), IP2(2) - IP1(2))

vecnor = Array(DispVec(0) / (distance / IDist), DispVec(1) / (distance / IDist), DispVec(2) / (distance / IDist))

readyVec = Array(IP1(0) + vecnor(0), IP1(1) + vecnor(1), IP1(2) + vecnor(2))

Else

readyVec = IP1

End If

End If

TmpVec(0) = readyVec(0): TmpVec(1) = readyVec(1): TmpVec(2) = readyVec(2)

PLD = TmpVec

End Function

Public Sub kółko()

Dim P1 As Variant

Dim P2 As Variant

P1 = ThisDocument.Utility.GetPoint(, "Wskaż punkt: ")

P2 = ThisDocument.Utility.GetPoint(P1, "Wskaż punkt: ")

Dim lineObj1 As ZwcadLine

'Set lineObj1 = ThisDocument.ModelSpace.AddLine(P1, P2)

'lineObj1.LineWeight = zcLnWt050

'lineObj1.Color = zcBlue

ThisDocument.Regen

Dim Px

Dim P3

Dim P4

Dim P5

Dim P6

Dim P7

Dim P8

Dim P9

Dim P10

Dim P11

Dim P12

Dim P13

Dim Odleglosc As Double

Dlugosc = Dpp(P1, P2) ' / 2#

Px = P1 'PLD(P1, P2, Dlugosc)

Dim Nachylenie As Double

Nachylenie = ThisDocument.Utility.AngleFromXAxis(P1, P2)

Dim Pi As Double

Pi = 1.570796

P3 = Px 'ThisDocument.Utility.PolarPoint(Px, Nachylenie - Pi, Dlugosc)

P4 = ThisDocument.Utility.PolarPoint(Px, Nachylenie + Pi, Dlugosc / 3)

P5 = ThisDocument.Utility.PolarPoint(P2, Nachylenie + Pi, Dlugosc / 3)

P6 = ThisDocument.Utility.PolarPoint(P2, Nachylenie + Pi, Dlugosc / 1.5)

P7 = ThisDocument.Utility.PolarPoint(Px, Nachylenie + Pi, Dlugosc / 1.5)

P8 = ThisDocument.Utility.PolarPoint(P2, Nachylenie + Pi, Dlugosc)

P9 = ThisDocument.Utility.PolarPoint(Px, Nachylenie + Pi, Dlugosc)

Dim lineObj2 As ZwcadLine

'Set lineObj2 = ThisDocument.ModelSpace.AddLine(P3, P4)

'lineObj2.LineWeight = zcLnWt050

Dim lineObj3 As ZwcadLine

'Set lineObj3 = ThisDocument.ModelSpace.AddLine(P2, P5)

'lineObj3.LineWeight = zcLnWt050

Dim lineObj4 As ZwcadLine

Set lineObj4 = ThisDocument.ModelSpace.AddLine(P4, P5)

lineObj4.LineWeight = zcLnWt050

Dim lineObj5 As ZwcadLine

Set lineObj5 = ThisDocument.ModelSpace.AddLine(P6, P7)

lineObj5.LineWeight = zcLnWt050

'Dim lineObj6 As ZwcadLine

'Set lineObj6 = ThisDocument.ModelSpace.AddLine(P8, P9)

'lineObj6.LineWeight = zcLnWt050

P10 = ThisDocument.Utility.PolarPoint(P1, Nachylenie, Dlugosc / 3)

P11 = ThisDocument.Utility.PolarPoint(P1, Nachylenie, Dlugosc / 1.5)

P12 = ThisDocument.Utility.PolarPoint(P9, Nachylenie, Dlugosc / 3)

P13 = ThisDocument.Utility.PolarPoint(P9, Nachylenie, Dlugosc / 1.5)

Dim lineObj7 As ZwcadLine

Set lineObj7 = ThisDocument.ModelSpace.AddLine(P10, P12)

lineObj7.LineWeight = zcLnWt050

Dim lineObj8 As ZwcadLine

Set lineObj8 = ThisDocument.ModelSpace.AddLine(P11, P13)

lineObj8.LineWeight = zcLnWt050

Dim lineObj9 As ZwcadLine

'Set lineObj9 = ThisDocument.ModelSpace.AddLine(P1, P9)

'lineObj9.LineWeight = zcLnWt050

Dim lineObj10 As ZwcadLine

'Set lineObj10 = ThisDocument.ModelSpace.AddLine(P2, P8)

'lineObj10.LineWeight = zcLnWt050

'lineObj2.Color = zcGreen

ThisDocument.Regen

'rysuje kwadrat z 9 kwadracikami bez obramowania

End Sub

Tak wygląda

---