| |
▼文哉 さん：
一応、色合いの多段階変化【以外】の改訂版です。
もうちょっと、よろよろかんを出してみましたが、さて、どうでしょう。
斜め移動をなくした結果、移動選択肢が少なくなって、動きが少なくなっています。
なお、途中で Shiftキーをおして終了させるようにしています。
ただ、すぐにキーを認識してくれる場合となかなか認識してくれない場合が
あります。ポンポンと２回ほど押すと認識確立が高くなりますが、あまりに
何回もおしていると、Windowsからメッセージがでるかもしれません。
どうしてもとまらない場合は、任意の文字を入力してください。
スペースでもいいです。要は、編集モードにしてマクロ実行を強制的に中断。
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Sub 酔っ払い2()
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
Randomize
Cells.Clear
myRGB = 223 '開始時の色合い
Do
rtn = GetAsyncKeyState(16) 'Shiftキー
If rtn <> 0 Then Exit Do
Sleep 500
DoEvents
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
ActiveCell.Offset(y, x).Activate
With ActiveCell
svColor = RGB(myRGB, myRGB, myRGB)
For i = 1 To 10
.Interior.Color = svColor
Sleep 30
DoEvents
.Interior.Color = vbWhite
Sleep 30
DoEvents
Next
Sleep 500
.Interior.Color = svColor
mySeq = mySeq + 1
.Value = mySeq
.ShrinkToFit = True '縮小して全てを表示
.Font.Color = RGB(255, 255, 255) '文字色は白抜き
myRGB = myRGB - 1 '次の色用
End With
Loop
With ActiveCell
.Value = "轟沈 爆睡"
.Interior.Color = vbBlack
End With
End Sub
|
|
UO3
- 11/6/17(金) 12:29 -
