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

lm1221

aoe1981 发表于 2014-11-30 10:11
又回过头测试了下liulang0808的演示附件，我从一开始就非常喜欢他的直观形象，只是在我的电脑上，当金片数输 ...

我的也是这样，不过有时也会正常

aoe1981

　　今天在2003中试运行了一下，居然移动图形对象的位置出了错，一时搞不清楚是怎么回事，其方向是正确的，估计应该是移动的单位距离与2010中有所差别吧……对此，我在前面也说过，不太清楚是以磅值为单位，还是以像素为单位进行移动的，相关语句如下：

1.         .IncrementTop -1
   

复制代码

1.         .IncrementLeft zy

复制代码

　　问题截图如下：
　　

香川群子

aoe1981 发表于 2014-11-29 08:48
关于动画延时效果的处理，使用了两个变量：tj1，tj2
tj1用来调节延时循环次数，相关代码如下：
可见，值越 ...

延时部分用DoEvents的For循环处理这样并不好。

因为实际循环速度和机器的配置有关。不同的电脑就会产生不同的结果。


…………
应该用Wait 或 API的Sleep函数。

先声明一下：
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)

然后直接使用 Sleep [毫秒数] 即可

aoe1981

香川群子 发表于 2014-12-1 10:09
延时部分用DoEvents的For循环处理这样并不好。

因为实际循环速度和机器的配置有关。不同的电脑就会产生 ...

这个确实如此，单位的电脑快一些，感觉效果又不一样了……而且在2003中居然连移动的位置也出现了偏差，一时没有查出原因……嘿嘿，主要是不太专心吧……多谢指点！

aoe1981

香川群子 发表于 2014-12-1 10:09
延时部分用DoEvents的For循环处理这样并不好。

因为实际循环速度和机器的配置有关。不同的电脑就会产生 ...

香川，改成sleep的，运行了下，反而没有逐步动画演示的效果，真是奇怪，是不是我的相关代码运用错误：
相关代码如下：

1. Public Sub DongHua(jp$, n1%, m1%, m2%) '动画（金片、金片序号、开始针、到达针）
   
2. Dim i&, zy%, tj& '左右、调节
   
3. tj = aoe.Range("b2").Value
   
4. aoe.Shapes(jp).Select
   
5. With Selection.ShapeRange
   
6.     For i = .Top To zb2(1, 2) - 30 Step -1 '金片上移
   
7.         .IncrementTop -1
   
8.         Sleep tj
   
9.     Next i
   
10.     If zb2(m1, 1) < zb2(m2, 1) Then zy = 1 Else zy = -1
    
11.     For i = WorksheetFunction.Min(zb2(m1, 1), zb2(m2, 1)) To WorksheetFunction.Max(zb2(m1, 1), zb2(m2, 1)) - 1
    
12.         .IncrementLeft zy '金片左右平移（须注意植树问题在此的应用，否则效果会偏差，此问题极隐蔽，极不易测试察觉）
    
13.         Sleep tj
    
14.     Next i
    
15.     For i = zb2(1, 2) - 30 To zb2(1, 4) - (hjj + h) * (jps(m2) + 1) '金片下移
    
16.         .IncrementTop 1
    
17.         Sleep tj
    
18.     Next i
    
19. End With
    
20. End Sub

复制代码

　　附件如下：
　　 汉诺塔动画演示（sleep版）.rar (54.25 KB, 下载次数: 195)

2014-12-2 18:32 上传

点击文件名下载附件

　　（2014－12－01　19：15已修正，该版本为最佳版本，可以适应不同配置的电脑运行快慢的调整）
　　（已更新，不显示控制点）

aoe1981

以下来自于2003帮助：
“IncrementTop 方法
参阅应用于示例特性以指定的磅数为增量，垂直移动指定的图形。

expression.IncrementTop(Increment)
expression      必需。该表达式返回一个 Shape 对象。

Increment      Single 类型，必需。以磅为单位指定图形垂直移动的距离。正值使图形向下移动，负值使图形向上移动。

示例
本示例复制 myDocument 上的第一个图形，设置所复制的图形的填充格式，将其向右移动 70 磅，向上移动 50 磅，然后按顺时针方向旋转 30 度。

Set myDocument = Worksheets(1)
With myDocument.Shapes(1).Duplicate
    .Fill.PresetTextured msoTextureGranite
    .IncrementLeft 70
    .IncrementTop -50
    .IncrementRotation 30
End With

”

可见，在2003中移动的是磅值。

aoe1981

再补充一点，家里可是2010，不太方便：
“IncrementLeft 方法
参阅应用于示例特性以指定的磅数为增量，水平移动指定的图形。

expression.IncrementLeft(Increment)
expression      必需。该表达式返回一个 Shape 对象。

Increment      Single 类型，必需。以磅为单位指定图形水平移动的距离。正值使图形向右移动，负值使图形向左移动。

示例
本示例复制 myDocument 上的第一个图形，设置所复制的图形的填充格式，将其向右移动 70 磅，向上移动 50 磅，然后按顺时针方向旋转 30 度。

Set myDocument = Worksheets(1)
With myDocument.Shapes(1).Duplicate
    .Fill.PresetTextured msoTextureGranite
    .IncrementLeft 70
    .IncrementTop -50
    .IncrementRotation 30
End With

”

aoe1981

插入一个图形对象的，其坐标仍然是以“磅”为单位：
“AddShape 方法
参阅应用于示例特性当该方法应用于 Shapes 对象时，返回一个 Shape 对象，该对象代表工作表中的新自选图形。当该方法应用于 CanvasShapes 对象时，返回一个 Shape 对象，该对象代表绘图画布中的新自选图形。

expression.AddShape(Type, Left, Top, Width, Height)
expression      必选。该表达式返回 Shapes 对象。

Type      MsoAutoShapeType 类型，必需。指定要创建的自选图形的类型。

MsoAutoShapeType 可为以下 MsoAutoShapeType 常量之一。
msoShape16pointStar
msoShape24pointStar
msoShape32pointStar
msoShape4pointStar
msoShape5pointStar
msoShape8pointStar
msoShapeActionButtonBackorPrevious
msoShapeActionButtonBeginning
msoShapeActionButtonCustom
msoShapeActionButtonDocument
msoShapeActionButtonEnd
msoShapeActionButtonForwardorNext
msoShapeActionButtonHelp
msoShapeActionButtonHome
msoShapeActionButtonInformation
msoShapeActionButtonMovie
msoShapeActionButtonReturn
msoShapeActionButtonSound
msoShapeArc
msoShapeBalloon
msoShapeBentArrow
msoShapeBentUpArrow
msoShapeBevel
msoShapeBlockArc
msoShapeCan
msoShapeChevron
msoShapeCircularArrow
msoShapeCloudCallout
msoShapeCross
msoShapeCube
msoShapeCurvedDownArrow
msoShapeCurvedDownRibbon
msoShapeCurvedLeftArrow
msoShapeCurvedRightArrow
msoShapeCurvedUpArrow
msoShapeCurvedUpRibbon
msoShapeDiamond
msoShapeDonut
msoShapeDoubleBrace
msoShapeDoubleBracket
msoShapeDoubleWave
msoShapeDownArrow
msoShapeDownArrowCallout
msoShapeDownRibbon
msoShapeExplosion1
msoShapeExplosion2
msoShapeFlowchartAlternateProcess
msoShapeFlowchartCard
msoShapeFlowchartCollate
msoShapeFlowchartConnector
msoShapeFlowchartData
msoShapeFlowchartDecision
msoShapeFlowchartDelay
msoShapeFlowchartDirectAccessStorage
msoShapeFlowchartDisplay
msoShapeFlowchartDocument
msoShapeFlowchartExtract
msoShapeFlowchartInternalStorage
msoShapeFlowchartMagneticDisk
msoShapeFlowchartManualInput
msoShapeFlowchartManualOperation
msoShapeFlowchartMerge
msoShapeFlowchartMultidocument
msoShapeFlowchartOffpageConnector
msoShapeFlowchartOr
msoShapeFlowchartPredefinedProcess
msoShapeFlowchartPreparation
msoShapeFlowchartProcess
msoShapeFlowchartPunchedTape
msoShapeFlowchartSequentialAccessStorage
msoShapeFlowchartSort
msoShapeFlowchartStoredData
msoShapeFlowchartSummingJunction
msoShapeFlowchartTerminator
msoShapeFoldedCorner
msoShapeHeart
msoShapeHexagon
msoShapeHorizontalScroll
msoShapeIsoscelesTriangle
msoShapeLeftArrow
msoShapeLeftArrowCallout
msoShapeLeftBrace
msoShapeLeftBracket
msoShapeLeftRightArrow
msoShapeLeftRightArrowCallout
msoShapeLeftRightUpArrow
msoShapeLeftUpArrow
msoShapeLightningBolt
msoShapeLineCallout1
msoShapeLineCallout1AccentBar
msoShapeLineCallout1BorderandAccentBar
msoShapeLineCallout1NoBorder
msoShapeLineCallout2
msoShapeLineCallout2AccentBar
msoShapeLineCallout2BorderandAccentBar
msoShapeLineCallout2NoBorder
msoShapeLineCallout3
msoShapeLineCallout3AccentBar
msoShapeLineCallout3BorderandAccentBar
msoShapeLineCallout3NoBorder
msoShapeLineCallout4
msoShapeLineCallout4AccentBar
msoShapeLineCallout4BorderandAccentBar
msoShapeLineCallout4NoBorder
msoShapeMixed
msoShapeMoon
msoShapeNoSymbol
msoShapeNotchedRightArrow
msoShapeNotPrimitive
msoShapeOctagon
msoShapeOval
msoShapeOvalCallout
msoShapeParallelogram
msoShapePentagon
msoShapePlaque
msoShapeQuadArrow
msoShapeQuadArrowCallout
msoShapeRectangle
msoShapeRectangularCallout
msoShapeRegularPentagon
msoShapeRightArrow
msoShapeRightArrowCallout
msoShapeRightBrace
msoShapeRightBracket
msoShapeRightTriangle
msoShapeRoundedRectangle
msoShapeRoundedRectangularCallout
msoShapeSmileyFace
msoShapeStripedRightArrow
msoShapeSun
msoShapeTrapezoid
msoShapeUpArrow
msoShapeUpArrowCallout
msoShapeUpDownArrow
msoShapeUpDownArrowCallout
msoShapeUpRibbon
msoShapeUTurnArrow
msoShapeVerticalScroll
msoShapeWave

Left   , Top   Single 类型，必需。相对于文档的左上角，以磅为单位给出自选图形边框左上角的位置。

Width   , Height   Single 类型，必需。以磅为单位给出自选图形边框的宽度和高度。

说明
若要更改已添加的自选图形的类型，请设置 AutoShapeType 属性。

示例
本示例向 myDocument 添加矩形。

Set myDocument = Worksheets(1)
myDocument.Shapes.AddShape msoShapeRectangle, 50, 50, 100, 200

”

aoe1981

香川群子 发表于 2014-12-1 10:09
延时部分用DoEvents的For循环处理这样并不好。

因为实际循环速度和机器的配置有关。不同的电脑就会产生 ...

香川，测试出来了，应当与doevents相互配合：

1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)
   
2. Sub Macro1()
   
3.     ActiveSheet.Shapes.AddShape(msoShapeRectangle, 75, 75, 100, 50).Select
   
4.     With Selection.ShapeRange
   
5.         .Fill.ForeColor.SchemeColor = 13
   
6.         For i = 1 To 100
   
7.             .IncrementTop -0.75
   
8.             .IncrementLeft -0.75
   
9.             DoEvents
   
10.             Sleep 10
    
11.         Next i
    
12.     End With
    
13. End Sub

复制代码

aoe1981

关于sleep效果的测试：

1. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long)
   
2. Sub Macro1()
   
3. t = Timer
   
4. For i = 1 To 1000000
   
5.     Sleep 0.0001
   
6. Next i
   
7. MsgBox Timer - t
   
8. End Sub

复制代码