[综合讨论] 我怎样才能在A中绘制螺旋描记器

Option Explicit
Const TwoPi As Double = 3.14159265359 * 2
Sub CreatePattern()
Dim StationaryCircle As AcadCircle
Dim RotatingCircle As AcadCircle
Dim PenPoint As AcadPoint
Dim tempPoint As AcadPoint
Dim varPkPt As Variant
Dim rotationAngle As Double
Dim ent As AcadEntity
Dim Origin(2) As Double
Dim PenPt() As Double
Dim SpiroCurve As AcadSpline
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
Dim fitPoints(0 To 194) As Double
Dim RadRatio As Double
Dim vararray As Variant
Dim varNewarray As Variant
Dim NumOfArray As Integer
Dim NumOfInitialRotations As Integer
Dim Remain As Double
Dim count As Integer
Dim SeqBlock As AcadBlock
Dim ref As AcadBlockReference
  On Error Resume Next
  With ThisDrawing.Utility
     .GetEntity ent, varPkPt, "Select Circle at WCS origin: "
     If Err <> 0 Then Exit Sub
     If TypeOf ent Is AcadCircle Then
        Set StationaryCircle = ent
     Else: Exit Sub
     End If
        If Round(DistBetween2PtST(Origin, StationaryCircle.center), 6) <> 0 Then Exit Sub
        
     .GetEntity ent, varPkPt, "Select Circle that rotates: "
     If Err <> 0 Then Exit Sub
     If TypeOf ent Is AcadCircle Then
        Set RotatingCircle = ent
     Else: Exit Sub
     End If
     
     If (StationaryCircle.radius + RotatingCircle.radius) - RotatingCircle.center(0) > 0.0000001 Then
     .Prompt "Circles are not situated correctly! Operation Cancelled. "
     Exit Sub
     End If
     
     RadRatio = StationaryCircle.radius / RotatingCircle.radius
     NumOfInitialRotations = Round(RadRatio)
     Remain = RadRatio - NumOfInitialRotations
     If Abs(Remain) < 0.0000001 Then
        NumOfArray = 0
        Remain = 0
     End If
         
     .GetEntity ent, varPkPt, "Select Pen Point in rotating circle: "
     If Err <> 0 Then Exit Sub
     On Error GoTo 0
     If TypeOf ent Is AcadPoint Then
        Set PenPoint = ent
        PenPt = PenPoint.Coordinates
     Else: Exit Sub
     End If
     Dim i As Integer
     
     fitPoints(0) = PenPt(0)
     fitPoints(1) = PenPt(1)
     fitPoints(2) = PenPt(2)
     
     For i = 1 To 64
        Set tempPoint = PenPoint.Copy
        tempPoint.Rotate RotatingCircle.center, (TwoPi / 64) * i
        tempPoint.Rotate StationaryCircle.center, (TwoPi / 64) * i * (RotatingCircle.radius / StationaryCircle.radius)
        varPkPt = tempPoint.Coordinates
        
        fitPoints(i * 3) = varPkPt(0)
        fitPoints(i * 3 + 1) = varPkPt(1)
        fitPoints(i * 3 + 2) = varPkPt(2)
        tempPoint.Delete
     
     Next
     Set SeqBlock = ThisDrawing.Blocks.Add(Origin, "oneTurn")
     
     Set SpiroCurve = SeqBlock.AddSpline(fitPoints, startTan, endTan)
     rotationAngle = (TwoPi / RadRatio)
     
     For i = 0 To NumOfInitialRotations - 1
        Set ent = SpiroCurve.Copy
        ent.Rotate Origin, rotationAngle * i
     Next
     Set ref = ThisDrawing.ModelSpace.InsertBlock(Origin, "oneTurn", 1, 1, 1, 0)
     If Remain <> 0 Then
        rotationAngle = (rotationAngle * NumOfInitialRotations) - TwoPi
        NumOfArray = Floor(Abs(TwoPi / rotationAngle), 1)
        For i = 0 To NumOfArray - 1
           Set ent = ref.Copy
           ent.Rotate Origin, rotationAngle * i
        Next
     End If
  End With
End Sub
Function DistBetween2PtST(dblPt1 As Variant, dblPt2 As Variant) As Double
DistBetween2PtST = Sqr((dblPt2(0) - dblPt1(0)) ^ 2 + (dblPt2(1) - dblPt1(1)) ^ 2 + (dblPt2(2) - dblPt1(2)) ^ 2)
End Function
Public Function Floor(ByVal X As Double, Optional ByVal Factor As Double = 1) As Double
Floor = Int(X / Factor) * Factor
End Function