[编程交流] 选择

Sub aaa111b()
   Dim i As Integer, ic As Integer, j As Integer
   Dim item1 As AcadLWPolyline
   Dim item2 As AcadPoint
   Dim icor As Variant
   Dim katsayi As Integer
   Dim mp As Double, mr As Double, b As Double, t As Double, r As Double, c As Double, Derece As Double, acix As Double, xne As Double, yne As Double, xn As Double, yn As Double
   Dim x1 As Double, x2 As Double, x3 As Double, y1 As Double, y2 As Double, y3 As Double, xc As Double, yc As Double, xkts As Double, ykts As Double
   Dim insertionPnt(0 To 2) As Double, BulgeDeger As Double
   While ThisDrawing.ModelSpace.Count > 2
       'If ThisDrawing.ModelSpace.Item(2).ObjectName = "AcDbPoint" Then
           ThisDrawing.ModelSpace.Item(2).Delete
       'End If
   Wend
   ThisDrawing.Regen acAllViewports
   For i = 0 To 0
       Set item1 = ThisDrawing.ModelSpace.Item(i)
       icor = item1.Coordinates()
       ic = UBound(icor)
       k = 1
       For j = 0 To ic Step 2
           k = k * -1
           item1.SetBulge j / 2, (j / 200 + 1) * k
           BulgeDeger = item1.GetBulge(j / 2)
           If BulgeDeger <> 0 Then
               x1 = icor(j): y1 = icor(j + 1)
               If j = ic - 1 Then
                   x2 = icor(0): y2 = icor(1)
               Else
                   x2 = icor(j + 2): y2 = icor(j + 3)
               End If
               ic2 = DaireYeNokta(x1, x2, y1, y2, BulgeDeger)
               'insertionPnt(0) = ic2(0): insertionPnt(1) = ic2(1): insertionPnt(2) = 0#
               'ThisDrawing.ModelSpace.AddPoint (insertionPnt)
               ThisDrawing.ModelSpace.AddLightWeightPolyline (ic2)
               ThisDrawing.Regen acAllViewports
           End If
       Next
   Next
End Sub
Private Function DaireYeNokta(x1 As Double, x2 As Double, y1 As Double, y2 As Double, BulgeDeger As Double) As Variant
   Dim item1 As AcadLWPolyline
   Dim katsayi As Integer
   Dim mr As Double, t As Double, r As Double, c As Double, acix As Double, xne As Double, yne As Double, xn As Double, yn As Double
   Dim x3 As Double, y3 As Double, xc As Double, yc As Double, xkts As Double, ykts As Double
   Dim xyzm(19) As Double, tetam As Double
   Dim pii As Double
   pii = Math.Atn(1) * 4
   'eps = 100000
   katsayi = 1
   If Math.Abs(BulgeDeger) > 1 Then
       katsayi = -1
   End If
   aci = Math.Atn(BulgeDeger) * 4
   acix = Math.Abs(aci) / aci
   x3 = (x1 + x2) / 2
   y3 = (y1 + y2) / 2
   c = Math.Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
   t = Math.Abs(c / (2 * Tan(aci / 2)))
   r = Math.Abs(c / (2 * Sin(aci / 2)))
   yn = y1 - y2
   xn = x1 - x2
   If yn <> 0 Then
       xne = yn / Abs(yn)
   Else
       xne = 1
   End If
   If xn = 0 Then
       xkts = xne
       ykts = 0
   Else
       yne = -xn / Math.Abs(xn)
       mr = Math.Abs((y2 - y1) / (x1 - x2))
       xkts = mr / Math.Sqr(mr * mr + 1) * xne
       ykts = 1 / Math.Sqr(mr * mr + 1) * yne
   End If
   xc = x3 + t * xkts * acix * katsayi
   yc = y3 + t * ykts * acix * katsayi
   tetam = Math.Atn((y1 - yc) / (x1 - xc))
   tetam = Math.Abs(tetam)
   If (x1 - xc) < 0 And (y1 - yc) < 0 Then
       tetam = pii + tetam
   ElseIf (x1 - xc) < 0 Then
       tetam = pii - tetam
   ElseIf (y1 - yc) < 0 Then
       tetam = 2 * pii - tetam
   End If
   For i = 0 To 9
       xyzm(i * 2) = xc + (r * 1.1) * Math.Cos(tetam)
       xyzm(i * 2 + 1) = yc + (r * 1.1) * Math.Sin(tetam)
       tetam = tetam + aci / 9
   Next
   DaireYeNokta = xyzm
End Function