|
▼文哉 さん:
こんにちは
やはり、GetAsyncKeyState が不安定です。
で、何回もキーを押すとPC全体が、変になる現象もでましたので、この制御は撤回し
かわりに「おやすみ」プロシジャを用意しました。これを実行すれば、千鳥足の徘徊は
終了します。(マクロショートカットキーに登録して実行すると操作しやすいかも)
で、本体の「酔っ払い」ですが、第三版として、リバイス。
移動方向の制御は変更していませんが、GetAsyncKeyState制御の撤回に加え、
千鳥足イメージを、すこし強調してみました。
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim StopLoop As Boolean
Sub 酔っ払い3()
Dim myRGB As Integer
Dim myRow As Long, myCol As Long
Dim x As Long, y As Long, z As Long, i As Long
Dim rtn As Long, svColor As Long, mySeq As Long
Dim myTrace As Long
Randomize
Cells.Clear
myTrace = RGB(&HC0, &HC0, &HC0) '軌跡の色 薄いグレー
StopLoop = False
Do
If StopLoop Then Exit Do
For i = 1 To 30
With ActiveCell
myRow = .Row
myCol = .Column
End With
z = Int((5 - 1 + 1) * Rnd + 1)
Select Case z
Case 1
x = 0: y = 0
Case 2
x = 0: y = 1
Case 3
x = 0: y = -1
Case 4
x = 1: y = 0
Case 5
x = -1: y = 0
End Select
If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
With ActiveCell
.Interior.Color = myTrace
.Offset(y, x).Activate
End With
With ActiveCell
mySeq = mySeq + 1
.Value = mySeq
.ShrinkToFit = True '縮小して全てを表示
.Font.Color = RGB(255, 255, 255) '文字色は白抜き
.Interior.Color = vbBlack
End With
Sleep 100
DoEvents
Next
With ActiveCell
For i = 1 To 20
.Interior.Color = vbWhite
Sleep 20
DoEvents
.Interior.Color = vbBlack
Sleep 20
DoEvents
Next
Sleep 500
DoEvents
End With
Loop
With ActiveCell
.Value = "轟沈 爆睡"
End With
End Sub
Sub おやすみ()
StopLoop = True
End Sub
|
|