强势发布：再做VBA汉诺塔动画演示

aoe1981

　　研发本帖附件的起因是下帖：
　　1.尊敬的liulang0808：《汉诺塔动画（修复了了两个问题），很少发主题帖， 大家提提意见吧》
　　http://club.excelhome.net/thread-1163278-1-1.html

　　研发本帖附件的技术参照是下帖：
　　2.尊敬的香川群子：《经典汉诺塔游戏》
　　http://club.excelhome.net/forum. ... 1074709&pid=7320769

　　liulang0808演示附件截图：
　　
　　特点：正视图、操作单元格。

　　香川群子演示附件截图：
　　
　　特点：俯视图、操作图形对象。

　　我的演示附件截图：
　　
　　特点：正视图、操作图形对象。

　　附件如下：
　　 汉诺塔动画演示（aoe1981）.rar (54.43 KB, 下载次数: 369)

2014-12-2 18:31 上传

点击文件名下载附件

　　敬请下载对比测试。
　　（已更新不显示控制点）


　　呵呵，生活因兴趣而精彩……
　　修正后的sleep版见35楼：
　　http://club.excelhome.net/forum. ... 1169124&pid=7972419
　　可以在2003中正常运行的见45楼：
　　http://club.excelhome.net/forum. ... 124&pid=7986292
　　（该附件目前应该是最佳版本，引入的函数sleep，精心设置了调节参数，可以适应不同配置电脑对动画演示快慢的调节。但在2003版中移动的偏差问题没有解决，不过在2010中是正常的。）

aoe1981

再传一张截图：

aoe1981

全部代码如下，一览无余，查看行数：
模块1：

1. Option Explicit
   
2. Dim zb1&(), zb2&(), pd%, bz(), js&, jps%(1 To 3) '坐标、步骤、金片数
   
3. Const hjj& = 10, ljj& = 50, jcx& = 60, jcy& = 150 '行间距、列间距、基础x值、基础y值
   
4. Const w& = 30, h& = 10, dz& = 24 '金片宽、金片高、金片宽递增
   
5. Public Sub YuBei(n%) '预备
   
6. Dim i&, j&, shp As Shape, x&, y&
   
7. ReDim zb1&(1 To n, 1 To 4), zb2&(1 To 3, 1 To 4)
   
8. With aoe
   
9.     For Each shp In .Shapes
   
10.         If shp.Type <> msoOLEControlObject And shp.Type <> msoFormControl Then shp.Delete
    
11.     Next shp
    
12.     x = jcx: y = jcy + (h + dz / 2) * n
    
13.     Randomize
    
14.     For i = n To 1 Step -1
    
15.         j = n - i + 1
    
16.         zb1(j, 1) = x + (i - 1) * dz / 2: zb1(j, 2) = y - (i - 1) * (h + hjj)
    
17.         zb1(j, 3) = w + (n - i) * dz: zb1(j, 4) = h
    
18.         .Shapes.AddShape(msoShapeRectangle, zb1(j, 1), zb1(j, 2), zb1(j, 3), zb1(j, 4)).Name = "金片" & j
    
19.         .Shapes("金片" & j).Select
    
20.         With Selection.ShapeRange
    
21.             .Line.Weight = 1
    
22.             .Fill.ForeColor.RGB = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
    
23.         End With
    
24.     Next i
    
25.     For i = 1 To 3
    
26.         zb2(i, 1) = zb1(n, 1) + zb1(n, 3) / 2 + (zb1(n, 3) + ljj) * (i - 1): zb2(i, 3) = zb2(i, 1)
    
27.         zb2(i, 2) = zb1(1, 2) - 60: zb2(i, 4) = zb1(n, 2) + h * 2
    
28.         '.Shapes.AddConnector(msoConnectorStraight, zb2(i, 1), zb2(i, 2), zb2(i, 3), zb2(i, 4)).Name = Chr(64 + i)'2010录制
    
29.         .Shapes.AddLine(zb2(i, 1), zb2(i, 2), zb2(i, 3), zb2(i, 4)).Name = Chr(64 + i) '2003录制
    
30.         .Shapes(Chr(64 + i)).Select
    
31.         With Selection.ShapeRange
    
32.             .Line.Weight = 4
    
33.             '.Line.ForeColor.ObjectThemeColor = msoThemeColorText1'2010录制
    
34.             .Line.ForeColor.SchemeColor = 64 '2003录制
    
35.             .ZOrder msoSendToBack
    
36.         End With
    
37.     Next i
    
38.     .Range("b2").Select
    
39. End With
    
40. pd = 1
    
41. End Sub
    
42. Sub Hanoi1() '汉诺塔
    
43. Dim n%
    
44. If pd = 1 Then
    
45.     n = aoe.Range("b1").Value: js = 0
    
46.     jps(1) = n: jps(2) = 0: jps(3) = 0
    
47.     ReDim bz(1 To 2 ^ n - 1)
    
48.     Call dg_Hanoi1(n, "A", "B", "C")
    
49. Else
    
50.     MsgBox "请选择阶数，初始化汉诺塔游戏。", , "友情提示"
    
51. End If
    
52. pd = 0
    
53. aoe.Range("b3").Select
    
54. End Sub
    
55. Sub dg_Hanoi1(n%, a, b, c) '递归过程（阶数、起始针、过渡针、目标针）
    
56. If n = 1 Then
    
57.     js = js + 1
    
58.     bz(js) = "金片" & n & "：" & a & "→" & c
    
59.     aoe.Cells(js + 1, "p").Value = "第" & js & "步": aoe.Cells(js + 1, "q").Value = bz(js)
    
60.     Call DongHua("金片" & n, n, Asc(a) - 64, Asc(c) - 64)
    
61.     jps(Asc(a) - 64) = jps(Asc(a) - 64) - 1: jps(Asc(c) - 64) = jps(Asc(c) - 64) + 1
    
62. Else
    
63.     Call dg_Hanoi1(n - 1, a, c, b)
    
64.     js = js + 1
    
65.     bz(js) = "金片" & n & "：" & a & "→" & c
    
66.     aoe.Cells(js + 1, "p").Value = "第" & js & "步": aoe.Cells(js + 1, "q").Value = bz(js)
    
67.     Call DongHua("金片" & n, n, Asc(a) - 64, Asc(c) - 64)
    
68.     jps(Asc(a) - 64) = jps(Asc(a) - 64) - 1: jps(Asc(c) - 64) = jps(Asc(c) - 64) + 1
    
69.     Call dg_Hanoi1(n - 1, b, a, c)
    
70. End If
    
71. End Sub
    
72. Public Sub DongHua(jp$, n1%, m1%, m2%) '动画（金片、金片序号、开始针、到达针）
    
73. Dim i&, zy%, tj2& '左右、调节
    
74. tj2 = aoe.Range("b3").Value
    
75. aoe.Shapes(jp).Select
    
76. With Selection.ShapeRange
    
77.     For i = .Top To zb2(1, 2) - 30 Step -1 '金片上移
    
78.         .IncrementTop -1
    
79.         If i Mod tj2 = 0 Then Call YanShi
    
80.     Next i
    
81.     If zb2(m1, 1) < zb2(m2, 1) Then zy = 1 Else zy = -1
    
82.     For i = WorksheetFunction.Min(zb2(m1, 1), zb2(m2, 1)) To WorksheetFunction.Max(zb2(m1, 1), zb2(m2, 1)) - 1
    
83.         .IncrementLeft zy '金片左右平移（须注意植树问题在此的应用，否则效果会偏差，此问题极隐蔽，极不易测试察觉）
    
84.         If i Mod tj2 = 0 Then Call YanShi
    
85.     Next i
    
86.     For i = zb2(1, 2) - 30 To zb2(1, 4) - (hjj + h) * (jps(m2) + 1) '金片下移
    
87.         .IncrementTop 1
    
88.         If i Mod tj2 = 0 Then Call YanShi
    
89.     Next i
    
90. End With
    
91. End Sub
    
92. Public Sub YanShi() '延时
    
93. Dim j&, tj1&
    
94. tj1 = aoe.Range("b2").Value
    
95. For j = 1 To tj1
    
96.     DoEvents
    
97. Next j
    
98. End Sub
    

复制代码

工作表aoe：

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3. If Target.Address(0, 0) = "B1" Then Range("p2:q" & Rows.Count).ClearContents: Call YuBei(Target.Value)
   
4. End Sub

复制代码

aoe1981

　　本来应当完成的早一些的，不至于像现在这样“半夜鸡叫”似的发帖，只是遇到了一个奇怪的测试难题，反复折腾不得其解，问题如下图：
　　
　　就是：始终在移动过程和结束后部分金片对不齐，极是恼人。

　　后来便睡下了，想着第二天再做。结果忽然在躺下后，灵光闪现，想到了真正的原因，便又急急起床、穿衣，重新坐在了电脑前，按所想思路一做，咦，果然是“药到病除”，激动难眠！

mmwwdd

好东西，递归是好办法

aoe1981

接昨晚，服务器似乎也休息了，提交了半天，不响应，只好憋着后半截，无奈地睡了……现在继续：
查出问题的一截代码如下：
    For i = WorksheetFunction.Min(zb2(m1, 1), zb2(m2, 1)) To WorksheetFunction.Max(zb2(m1, 1), zb2(m2, 1))
        .IncrementLeft zy '金片左右平移（须注意植树问题在此的应用，否则效果会偏差，此问题极隐蔽，极不易测试察觉）
        If i Mod tj2 = 0 Then Call YanShi
    Next i
改成了：
    For i = WorksheetFunction.Min(zb2(m1, 1), zb2(m2, 1)) To WorksheetFunction.Max(zb2(m1, 1), zb2(m2, 1)) - 1
        .IncrementLeft zy '金片左右平移（须注意植树问题在此的应用，否则效果会偏差，此问题极隐蔽，极不易测试察觉）
        If i Mod tj2 = 0 Then Call YanShi
    Next i
便正常了，一切OK了。也许有点搞笑，只是多了个-1，但确实就这一点，立即搞定了纠缠了我大约一两小时的难题，呵呵，为此，一定要详细标记下。


到底是为什么呢？我的回答是：这就是植树问题的巧妙应用。

aoe1981

举个例子，假设现在要将金片从1号针移动到2号针，1号针的x坐标为10，2号针的x坐标为100，似乎只需要：
for i=10 to 100
就可以了（我是为了使金片移动过程看起来流畅、连贯些，每次移动以1个像素或者是磅值之类的为最小单位，此处不太清楚……），但正是这种想法，出了错，而且使我在查错过程中走了很多弯路……

我以为是：针的宽度为4.5磅造成的，我以为是金片的外边框所占像素或磅值造成的……反复测试，仍不得解。

其实吧，从10移动到100，只需要90次，但是从10起始循环到100时，却移动了91次。这个原理就是所谓“植树问题”，生活中也有大量类似例子，比如：4步5个脚印是也。

一个感觉，数学素养往往决定应用的成败！

aoe1981

现在的效果图如下：

aoe1981

　　本附件，支持比较大的任意n阶汉诺塔的直观动画演示，如图：
　　

　　但附件中数据有效性最大设置为8，有两个考虑：
　　1.此时总步骤数为：2^8-1=255（步），在一个一般可以较耐心地等待完的数值内，事实上，数学中的所有直观演示，似乎都是在较小数量范围内展开的，只是为了人们便于形象直观的理解问题，有力有效地拓展，还是要靠抽象；
　　2.太多的金片全屏也呈现不下，根本不需要！

aoe1981

关于动画延时效果的处理，使用了两个变量：tj1，tj2
tj1用来调节延时循环次数，相关代码如下：

1. Public Sub YanShi() '延时
   
2. Dim j&, tj1&
   
3. tj1 = aoe.Range("b2").Value
   
4. For j = 1 To tj1
   
5.     DoEvents
   
6. Next j
   
7. End Sub
   

复制代码

可见，值越大，循环次数越多，延时越长，动画越慢；


tj2用来调节移动步幅（即隔多少像素或磅值调用上述延时代码一次），相关代码如下：
Public Sub DongHua(jp$, n1%, m1%, m2%) '动画（金片、金片序号、开始针、到达针）
Dim i&, zy%, tj2& '左右、调节
tj2 = aoe.Range("b3").Value
aoe.Shapes(jp).Select
With Selection.ShapeRange
    For i = .Top To zb2(1, 2) - 30 Step -1 '金片上移
        .IncrementTop -1
        If i Mod tj2 = 0 Then Call YanShi
    Next i
    If zb2(m1, 1) < zb2(m2, 1) Then zy = 1 Else zy = -1
    For i = WorksheetFunction.Min(zb2(m1, 1), zb2(m2, 1)) To WorksheetFunction.Max(zb2(m1, 1), zb2(m2, 1)) - 1
        .IncrementLeft zy '金片左右平移（须注意植树问题在此的应用，否则效果会偏差，此问题极隐蔽，极不易测试察觉）
       If i Mod tj2 = 0 Then Call YanShi
    Next i
    For i = zb2(1, 2) - 30 To zb2(1, 4) - (hjj + h) * (jps(m2) + 1) '金片下移
        .IncrementTop 1
       If i Mod tj2 = 0 Then Call YanShi
    Next i
End With
End Sub

可见，值越小，调用延时代码的频率越高，从而延时越长，动画效果越慢。

最好的使用方法是：搭配上述两项指标，应该会得到较好的效果吧……