Excel VBA質問箱 IV

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

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


1402 / 13644 ツリー ←次へ | 前へ→

【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 発言[未読]

【74671】はじめまして、ご質問させてください。
質問  化け猫  - 13/8/28(水) 14:33 -

引用なし
パスワード
   "Excel VBA アクションゲーム作成入門"の4-1項にスロットゲームがありますが、私のPCで動作させしばらくするとExcel が応答しなくなります。
どうしたら解決できますか?

初心者なので、分かりかねますが今後より複雑な恒常ループ関数を作成した時に動かなくなるのでは、、と不安に思っております。

ご回答いただけると幸いです。

【74672】Re:はじめまして、ご質問させてください。
発言  ウッシ  - 13/8/28(水) 17:00 -

引用なし
パスワード
   こんにちは

"Excel VBA アクションゲーム作成入門"
を持っている人でないと回答出来ないかも。
どんなコードなんでしょう?

PCの性能も関係有るでしょうし、なんとも言えないです。


▼化け猫 さん:
>"Excel VBA アクションゲーム作成入門"の4-1項にスロットゲームがありますが、私のPCで動作させしばらくするとExcel が応答しなくなります。
>どうしたら解決できますか?
>
>初心者なので、分かりかねますが今後より複雑な恒常ループ関数を作成した時に動かなくなるのでは、、と不安に思っております。
>
>ご回答いただけると幸いです。

【74673】Re:はじめまして、ご質問させてください。
お礼  化け猫  - 13/8/28(水) 18:00 -

引用なし
パスワード
   > ウッシさん
ご回答ありがとうございます。
本に載っているコードと私のコードは少しばかり異なるのですが、起る現象は同じ
でした。
下記に私のコードを載せます。(長文になってしまいすいません。。。)
スロットをしばらくまわしたままにしておくとexcelが応答しなくなります。

Option Explicit
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ReelData()

  Dim Reel As Variant
  
  Reel = Worksheets("ReelData").Range("B3:D18")
  
  
  Dim ReelV As Variant
  Dim n(1 To 3) As Integer
  Dim i As Integer
  Dim GameFlag As Boolean
  Dim ReelF(1 To 3) As Boolean
    
  ReelV = Range("B4:D4")
  
  Do While GameFlag = False
    
    Dim t1 As Long
    Dim t2 As Long
        
    t1 = GetTickCount
    t2 = Worksheets("ReelData").Range("G2").Value
    
    Do While GetTickCount - t1 < t2
      
      Sleep Worksheets("ReelData").Range("G2").Value
            
    Loop
    
    For i = 1 To 3
      
      If ReelF(i) = False Then
        
        n(i) = n(i) + 1
        
        If n(i) > 16 Then
        
          n(i) = 1
          
        End If
      
        '表示用文字列を格納
        ReelV(1, i) = Reel(n(i), i)
      
      End If
      
    Next
     
    'リールを一括画面表示
    Range("B4:D4") = ReelV
        
    'ボタンをPushしたら各リールを止める。
    If GetAsyncKeyState(90) <> 0 Then
      
      ReelF(1) = True
          
    End If
    
    If GetAsyncKeyState(88) <> 0 Then
    
      ReelF(2) = True
  
    End If
    
    If GetAsyncKeyState(67) <> 0 Then
      
      ReelF(3) = True
      
    End If
    
    
    '全てのリールがストップしたらゲームを終了する。
    If ReelF(1) Then
      
      If ReelF(2) Then
        
        If ReelF(3) Then
              
          GameFlag = True
           
        End If
      
      End If
      
    End If
        
  Loop
  
  Dim temp As String
  
  If Range("B4").Value = Range("C4").Value And Range("C4").Value = Range("D4").Value Then
    
    If Range("B4").Value = 7 Then
    
      temp = "大当たり!!!"
      
    ElseIf Range("B4").Value = "BAR" Then
    
      temp = "中当たり!!"
    
    Else
      
      temp = "小当たり!"
    
    End If
    
  Else
  
    temp = "はずれ。。"
    
    
  End If
  
  MsgBox temp
     
End Sub

【74675】Re:はじめまして、ご質問させてください。
質問  ウッシ  - 13/8/28(水) 20:55 -

引用なし
パスワード
   こんばんは

Worksheets("ReelData")上のデータとかボタンとかはどうなっているのでしょうか?

テスト出来る程度の情報でいいので宜しくお願いします。

【74676】Re:はじめまして、ご質問させてください。
発言  化け猫  - 13/8/28(水) 21:09 -

引用なし
パスワード
   > ウッシさん

ReelDataシートは、データのみで以下を表記しています。
スロットのシートでは、マクロ実行ボタンを一つだけ設けています。

    リール1 リール2 リール3
1    7     7    7
2    7     7    BAR
3    7     3    7
4    BAR    BAR   BAR
5    BAR    4    2
6    4     4    4
7    3     2    2
8    1     3    1
9    7     4    7
10    7     7    BAR
11    7      7    7
12    BAR    1    BAR
13    BAR    2    1
14    3     BAR   3
15    3     4    4
16    4     5    4

【74677】Re:はじめまして、ご質問させてください。
回答  ウッシ  - 13/8/28(水) 23:29 -

引用なし
パスワード
   こんばんは

どの程度動かすとハングするのでしょうか?

問題無く動いている感じがしますけど、一応ループの中の変数宣言は外に出すとして

Option Explicit
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Declare Function GetTickCount Lib "kernel32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ReelData()

  Dim Reel As Variant
  Dim t1 As Long
  Dim t2 As Long
  Dim temp As String
  Dim ReelV As Variant
  Dim n(1 To 3) As Integer
  Dim i As Integer
  Dim GameFlag As Boolean
  Dim ReelF(1 To 3) As Boolean
  
 
  Reel = Worksheets("ReelData").Range("B3:D18")
 
  ReelV = Range("B4:D4")
  
  t2 = Worksheets("ReelData").Range("G2").Value
  
  Do While GameFlag = False
  
'    Dim t1 As Long
'    Dim t2 As Long
    
    t1 = GetTickCount
'    t2 = Worksheets("ReelData").Range("G2").Value
  
    Do While GetTickCount - t1 < t2
   
      Sleep Worksheets("ReelData").Range("G2").Value
    
    Loop
  
    For i = 1 To 3
   
      If ReelF(i) = False Then
    
        n(i) = n(i) + 1
    
        If n(i) > 16 Then
    
          n(i) = 1
     
        End If
   
        '表示用文字列を格納
        ReelV(1, i) = Reel(n(i), i)
   
      End If
   
    Next
   
    'リールを一括画面表示
    Range("B4:D4") = ReelV
    
    'ボタンをPushしたら各リールを止める。
    If GetAsyncKeyState(90) <> 0 Then  'z
   
      ReelF(1) = True
     
    End If
  
    If GetAsyncKeyState(88) <> 0 Then  'x
  
      ReelF(2) = True
 
    End If
  
    If GetAsyncKeyState(67) <> 0 Then  'c
   
      ReelF(3) = True
   
    End If
  
  
    '全てのリールがストップしたらゲームを終了する。
    If ReelF(1) Then
   
      If ReelF(2) Then
    
        If ReelF(3) Then
       
          GameFlag = True
      
        End If
   
      End If
   
    End If
    
  Loop
 
'  Dim temp As String
 
  If Range("B4").Value = Range("C4").Value And Range("C4").Value = Range("D4").Value Then
  
    If Range("B4").Value = 7 Then
  
      temp = "大当たり!!!"
   
    ElseIf Range("B4").Value = "BAR" Then
  
      temp = "中当たり!!"
  
    Else
   
      temp = "小当たり!"
  
    End If
  
  Else
 
    temp = "はずれ。。"
  
  
  End If
 
  MsgBox temp
   
End Sub

【74679】Re:はじめまして、ご質問させてください。
発言  化け猫  - 13/8/29(木) 8:51 -

引用なし
パスワード
   > ウッシさん

ご対応ありがとうございます。
概算ですが、9秒程度で応答しなくなっています。

原因がわからないので、ウッシさんのように変数宣言をまとめてみましたが、
状況はかわりませんでした。

ちなみに私のPCは、LL750/Cでメモリの拡張はしていませんが、
十分なスペックを有していると思われます。

【74680】Re:はじめまして、ご質問させてください。
回答  ウッシ  - 13/8/29(木) 10:34 -

引用なし
パスワード
   こんにちは

9秒ですか?
昨夜は分からなかったので30分位動かしましたけどなんともなかったです。

自宅は、Vista、Excel2007で5年落ち位のPCですけど。

コードの問題では無さそうですね。

ちょっと別の方にも試して貰えるといいですね。


▼化け猫 さん:
>> ウッシさん
>
>ご対応ありがとうございます。
>概算ですが、9秒程度で応答しなくなっています。
>
>原因がわからないので、ウッシさんのように変数宣言をまとめてみましたが、
>状況はかわりませんでした。
>
>ちなみに私のPCは、LL750/Cでメモリの拡張はしていませんが、
>十分なスペックを有していると思われます。

【74684】Re:はじめまして、ご質問させてください。
お礼  化け猫  - 13/8/29(木) 17:54 -

引用なし
パスワード
   > ウッシさん

ご対応くださり、ありがとうございました(^<^)
色々設定を変えて、トライしてみようと思います。

> 皆様

この問題に対し、引き続き回答を受け付けております。
Excel2010を使って同じような現象が起こるという方は、
レスいただけると助かります。

【74685】Re:はじめまして、ご質問させてください。
発言  ichinose  - 13/8/29(木) 20:06 -

引用なし
パスワード
   こんばんは。

現象確認しました。
必ずではないですが、かなりの頻度で発生しますね!!

ループ内にDoeventsを入れると私が試した限りでは、
「応答なし」 にはなりませんでした。


但し、Doeventsを入れるとなると、キーボードでリールを止めるのではなく、
フォームのボタンを三つ設けて、これでリールを止める仕様にしてみては?
いかがですか?
他にも変更は必要かもしれませんが・・・・。

【74686】Re:はじめまして、ご質問させてください。
お礼  化け猫  - 13/8/29(木) 20:12 -

引用なし
パスワード
   > ichinose さん、ウッシさん

コンバンワ、そしてichinoseさんご回答ありがとうございます。

わたしも先程DoEventsをDo Loop の中に三回連続で記載したところ、
正常に動作するようになりました!

私には、DoEventsの意味するところが分かりませんが勉強してみます。
ありがとうございました(^<^)

【74689】Re:はじめまして、ご質問させてください。
発言  化け猫  - 13/8/30(金) 5:30 -

引用なし
パスワード
   > ichinoseさん、ウッシさん

おはようございます。

Excel2010にて長いループを検出した場合、応答なしになると断定すると、Excel2010の仕様であるとは考えられませんか。


推論ですが、故障時制御のようなものをExcel2010で追加したというのであれば、DoEventsは必要不可欠なコードになっているのかもしれませんね。

【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

【74691】Re:はじめまして、ご質問させてください。
発言  ichinose  - 13/8/30(金) 21:01 -

引用なし
パスワード
   >
>推論ですが、故障時制御のようなものをExcel2010で追加したというのであれば、DoEventsは必要不可欠なコードになっているのかもしれませんね。

この現象、厄介ですね!!
簡単な例だと

Option Explicit
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long

Sub test()
  Dim a As Long
  Do
    a = a + 1
    If GetAsyncKeyState(13) <> 0 Then Exit Do
  Loop
End Sub

これでも発生しますね!!

上記の場合、長くループさせれば、オーバーフローエラーになりますが。
正常に回っている状態でもマウスを一回クリックすると、
反応なしになることもあります。
反応なしになると、ループを抜ける手段を作っていかないと、
ESCキーでも止められません。

これは、直してもらわないといけませんねえ MS社に・・。

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