[[20111130100821]]　『図形を浮遊させる』（俊介）　ページの最後に飛ぶ

『図形を浮遊させる』（俊介）

 クリックすると現れる図形を見ていて思いつきました。
 オートシェイプで作った図形５個を画面一杯の中で１０秒間浮遊させたいと思います。
 こんな事はできるでしょうか？
 【Excel2003,Windows Xp】

 「浮遊」って具体的には、どんな動きをさせたいの？

 (ぶらっと)

 ぶらっと様
 イメージとしてはフワーっと風船のようなシャボン玉のような動きで隅まで行ったらぶっかって跳ね返 る動きを考えています。
 １０秒では短いので３０秒ぐらいかなー （俊介）

 しゃぼんだまが「ふわっと」で「跳ね返る」というイメージじゃないのでご不満だろうけど試供品（？）
とりあえず、図形１つだけのサンプル。
複数の図形を操作するなら
Call moveShape(ActiveSheet.Shapes("Rectangle 1"))  '必要な図形を
これを必要な図形分だけ記述。

 Option Explicit
 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

 Sub test()
    Dim i As Long
    For i = 1 To 300   '100ミリ秒 x 300回 = 30秒
        Call moveShape(ActiveSheet.Shapes("Rectangle 1"))  '必要な図形を
        Sleep 100
        DoEvents
    Next
 End Sub

 Private Sub moveShape(mysp As Shape)
    Dim x1 As Long, x2 As Long
    Dim y1 As Long, y2 As Long
    Dim l As Long, t As Long

    With ActiveWindow.VisibleRange
        y1 = .Row
        x1 = .Column
        '図形が下に配置された時に画面からはみださないように行数を適宜調整
        y2 = y1 + .Rows.Count - 5
        '図形が左に配置された時に画面からはみださないように列数を適宜調整
        x2 = x1 + .Columns.Count - 3
    End With

    With mysp
        l = Int((x2 - x1 + 1) * Rnd + x1)
        t = Int((y2 - y1 + 1) * Rnd + y1)
        .Left = Cells(t, l).Left
        .Top = Cells(t, l).Top
    End With

 End Sub

 (ぶらっと)

 Sleepをもう少し小さな数値（たとえば10)にして、ループ回数を増やせば、もう少し「動いているなぁ」
という感じがでるかも。

 で、ループを無制限にして何かのキー（以下の例ではシフトキー）がおされたら終了にすることもできる。
Oval を３つ配置して。

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

 Sub test()
    Do
        If GetAsyncKeyState(16) <> 0 Then Exit Do 'シフトキーがおされたら終了
        Call moveShape(ActiveSheet.Shapes("Oval 1"))  '必要な図形を
        Call moveShape(ActiveSheet.Shapes("Oval 2"))  '必要な図形を
        Call moveShape(ActiveSheet.Shapes("Oval 3"))  '必要な図形を
        Sleep 10
        DoEvents
    Loop
 End Sub

 Private Sub moveShape(mysp As Shape)
    Dim x1 As Long, x2 As Long
    Dim y1 As Long, y2 As Long
    Dim l As Long, t As Long

    With ActiveWindow.VisibleRange
        y1 = .Row
        x1 = .Column
        '図形が下に配置された時に画面からはみださないように行数を適宜調整
        y2 = y1 + .Rows.Count - 5
        '図形が左に配置された時に画面からはみださないように列数を適宜調整
        x2 = x1 + .Columns.Count - 3
    End With

    With mysp
        l = Int((x2 - x1 + 1) * Rnd + x1)
        t = Int((y2 - y1 + 1) * Rnd + y1)
        .Left = Cells(t, l).Left
        .Top = Cells(t, l).Top
    End With

 End Sub

 (ぶらっと)

 ↑　図形が左に配置された時に
　これは、図形が「右」に配置された時に　　の間違い。

 (ぶらっと)

 ぶらっとさんのコードを一部お借りして・・・
 こんな風にしても面白いかも？

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

  Const MoveLong As Long = 5

  Sub test()
    Dim myTh() As Double
    Dim sh     As Shape
    Dim myRng  As Range
    Dim i      As Long
    Set myRng = ActiveWindow.VisibleRange
    With ActiveSheet.Shapes
      ReDim myTh(1 To .Count)
      Do
        If GetAsyncKeyState(16) <> 0 Then Exit Do 'シフトキーがおされたら終了
        For i = 1 To .Count
          While myTh(i) = 0 Or _
                .Item(i).Top <= Application.Top Or _
                .Item(i).Left <= Application.Left Or _
                .Item(i).Top + .Item(i).Height >= myRng.Top + myRng.Height Or _
                .Item(i).Left + .Item(i).Width >= myRng.Left + myRng.Width
            myTh(i) = RandTheta()
            moveShape .Item(i), myTh(i)
          Wend
          moveShape .Item(i), myTh(i)
        Next i
        Sleep 10
        DoEvents
      Loop
    End With
  End Sub

  Private Function RandTheta() As Double
    Randomize
    RandTheta = Int(360 * Rnd) / 180 * Application.WorksheetFunction.Pi()
  End Function

  Private Sub moveShape(mySh As Shape, th As Double)
    Dim x As Double
    Dim y As Double
    x = MoveLong * Cos(th)
    y = MoveLong * Sin(th)
    With mySh
      .Left = .Left + x
      .Top = .Top + y
    End With
  End Sub

 （ｍｏｍｏ）

ｍｏｍｏ様
イメージしていた通りの動きで素晴らしいのですがズームを５０%にしないと動かないのは何故？

 >ズームを５０%にしないと動かないのは何故？

 ん？こちらでは100%でも、ちゃんと動くよ。
それにしても、ｍｏｍｏさんのコード、いいねぇ。当方のような事務処理プログラム屋さんだと、なかなかできないなぁ。

 (ぶらっと)

 ぶらっと様
 お世話になっています。
 ぶらっと様のファイルで確認していたから？？なのかと思い新しいシートで動かしてみました。
 １００％で動いたのですがわずか１０秒足らずで砂時計のまま動きません。
 パソコンの性能？な。ｍｏｍｏ様（俊介）

 お遊びだったのであんまり細かく検証してませんけど
 ズームというより、フルサイズ画面だと貼りつく時がありますねぇ
 なぜかというと、コードの修正を２個所忘れていたから・・・・（苦笑）

 testを以下に差し替え

  Sub test()
    Dim myTh() As Double
    Dim sh     As Shape
    Dim myRng  As Range
    Dim i      As Long
    Set myRng = ActiveWindow.VisibleRange
    With ActiveSheet.Shapes
      ReDim myTh(1 To .Count)
      Do
        If GetAsyncKeyState(16) <> 0 Then Exit Do 'シフトキーがおされたら終了
        For i = 1 To .Count
          While myTh(i) = 0 Or _
                .Item(i).Top <= myRng.Top Or _
                .Item(i).Left <= myRng.Left Or _
                .Item(i).Top + .Item(i).Height >= myRng.Top + myRng.Height Or _
                .Item(i).Left + .Item(i).Width >= myRng.Left + myRng.Width
            myTh(i) = RandTheta()
            moveShape .Item(i), myTh(i)
          Wend
          moveShape .Item(i), myTh(i)
        Next i
        Sleep 10
        DoEvents
        DoEvents
      Loop
    End With
  End Sub

 どこの修正を忘れていたかは・・・恥ずかしいのでご自由に探してください^^;

 >ぶらっとさん
 私はただのEXCEL好きなだけでプロじゃないです。
 なので、常にロジックの面白さを中心に追及しているので
 能力のある方には面白く見えて、実は中途半端な事も多いです^^;

 （ｍｏｍｏ）

ｍｏｍｏ様

 修正したのですが・・やはり固まってしまいます。(涙.シクシク)（俊介）

 固まるというのはどのような現象でしょう？
 最初のコードでは確かに左と上で固定されてしまいますが・・・
 （ｍｏｍｏ）

 横から失礼。
今、３０分ぐらい動かしているけど、固まりはしない。固まりはしないけど、ぴたっと、動きがとまる場合がある。
（いずれ、また動き出すけど）
Escキーで中断させたあとステップ実行すると、
        For i = 1 To .Count
          While myTh(i) = 0 Or _
                省略
            myTh(i) = RandTheta()
            moveShape .Item(i), myTh(i)
          Wend
          moveShape .Item(i), myTh(i)
        Next i
この　While と Wend のループ内をくるくる回っていて、なかなか下の　moveShape .Item(i), myTh(i)　に
おりてこない状態。

 どのようなときに、この繰り返しになるのかのチェックはしていないけど、
（俊介）さんのケースは、このループの繰り返しの回数が異常に大きいのかも。

 追記）今、また、ぴたっとなって、なかなか帰ってこなかったのでEscで中断。
　　こちらではOvalを４つ配置して動かしているんだけど、そのうちの１つが、
    VisbleRangeではなく、からり離れたページに配置されていた。
　　ジャストインフォメーションとして。

 (ぶらっと)

 なるほど・・・
 そのループは画面から外れた方向に移動しようとした時に
 外れない方向になるまでベクトル角度をやり直しているんですが
 そもそもランダムで角度を与えてるので連続する事があるかもしれませんね。

 かなり離れた場所は・・・わからない・・・^^;

 元々遊びのつもりでしたけど、突き詰める必要があるなら
 角度の与え方をランダムじゃなくてぶつかった壁ごとに制御しないとダメですね。
 それか入射角から反射角を求めるようなロジックを入れるか・・・
 （ｍｏｍｏ）

 ぶらっと様
 フォローありがとうございます。
 ｍｏｍｏ様
  myTh(i) = RandTheta()
 .Top = .Top + y
 ここで止まっているようなのですが・・・チョット変なのです。
 Sheet1で動かしていたのですがSheet2やSheet3ならスムーズに動きますが一瞬止まる時も・・このあたりはぶらっと様のお話と同じです。（俊介）

 さて、少し変更してみましたがこんなのではどうでしょう？

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

  Const MoveLong      As Long = 5

  Sub test()
    Dim myTh() As Double
    Dim i      As Long
    Dim cnt    As Long
    With ActiveSheet.Shapes
      ReDim myTh(1 To .Count)
      Do
        If GetAsyncKeyState(16) <> 0 Then Exit Do 'シフトキーがおされたら終了
        For i = 1 To .Count
          cnt = 0
          Do While myTh(i) = 0 Or ChkArea(.Item(i), myTh(i)) = False
            myTh(i) = RandTheta()
            cnt = cnt + 1
            If cnt = 30 Then
              .Item(i).Left = 0
              .Item(i).Top = 0
              Exit Do
            End If
          Loop
          moveShape .Item(i), myTh(i)
        Next i
        Sleep 10
        DoEvents
        DoEvents
      Loop
    End With
  End Sub

  Private Function ChkArea(mySh As Shape, th As Double) As Integer
    Dim x As Double
    Dim y As Double
    If th = 0 Then
      x = mySh.Left
      y = mySh.Top
    Else
      x = mySh.Left + MoveLong * Cos(th)
      y = mySh.Top + MoveLong * Sin(th)
    End If
    With ActiveWindow.VisibleRange
      If x <= .Left Or _
         y <= .Top Or _
         x + mySh.Width > .Width Or _
         y + mySh.Height > .Height Then
        ChkArea = False
      Else
        ChkArea = True
      End If
    End With
  End Function

  Private Function RandTheta() As Double
    Randomize
    RandTheta = Int(360 * Rnd + 1) / 180 * Application.WorksheetFunction.Pi()
  End Function

  Private Sub moveShape(mySh As Shape, th As Double)
    With mySh
      .Left = .Left + MoveLong * Cos(th)
      .Top = .Top + MoveLong * Sin(th)
    End With
  End Sub

 （ｍｏｍｏ）

 ｍｏｍｏ様
 お手数をおかけしました。
 希望通りのコードです。
 何を作ろうかと言いますと「シフトキーがおされたら終了」でしたが、これで画像を全部消します。
 画像の消えた箇所を探してクリックし画像を出します。
 画像には簡単な九九問題が書いてあり問題を解きます。
 小二の息子が九九をやり始めたので作ってやろうと思いました。
 覚えようとしないのでゲーム感覚で覚えられたらと思っています。（俊介）

 ｍｏｍｏ様
 ご相談なのですが画面一杯で動かしているコードはどこなのでしょうか？
 実は一番下まで行くと答の記入が出来ない場合(かぶってしまう)がありそのセル分は避けたいのです。(俊介)

 ｍｏｍｏさんへの質問でしゃしゃりでるのもいかがなもんかとは思うけど　ChkArea　の中の

 With ActiveWindow.VisibleRange
    '
    '
    '
 End With

 これで画面いっぱいの範囲が規定されているので、たとえば下３行を対象外にするなら

 With ActiveWindow.VisibleRange.Resize(ActiveWindow.VisibleRange.Rows.Count - 3)
    '
    '
    '
 End With

 これでいけるんじゃないかな？

 (ぶらっと)

ぶらっと様

 お助けありがとうございます。
 いけました。
 もう一ついいですか？図形を消すのコードが何処か間違っていてアクティブになるのです。

 Sub 図形を消す()
     ActiveSheet.Shapes("四角形 1").Select
     With Selection.Font
          .ColorIndex = 2
     End With

    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 1
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 1
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
 End Sub
 ActiveSheet.Shapes("四角形 1").Select　これがダメと思うのですが分からないのです。
 すみませんが教えてください。(俊介)

 横から失礼します。

 >クリックすると現れる図形を見ていて思いつきました。

 元々のスレッドの内容を良く見てください。

[[20111126210215]]　『クリックすると現れる図形』（悠介）　

 (シスボーベー)

 >ActiveSheet.Shapes("四角形 1").Select　これがダメと思うのですが分からないのです。
 > すみませんが教えてください。(俊介)

 VBAヘルプやネット検索するなどしてコードの意味を理解するようにしてください。

 >覚えようとしないのでゲーム感覚で覚えられたらと思っています。

 親御さんの方もゲーム感覚でVBAを覚えられるように回答者が工夫してやらなければいけない
 のかな・・・。

 (カエムワセト)

コメント返信：

[ 一覧(最新更新順) ]

[[20111130100821]] 『図形を浮遊させる』（俊介） ページの最後に飛ぶ

[[20111130100821]]　『図形を浮遊させる』（俊介）　ページの最後に飛ぶ