cad图中显示动图案例如下：

部分代码如下：

 （按下Esc键可退出）

#If VBA7 Then
  ' 64位系统声明
  Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
  ' 32位系统声明
  Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#If VBA7 Then
    ' 64位系统声明
    Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#Else
    ' 32位系统声明
    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
#End If
Sub CreateClock()
    ' cad二次开发代码yngqq443440204@2024年8月27日19:34:59
    'MsgBox "按下Esc键退出，CAD二次开发qq:443440204", , "CopyRight@yngqq"
    Dim v As Integer
    v = 15 '倍速
    Dim escapePressed As Boolean
    escapePressed = False
    Dim doc As AcadDocument
    Set doc = ThisDrawing

    ' Step 1: 创建钟表外框（圆形）
    Dim center(0 To 2) As Double
    center(0) = 0: center(1) = 0: center(2) = 0
    Dim center1(0 To 2) As Double
    center1(0) = 1000: center1(1) = 1000: center1(2) = 0
    Dim radius As Double
    radius = 10
   Dim outerCirclearr(0) As AcadEntity
    ' 创建外框圆
    Dim outerCircle As AcadCircle
    Set outerCircle = doc.ModelSpace.AddCircle(center, radius)
    Set outerCircle1 = doc.ModelSpace.AddCircle(center, 33)
   Set outerCirclearr(0) = outerCircle
   Set myl = ThisDrawing.Layers.Add("图层1")
  ' myl.transparency = 90
    ' Step 2: 填充外框
    Dim hatch As AcadHatch
    Set hatch = doc.ModelSpace.AddHatch(acHatchPatternTypePreDefined, "SOLID", True)
   hatch.Layer = "图层1"
    
    hatch.AppendOuterLoop (outerCirclearr)
    hatch.color = 12
   'hatch.transparency = True ' 设置透明度
    hatch.Evaluate

    ' Step 3: 创建指针（时针 分针 秒针）
    Dim hourHand As AcadLine
    Dim minuteHand As AcadLine
    Dim secondHand As AcadLine
   
    ' 指针长度和粗细
    Dim hourLength As Double, minuteLength As Double, secondLength As Double
    hourLength = 17: minuteLength = 20: secondLength = 28
   
    Dim hourWidth As Double, minuteWidth As Double, secondWidth As Double
    hourWidth = 30: minuteWidth = 20: secondWidth = 10
    
     Dim myhour(2) As Double
      myhour(0) = hourLength
        Dim mymin(2) As Double
      mymin(0) = minuteLength
        Dim mysec(2) As Double
      mysec(0) = secondLength
    ' 创建时针 分针 秒针
    Set hourHand = doc.ModelSpace.AddLine(center, myhour)
    Set minuteHand = doc.ModelSpace.AddLine(center, mymin)
    Set secondHand = doc.ModelSpace.AddLine(center, mysec)
   
    ' 设置颜色和宽度
    hourHand.color = acBlue
    minuteHand.color = acGreen
    secondHand.color = acYellow
   
    hourHand.Lineweight = acLnWt035
    minuteHand.Lineweight = acLnWt025
    secondHand.Lineweight = acLnWt018
  
    ' Step 4: 模拟指针的走动
    Dim i As Integer
    Dim a As Double
'    For Each ent In ThisDrawing.ModelSpace
'        ent.Move center, center1
'    Next ent
    ZoomExtents
    Do
    a = GetAsyncKeyState(vbKeyEscape)
         If GetAsyncKeyState(vbKeyEscape) <> 0 Then
            escapePressed = True
         End If
        ' 旋转指针
        RotateEntity hourHand, center, 6 * (-1) / 360 * v
        RotateEntity minuteHand, center, 6 * (-1) / 60 * v
        RotateEntity secondHand, center, (-6) * v
       
        ' 刷新视图
        'doc.Regen acActiveViewport
         hourHand.Update
         minuteHand.Update
         secondHand.Update
        ' 暂停以创建动画效果
       Sleep 100
        DoEvents
       If escapePressed Then
            ThisDrawing.Utility.Prompt "检测到ESC键，退出循环 " & vbCrLf
            MsgBox "已按下Esc键，CAD二次开发qq:443440204", , "CopyRight@yngqq"
            Exit Do
        End If
     Loop
End Sub

' RotateEntity函数：旋转实体
Sub RotateEntity(entity As AcadEntity, basePoint As Variant, angle As Double)
    entity.Rotate basePoint, angle * 3.14159 / 180
End Sub

缩小视图，完整预览整个钟表，可使用如下代码：ZoomScaled 0.8, acZoomScaledRelative