VBA中pictureBox在持续位移时,保持帧动画(延迟LoadPicture)?

[灭我豚拳]

请教大神:
1.将一个PictureBox做成帧动画(用timeGetTime来延迟LoadPicture从而逐帧实现)
2.将这个PictureBox进行持续位移(用timeGetTime来延迟持续改变其Left值)

那么问题来了:
位移时,原本进行的帧动画会暂停.
或者帧动画时,原来进行的位移会暂停
各自都使用了DoEvent也没用
请问有解决方案吗?


不能贴附件,只能贴个范例的代码:
1.这是我picturebox实现的帧动画(IMG文件夹内的1.gif 2.gif 3.gif是我设置3张静态gif图片)

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Sub Img1_LoadPic()
Dim Cycle As Integer
Dim PicNum As Integer
Dim Savetime As Double
For Cycle = 1 To 10
For PicNum = 1 To 3
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\IMG\" & PicNum & ".gif")
DoEvents
Savetime = timeGetTime
While timeGetTime < Savetime + 500
DoEvents
Wend
Next
Next

End Sub

2.这是我实现的picturebox持续位移

两个同时运行时会中断另一个
请问有解决方案可以两个sub同时产生效果么?
大神教我怎么改~~~

Sub Img1_Mov()
Dim Savetime As Double
Dim NowMovNum As Integer
Dim AddMovNum As Integer
Dim AddValue As Integer
For AddValue = 1 To 5
NowMovNum = Image1.Left
AddMovNum = NowMovNum + AddValue
Image1.Left = AddMovNum
DoEvents
Savetime = timeGetTime
While timeGetTime < Savetime + 500
DoEvents
Wend
Next

End Sub

[一如既往哈]

在vba里模拟显示动画，多费劲啊。直接上个webbrowser控件不好吗？

[Tiger_Zhao]

用任务队列：
1)先定义一个任务接口

'ITask
Option Explicit

'任务是否运行中'
Public Property Get Enabled() As Boolean
End Property

'下个触发时点'
Public Property Get NextTime() As Long
End Property

'达到触发时点时被调用。'
'显示下一帧动画或下一步移动。'
'同时需要增加NextTime的值，如果动画/移动结束则设Enabled为False'
Public Sub OnTimer()
End Sub

2)动画/移动分别做成实现ITask接口的Class
3)调用的方式如下

Private Sub RunTasks()
    Dim colTasks As Collection
    Dim cTask As ITask
    Dim lTime As Long
    Dim bOnTimer As Boolean
    Dim lEnabledCount As Long
    
    Set colTasks = New Collection
    '初始化动画/移动的任务实例，加入colTasks集合'
    
    Do
        lTime = timeGetTime()
        lEnabledCount = 0
        bOnTimer = False
        
        For Each cTask In colTasks
            If cTask.Enabled Then
            
                If lTime >= cTask.NextTime Then
                    cTask.OnTimer
                    bOnTimer = True
                    
                    If cTask.Enabled Then
                        lEnabledCount = lEnabledCount + 1
                    End If
                Else
                    lEnabledCount = lEnabledCount + 1
                End If
                
            End If
        Next
        
        If bOnTimer Then
            DoEvents
        End If
    Loop While lEnabledCount > 0

End Sub