移动形状可见
Move Shape visible
我正在尝试用 VBA 移动 Excel 中的一组图片,效果很好,但我希望用户可以看到图片是如何移动的。
这是一个小游戏,"Horse Race"。
这是我移动马匹的代码。
Sub TrackProgress()
Dim Tracks() As GroupObject
Dim Agents(), HorseCount As Integer
Dim AgentCount As Integer
Dim TrackCount As Integer
Dim Progress As Double
Dim MaxPx As Double
AgentCount = Sheets("Config").Range("O5").Value
TrackCount = Round(AgentCount / HorsesPerTrack, 0)
ReDim Tracks(1 To TrackCount)
ReDim Agents(1 To AgentCount)
MaxPx = Sheets("Config").Range("O15").Value
Sheets("HorseRaceTrack").Select
For i = 6 To Sheets("Config").Cells(Rows.Count, 5).End(xlUp).Row
If Sheets("Config").Cells(i, 4).Value = "Active" Then
Agents(i - 5) = Sheets("Config").Cells(i, 5).Value
End If
Next i
For i = 1 To AgentCount
If Not IsError(Sheets("Config").Cells(i + 5, 7).Value) Then
Progress = Sheets("Config").Cells(i + 5, 7).Value
Do Until Sheets("HorseRaceTrack").Shapes("Horse_" & Agents(i)).Left >= (MaxPx * Progress)
Sheets("HorseRaceTrack").Shapes("Horse_" & Agents(i)).IncrementLeft 1.3636220472
'Sleep 1000 ' Pferd beweg sich nicht flüssig....
Loop
Else
GoTo NextOne
End If
NextOne:
Next i
End Sub
我已经尝试使用 "sleep 500" 但是屏幕也很卡
感谢您的帮助!
在 .IncrementLeft
之后紧跟 DoEvents
。这应该允许工作表在移动时显示形状。
通过调整增量的大小,可以让动作加速或减速。
我正在尝试用 VBA 移动 Excel 中的一组图片,效果很好,但我希望用户可以看到图片是如何移动的。
这是一个小游戏,"Horse Race"。
这是我移动马匹的代码。
Sub TrackProgress()
Dim Tracks() As GroupObject
Dim Agents(), HorseCount As Integer
Dim AgentCount As Integer
Dim TrackCount As Integer
Dim Progress As Double
Dim MaxPx As Double
AgentCount = Sheets("Config").Range("O5").Value
TrackCount = Round(AgentCount / HorsesPerTrack, 0)
ReDim Tracks(1 To TrackCount)
ReDim Agents(1 To AgentCount)
MaxPx = Sheets("Config").Range("O15").Value
Sheets("HorseRaceTrack").Select
For i = 6 To Sheets("Config").Cells(Rows.Count, 5).End(xlUp).Row
If Sheets("Config").Cells(i, 4).Value = "Active" Then
Agents(i - 5) = Sheets("Config").Cells(i, 5).Value
End If
Next i
For i = 1 To AgentCount
If Not IsError(Sheets("Config").Cells(i + 5, 7).Value) Then
Progress = Sheets("Config").Cells(i + 5, 7).Value
Do Until Sheets("HorseRaceTrack").Shapes("Horse_" & Agents(i)).Left >= (MaxPx * Progress)
Sheets("HorseRaceTrack").Shapes("Horse_" & Agents(i)).IncrementLeft 1.3636220472
'Sleep 1000 ' Pferd beweg sich nicht flüssig....
Loop
Else
GoTo NextOne
End If
NextOne:
Next i
End Sub
我已经尝试使用 "sleep 500" 但是屏幕也很卡
感谢您的帮助!
在 .IncrementLeft
之后紧跟 DoEvents
。这应该允许工作表在移动时显示形状。
通过调整增量的大小,可以让动作加速或减速。