Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7628 / 76732 ←次へ | 前へ→

【74690】Re:はじめまして、ご質問させてください。
発言  Abyss  - 13/8/30(金) 17:32 -

引用なし
パスワード
   こんにちは。
その書籍のタイトルにもあるように、
「〜入門」ですので、完璧さを求めるのはムリがあると
思います。

通常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
8 hits

【74671】はじめまして、ご質問させてください。 化け猫 13/8/28(水) 14:33 質問
【74672】Re:はじめまして、ご質問させてください。 ウッシ 13/8/28(水) 17:00 発言
【74673】Re:はじめまして、ご質問させてください。 化け猫 13/8/28(水) 18:00 お礼
【74675】Re:はじめまして、ご質問させてください。 ウッシ 13/8/28(水) 20:55 質問
【74676】Re:はじめまして、ご質問させてください。 化け猫 13/8/28(水) 21:09 発言
【74677】Re:はじめまして、ご質問させてください。 ウッシ 13/8/28(水) 23:29 回答
【74679】Re:はじめまして、ご質問させてください。 化け猫 13/8/29(木) 8:51 発言
【74680】Re:はじめまして、ご質問させてください。 ウッシ 13/8/29(木) 10:34 回答
【74684】Re:はじめまして、ご質問させてください。 化け猫 13/8/29(木) 17:54 お礼
【74685】Re:はじめまして、ご質問させてください。 ichinose 13/8/29(木) 20:06 発言
【74686】Re:はじめまして、ご質問させてください。 化け猫 13/8/29(木) 20:12 お礼
【74689】Re:はじめまして、ご質問させてください。 化け猫 13/8/30(金) 5:30 発言
【74690】Re:はじめまして、ご質問させてください。 Abyss 13/8/30(金) 17:32 発言
【74691】Re:はじめまして、ご質問させてください。 ichinose 13/8/30(金) 21:01 発言

7628 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free