| |
▼kinoko さん：
>一度通ったところは赤、二度目は青色っていう
ということなら色相返還をしなくてもいいので、アップした、共通モジュールプロシジャは必要なく
以下のみでＯＫですね。
色の順番は ★のところで規定しています。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Sub Sample2()
Dim i As Long
Dim j As Long
Dim n As Long
Dim t As Long
Dim l As Long
Dim r As Long
Dim b As Long
Dim a As Range
Dim rtn As Long
Dim pos As Variant
Dim color As Variant
Cells.Clear
Randomize
Cells.RowHeight = 5
Cells.ColumnWidth = 0.5
With ActiveWindow.VisibleRange
t = .Row
b = .Rows.Count
l = .Column
r = .Columns.Count
End With
color = Array(vbRed, vbBlue, vbMagenta, vbYellow, vbCyan, vbBlack, vbRed) '★
'最初のセルを選定
i = Int((b - t + 1) * Rnd + t)
j = Int((r - l + 1) * Rnd + l)
Cells(i, j).Interior.color = vbRed
Do
rtn = GetAsyncKeyState(16) 'シフトキー
rtn = rtn And &H80000000
If rtn <> 0 Then Exit Do
If i = l And j = t Then '領域の左上隅
pos = Array(5, 7, 8)
ElseIf i = r And j = t Then '領域の右上隅
pos = Array(4, 6, 7)
ElseIf i = b And j = l Then '領域の左下隅
pos = Array(2, 3, 5)
ElseIf i = b And j = r Then '領域の右下隅
pos = Array(1, 2, 6)
ElseIf i = t Then '領域の上辺
pos = Array(4, 5, 6, 7, 8)
ElseIf i = b Then '領域の下辺
pos = Array(1, 2, 3, 4, 5)
ElseIf j = l Then '領域の左端
pos = Array(2, 3, 5, 7, 8)
ElseIf j = r Then '領域の右端
pos = Array(1, 2, 4, 6, 7)
Else
pos = Array(1, 2, 3, 4, 5, 6, 7, 8)
End If
n = Int((UBound(pos) - LBound(pos) + 1) * Rnd + LBound(pos))
n = pos(n)
'セル移動
Select Case n
Case 1: i = i - 1: j = j - 1
Case 2: i = i - 1
Case 3: i = i - 1: j = j + 1
Case 4: j = j - 1
Case 5: j = j + 1
Case 6: i = i + 1: j = j - 1
Case 7: i = i + 1
Case 8: i = i + 1: j = j + 1
End Select
With Cells(i, j).Interior
If .ColorIndex = xlNone Then
.color = vbRed '最初は赤
Else
n = WorksheetFunction.Match(.color, color, 0)
.color = color(n)
End If
End With
Sleep 10
DoEvents
Loop
End Sub
|
|
γ
- 16/7/18(月) 14:36 -
Gyouko
- 16/7/16(土) 16:51 -
lonelysocrates
- 16/7/4(月) 23:31 -
