| |
▼kinoko さん：
私も一例を。
動きの枠を、今、デスクトップに表示されているエクセルシートの範囲にしています。
ただし、かなり細かなマス目にしてありますよね。【壁】には、なかなか到達しないかもしれません。
気長に眺めていれば、いつかは壁にぶつかって、壁の外にはいかない動きをします。
すでに通り過ぎて色がついているセルについては、HSV色相で左回りに10°ずつ、色を変化させています。
h tps://ja.wikipedia.org/wiki/%E8%89%B2%E7%9B%B8
なお、HSV色相に関してはＶＢＡでは標準の変換関数がないので自前で共通プロシジャとして使っているものを
使います。
Shiftキーを眺めに押せば、終了します。
●テストモジュール
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Sub Sample()
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 d As HSVSET
Dim pos 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
'最初のセルを選定
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
d = RGB2HSV(.Color)
d.h = d.h + 10 '次からは色相を10°左回りに移動した色
.Color = HSV2RGB(d)
End If
End With
Sleep 10
DoEvents
Loop
End Sub
●共通プロシジャモジュール
Public Type HSVSET
h As Double
s As Double
v As Double
End Type
Public Type RGBSET
r As Long
g As Long
b As Long
End Type
Function RGB2HSV(rgbVal As Long) As HSVSET
Dim mx As Long
Dim mn As Long
Dim r As Long
Dim g As Long
Dim b As Long
Dim z As RGBSET
z = divRGB(rgbVal)
r = z.r
g = z.g
b = z.b
mn = WorksheetFunction.Min(r, g, b)
mx = WorksheetFunction.Max(r, g, b)
If mx = mn Then
RGB2HSV.h = 0
Else
Select Case mx
Case r
RGB2HSV.h = (60 * (g - b) / (mx - mn) + 360)
If (RGB2HSV.h >= 360#) Then
RGB2HSV.h = RGB2HSV.h - 360#
End If
Case g
RGB2HSV.h = 60 * (b - r) / (mx - mn) + 120
Case b
RGB2HSV.h = 60 * (r - g) / (mx - mn) + 240
End Select
End If
If mx = 0 Or mx = mn Then
RGB2HSV.s = 0
Else
RGB2HSV.s = 255 * ((mx - mn) / mx)
End If
RGB2HSV.v = mx
End Function
Function HSV2RGB(d As HSVSET) As Long
Dim r As Long
Dim g As Long
Dim b As Long
Dim f As Double
Dim i As Long
Dim p As Long
Dim q As Long
Dim t As Long
Dim h As Double
Dim s As Double
Dim v As Double
If d.s = 0 Then
r = d.v
g = d.v
b = d.v
Else
h = d.h
s = d.s
v = d.v
If h = 360 Then h = 0
i = Int(h / 60) Mod 6
f = h / 60 - Int(h / 60)
p = Int(CInt(v * (1 - (s / 255))))
q = Int(CInt(v * (1 - (s / 255) * f)))
t = Int(CInt(v * (1 - ((s / 255) * (1 - f)))))
Select Case i
Case 0: r = v: g = t: b = p
Case 1: r = q: g = v: b = p
Case 2: r = p: g = v: b = t
Case 3: r = p: g = q: b = v
Case 4: r = t: g = p: b = v
Case 5: r = v: g = p: b = q
End Select
End If
HSV2RGB = RGB(r, g, b)
End Function
Function divRGB(rgbVal As Long) As RGBSET
divRGB.b = rgbVal \ 256 ^ 2
divRGB.g = (rgbVal - divRGB.b * 256 ^ 2) \ 256
divRGB.r = rgbVal - divRGB.b * 256 ^ 2 - divRGB.g * 256
End Function
|
|
β
- 16/6/23(木) 21:48 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
