| |
こんにちは。
その書籍のタイトルにもあるように、
「〜入門」ですので、完璧さを求めるのはムリがあると
思います。
通常Do〜Loop中でのDoEvents命令はOSに溜まったメッセージの
処理を要求するので、簡単とは言え不具合が生じる場面も
あったりします。
興味本位ですが、以下のようなTimerを使った別方法もありますので、
ご参考にしてください。
（標準モジュール）
Declare Function FindWindowExW& Lib "User32" _
(ByVal hwndParent&, _
ByVal hwndChildAfter&, _
ByVal lpszClass&, _
ByVal lpszWindow&)
Declare Function SetTimer& Lib "User32" _
(ByVal hWnd&, _
ByVal nIDEvent&, _
ByVal uElapsed&, _
ByVal lpTimerFunc&)
Declare Function KillTimer& Lib "User32" _
(ByVal hWnd&, _
ByVal nIDEvent&)
Declare Function GetAsyncKeyState% Lib "User32" _
(ByVal vKey&)
Declare Function GetFocus& Lib "User32" ()
Declare Function GetAncestor& Lib "User32" _
(ByVal hWnd&, _
ByVal gaFlag&)
Private Reel, ReelV
Private n(1 To 3) As Long
Private ReelF(1 To 3) As Boolean
Private hTgt&, TimerID&
Sub GameStart()
Dim Interval&
Erase ReelF
Reel = Worksheets("ReelData").Range("B3:D18")
With Range("B4:D4")
.NumberFormat = "@"
ReelV = .Value
End With
hTgt = FindWindowExW(Application.hWnd, 0, StrPtr("XLDESK"), 0)
hTgt = FindWindowExW(hTgt, 0, StrPtr("EXCEL7"), 0)
GameStop
Application.OnKey "z", ""
Application.OnKey "x", ""
Application.OnKey "c", ""
' 適当に間隔を調整...
Interval = 10
TimerID = SetTimer(0, 0, Interval, AddressOf TimerProc)
End Sub
Sub GameStop()
If TimerID Then KillTimer 0, TimerID
TimerID = 0
Application.OnKey "z"
Application.OnKey "x"
Application.OnKey "c"
End Sub
Private Sub TimerProc _
(ByVal hWnd&, ByVal uMsg&, ByVal nIDEvent&, ByVal dwTime&)
Dim i As Long, hTmp&
hTmp = GetFocus()
If hTmp <> hTgt Then
If GetAncestor(hTmp, 2) = Application.hWnd Then
Exit Sub
End If
End If
For i = 1 To 3
If Not ReelF(i) Then
n(i) = n(i) + 1
If n(i) > 16 Then n(i) = 1
'表示用文字列を格納
ReelV(1, i) = Reel(n(i), i)
End If
Next
'リールを一括画面表示
On Error Resume Next
Range("B4:D4") = ReelV
On Error GoTo 0
'ボタンをPushしたら各リールを止める。
If Not ReelF(1) Then ReelF(1) = GetAsyncKeyState(vbKeyZ) And &H8000
If Not ReelF(2) Then ReelF(2) = GetAsyncKeyState(vbKeyX) And &H8000
If Not ReelF(3) Then ReelF(3) = GetAsyncKeyState(vbKeyC) And &H8000
'全てのリールがストップしたらゲームを終了する。
If Not ReelF(1) Then Exit Sub
If Not ReelF(2) Then Exit Sub
If Not ReelF(3) Then Exit Sub
GameStop
CheckScore
End Sub
Private Sub CheckScore()
Dim temp As String
Dim bFlag As Boolean
bFlag = Range("B4").Value = Range("C4").Value
bFlag = bFlag And (Range("C4").Value = Range("D4").Value)
If bFlag Then
Select Case Range("B4").Value
Case 7: temp = "大当たり!!"
Case "Bar": temp = "中当たり!!"
Case Else: temp = "小当たり!"
End Select
Else
temp = "はずれ。。"
End If
MsgBox temp
End Sub
' Book終了前にはTimer解除確認。
Private Sub Auto_Close()
GameStop
End Sub
|
|
Abyss
- 13/8/30(金) 17:32 -
