Public Sub DrawClock()
Dim cx As Single, cy As Single, r As Single
Dim BeginX As Single, BeginY As Single
Dim EndX As Single, EndY As Single
Dim i As Integer, j As Integer
Dim shpDraw(0 To 30) As String
Const pi As Single = 3.1415926
cx = 300: cy = 300: r = 200
For i = 0 To 30
j = i - 45
BeginX = cx + r * Cos(j * pi / 60)
BeginY = cy + r * Sin(j * pi / 60)
If i Mod 10 = 0 Then
EndX = cx + (r + 20) * Cos(j * pi / 60)
EndY = cy + (r + 20) * Sin(j * pi / 60)
ElseIf i Mod 5 = 0 Then
EndX = cx + (r + 10) * Cos(j * pi / 60)
EndY = cy + (r + 10) * Sin(j * pi / 60)
Else
EndX = cx + (r + 5) * Cos(j * pi / 60)
EndY = cy + (r + 5) * Sin(j * pi / 60)
End If
shpDraw(i) = ActiveWindow.View.Slide. _
Shapes.AddLine(BeginX, BeginY, EndX, EndY).Name
Next
ActiveWindow.View.Slide.Shapes.Range(shpDraw).Select
ActiveWindow.Selection.ShapeRange.Group
End Sub
说说程序中的几个要点：
● Const 关键字表示后面跟着的是常数，也就是在后文不能修改的数，这里用来定义圆周率。不过程序里用的是圆周率的60分之一，把这个值直接定为一个常数更好。
● AddLine 方法的意思是画直线段，后面跟着四个参数，分别是直线起点和终点的坐标。注意这里的刻度线有三种长度。
● 上面程序的最后两句，功能是选中全部画出的直线段（注意这里引用了前面所画直线段的名字，其中括号里的 shpDraw 没有下标），并组成一个组，这样将来移动刻度盘的时候不会发生错乱。
● 有的电流表在 0 刻度线的左侧还有刻度，比如是从-1~+3/-0.2~+0.6（单位是安培）的，需要对上述代码适当改动，比如相邻小刻度之间的夹角是 2.5°，最左侧和最右侧夹角是 100°。
前面的程序还有一些不足，比如没有弧线、没有指针、没有表盘边框、没有文字标记，如果要增加这些内容，首先要扩大前面程序中 shpDraw 的下标范围。然后在 For 语句之前或 Next 语句之后，增加相应的绘图程序：
'绘制弧线
shpDraw(31) = ActiveWindow.View.Slide.Shapes. _
AddShape(msoShapeArc, cx, cy - r, r, r).Name
ActiveWindow.View.Slide. _
Shapes(shpDraw(31)).Adjustments.Item(1) = -135
ActiveWindow.View.Slide. _
Shapes(shpDraw(31)).Adjustments.Item(2) = -45
'绘制指针
BeginX = cx + r * Cos(-pi * 0.3) / 2
BeginY = cy + r * Sin(-pi * 0.3) / 2
EndX = cx + (r + 250) * Cos(-pi * 0.3) / 2
EndY = cy + (r + 250) * Sin(-pi * 0.3) / 2
With ActiveWindow.View.Slide.Shapes. _
AddLine(BeginX, BeginY, EndX, EndY)
.Line.DashStyle = msoLineSolid '绘制实线
.Line.ForeColor.RGB = RGB(255, 0, 0) '设为红色
shpDraw(32) = .Name
End With
'绘制表盘边框
With ActiveWindow.View.Slide.Shapes. _
AddShape(msoShapeRectangle, _
cx - r - 5, cy - r - 45, 2 * r + 10, r - 35)
.Fill.Visible = msoFalse
shpDraw(33) = .Name
End With
'绘制文字标记
For i = 34 To 37
j = i + 3
With ActiveWindow.View.Slide.Shapes. _
AddTextbox(msoTextOrientationHorizontal, _
cx - r * Cos((j + 0.5) * pi / 6) - j / 2, cy - r * Sin((j + 0.5) * pi / 6), 15, 15)
.TextFrame.TextRange.Text = j - 37
.IncrementRotation (j - 37) * 30 - 45
shpDraw(i) = .Name
End With
Next
以上就是最后的效果，除了文字标记位置马马虎虎外，其它的还不错。这里因为文字只有一个字符，所以文本框的宽度＼高度都比较小，如果文字是两个、三个甚至四个字符（比如 15、0.6、 -0.2），至少宽度要改得大一些。本来其中的文字和表盘边框是可以不用代码画的，直接插入相应的图形就挺好，这里的目的是给大家多演示一下画图的方法。换言之，编程的目的是为了更好实现我们的目的，不要弄成强迫症，什么东西都想用程序来解决。另外前面程序只对指针设置了线型和颜色，可能在不同的电脑上运行时效果不完全一致，比如线条颜色、文字大小这些。
大家可以继续学习 VBA 编程的其它知识，至少可以先试着用代码绘制万用表电阻档。或者大家也可以想想，如果要制作一个窗体，让用户通过窗体来绘制不同风格的表盘，需要怎么设计和编程。
大家在学习中遇到困难的话，一是要善于利用帮助和网络，不过现在网络上的东西，很多你需要的资料永远找不到，都是互相抄；二是可以借助“录制宏”来实现，但是偏偏 PowerPoint 里没有这个功能，大家可以借助 Excel 里的录制宏功能来学习，然后作适当修改。
联系客服
