Excel VBA質問箱 IV

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

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


12965 / 76734 ←次へ | 前へ→

【69280】Re:VBAプログラミング
発言  UO3  - 11/6/17(金) 16:35 -

引用なし
パスワード
   ▼文哉 さん:

こんにちは

やはり、GetAsyncKeyState が不安定です。
で、何回もキーを押すとPC全体が、変になる現象もでましたので、この制御は撤回し
かわりに「おやすみ」プロシジャを用意しました。これを実行すれば、千鳥足の徘徊は
終了します。(マクロショートカットキーに登録して実行すると操作しやすいかも)

で、本体の「酔っ払い」ですが、第三版として、リバイス。
移動方向の制御は変更していませんが、GetAsyncKeyState制御の撤回に加え、
千鳥足イメージを、すこし強調してみました。

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim StopLoop As Boolean

Sub 酔っ払い3()
  Dim myRGB As Integer
  Dim myRow As Long, myCol As Long
  Dim x As Long, y As Long, z As Long, i As Long
  Dim rtn As Long, svColor As Long, mySeq As Long
  Dim myTrace As Long
  
  Randomize
  Cells.Clear
  myTrace = RGB(&HC0, &HC0, &HC0) '軌跡の色 薄いグレー
  StopLoop = False
  
  Do
    If StopLoop Then Exit Do
  
    For i = 1 To 30
      With ActiveCell
        myRow = .Row
        myCol = .Column
      End With
  
      z = Int((5 - 1 + 1) * Rnd + 1)
  
      Select Case z
    
        Case 1
          x = 0: y = 0
        Case 2
          x = 0: y = 1
        Case 3
          x = 0: y = -1
        Case 4
          x = 1: y = 0
        Case 5
          x = -1: y = 0
      End Select
  
      If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
      If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
      
      With ActiveCell
        .Interior.Color = myTrace
        .Offset(y, x).Activate
      End With
      
      With ActiveCell
        mySeq = mySeq + 1
        .Value = mySeq
        .ShrinkToFit = True '縮小して全てを表示
        .Font.Color = RGB(255, 255, 255) '文字色は白抜き
        .Interior.Color = vbBlack
      End With
      
      Sleep 100
      DoEvents
      
    Next
    
    With ActiveCell

      For i = 1 To 20
        .Interior.Color = vbWhite
        Sleep 20
        DoEvents
        .Interior.Color = vbBlack
        Sleep 20
        DoEvents
      Next
   
      Sleep 500
      DoEvents

    End With
    
  Loop
 
  With ActiveCell
    .Value = "轟沈 爆睡"
  End With
 
End Sub

Sub おやすみ()
  StopLoop = True
End Sub

3 hits

【69270】VBAプログラミング 文哉 11/6/17(金) 6:07 質問
【69271】Re:VBAプログラミング UO3 11/6/17(金) 6:41 発言
【69273】Re:VBAプログラミング Jaka 11/6/17(金) 9:45 発言
【69278】あ〜、なんとなく解った。 Jaka 11/6/17(金) 12:54 発言
【69274】Re:VBAプログラミング SS 11/6/17(金) 9:49 発言
【69279】Re:VBAプログラミング SS 11/6/17(金) 13:07 発言
【69276】Re:VBAプログラミング UO3 11/6/17(金) 11:45 発言
【69277】Re:VBAプログラミング UO3 11/6/17(金) 12:29 発言
【69280】Re:VBAプログラミング UO3 11/6/17(金) 16:35 発言

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