ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 8999|回复: 48

[原创] 强势发布:再做VBA汉诺塔动画演示

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-11-29 01:17 | 显示全部楼层 |阅读模式
本帖已被收录到知识树中,索引项:递归
本帖最后由 aoe1981 于 2014-12-9 15:31 编辑

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

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

  liulang0808演示附件截图:
   360截图-1379095.jpg
  特点:正视图、操作单元格。

  香川群子演示附件截图:
   360截图-1420404.jpg
  特点:俯视图、操作图形对象。

  我的演示附件截图:
   360截图-1633221.jpg
  特点:正视图、操作图形对象。

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

评分

参与人数 2财富 +20 鲜花 +2 收起 理由
lm1221 + 2 优秀作品
笑着...两年过去 + 20 看起来好高大上的样子

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 01:19 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 01:24 | 显示全部楼层
全部代码如下,一览无余,查看行数:
模块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
复制代码

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 01:30 | 显示全部楼层
  本来应当完成的早一些的,不至于像现在这样“半夜鸡叫”似的发帖,只是遇到了一个奇怪的测试难题,反复折腾不得其解,问题如下图:
   360截图-2388765.jpg
  就是:始终在移动过程和结束后部分金片对不齐,极是恼人。

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

TA的精华主题

TA的得分主题

发表于 2014-11-29 06:03 | 显示全部楼层
好东西,递归是好办法

点评

非常赞同您的观点。递归应用似乎还是很普遍,学点递归,可能一时难以创造性地应用,但大概可以看懂,也是极好的!  发表于 2014-11-29 09:23

评分

参与人数 1鲜花 +1 收起 理由
aoe1981 + 1 感谢提示

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 07:49 | 显示全部楼层
本帖最后由 aoe1981 于 2014-11-29 08:58 编辑

接昨晚,服务器似乎也休息了,提交了半天,不响应,只好憋着后半截,无奈地睡了……现在继续:
查出问题的一截代码如下:
    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,但确实就这一点,立即搞定了纠缠了我大约一两小时的难题,呵呵,为此,一定要详细标记下。


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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 08:00 | 显示全部楼层
本帖最后由 aoe1981 于 2014-11-29 08:51 编辑

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

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

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 08:04 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 08:28 | 显示全部楼层
本帖最后由 aoe1981 于 2014-11-29 09:01 编辑

  本附件,支持比较大的任意n阶汉诺塔的直观动画演示,如图:
   360截图-2963316.jpg

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-11-29 08:48 | 显示全部楼层
关于动画延时效果的处理,使用了两个变量: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

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

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

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-8-20 21:42 , Processed in 0.109075 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表