Excel VBA質問箱 IV

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

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


12969 / 76734 ←次へ | 前へ→

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

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

こんにちは

テーマがおもしろいので、ちょっと遊んでみました。
文哉さんの意図は「お掃除ロボット」のようなスムーズな動きかもしれませんが
「よっぱらいの千鳥足」をイメージしています。
壁際では、壁に向かって進んで頭をぶつけることもあると思いますし、一歩踏み出して
よろよろっと、そんな感じをだせないかなと。

まだ、未完成というか、以下の点が気に入らないのですが。
・だんだん意識が暗くなっていくことをイメージして、色合いを濃くしていってるんですが
 今は4段階ぐらい、これを、もう少し細かな移り変わりにできたらと。
・左右上下に移動方向を限定しているつもりなんですが、斜めにも移動。バグでしょうね。

なお、実行中に、任意の文字を入力すれば終了します。

Sub 酔っ払い()
  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
  
  Cells.Clear
  myRGB = 200 '開始時の色合い
  
  Do
    Sleep 50
    DoEvents
    DoEvents
    
    With ActiveCell
      myRow = .Row
      myCol = .Column
    End With

    x = Int((1 - (-1) + 1) * Rnd + (-1))
    y = Int((1 - (-1) + 1) * Rnd + (-1))
    
    If myRow + y < 1 Or myRow + y > Rows.Count Then y = 0
    If myCol + x < 1 Or myCol + x > Columns.Count Then x = 0
    
    If x <> 0 Or y <> 0 Then ActiveCell.Offset(y, x).Activate
    With ActiveCell
      svColor = RGB(myRGB, myRGB, myRGB)
      For i = 1 To 10
        
        .Interior.Color = vbBlack
        Sleep 30
        DoEvents
        .Interior.Color = svColor
        Sleep 30
        DoEvents
        
      Next
      .Interior.Color = svColor
      mySeq = mySeq + 1
      .Value = mySeq
      .ShrinkToFit = True '縮小して全てを表示
      .Font.Color = RGB(255, 255, 255) '文字色は白抜き
      myRGB = myRGB - 1 '次の色用

    End With
  Loop
  
End Sub

8 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 発言

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