[[20120915115344]]　『VBAで図形の重なり』（まこと）　ページの最後に飛ぶ

『VBAで図形の重なり』（まこと）

お世話になります。
マクロを使ってオートシェープを複数描いています。
オートシェープ1の上に、オートシェイプ2をたくさん描いております。
オートシェイプ１上に描かれたオートシェイプ2は残し、
オートシェイプ１からはみ出した、オートシェイプ2を削除したいです。
これらを見分けるにはどのように記載をすれば良いのでしょうか？

丁度、お相撲で例えると、
土俵の中の力士を残し、
土俵外の力士は消す、
土俵の俵に足が掛かっていれば残す。

という感じなのですが、この3つの判別方法を
どなたか教えていただけませんでしょうか？

 >オートシェープ1の上に、オートシェイプ2をたくさん描いております

 これらはシェープの名前ではなく、「あるオートシェープの上にたくさんの別のオートシェープを描いている」
 ということだよね？

 ↑　ということなら、たとえば

 Sub Sample()
    Dim mySP As Shape
    Dim yourSP As Shape
    Dim myL As Double
    Dim myT As Double
    Dim myB As Double
    Dim myR As Double

    Set mySP = ActiveSheet.Shapes("Rectangle 1")  '基準のシェープ名
    With mySP
        myL = .Left
        myT = .Top
        myB = .Top + .Height
        myR = .Left + .Width
    End With

    For Each yourSP In ActiveSheet.Shapes
        If Not yourSP Is mySP Then
            With yourSP
                If .Top < myT Or .Left < myL Or .Top + .Height > myB Or .Left + .Width > myR Then yourSP.Delete
            End With
        End If
    Next
 End Sub

 (ぶらっと)

削除の条件が少したりないかも？（マナ）

 考えてたら頭が混乱して挫折しちゃいました。
 > If .Top < myT Or .Left < myL Or .Top + .Height > myB Or .Left + .Width > myR Then yourSP.Delete

 ↑　ん？　左右上下の１つでもが、それぞれの基準値の外側ということで、いいと思うけど？

 ところで、基準の図形が基準の図形をはみだすことはないので以下でもいいね。

 Sub Sample()
    Dim mySP As Shape
    Dim yourSP As Shape
    Dim myL As Double
    Dim myT As Double
    Dim myB As Double
    Dim myR As Double

    Set mySP = ActiveSheet.Shapes("Rectangle 1")  '基準のシェープ名
    With mySP
        myL = .Left
        myT = .Top
        myB = .Top + .Height
        myR = .Left + .Width
    End With

    For Each yourSP In ActiveSheet.Shapes
        With yourSP
            If .Top < myT Or .Left < myL Or .Top + .Height > myB Or .Left + .Width > myR Then yourSP.Delete
        End With
    Next
 End Sub

 (ぶらっと)

 一つ気になったのですが、オートシェープの Top,Left,Width,Height は必ずしも
 図形の描画領域と一致しないですよね？

 矩形はほぼ問題ないと思いますけれど、円や三角で矩形領域は重なっているけれど、
 描画領域は重なっていないような場合は、問題にならないでしょうか。

 こう考えだすと、なかなか難しくて躊躇していました。
 (Mook)

そうか、条件の組み合わせが違うのかな（マナ）

 > 土俵の俵に足が掛かっていれば残す。

 >> 土俵の俵に足が掛かっていれば残す。

 あっ！！ここを読み飛ばしていた。
 でも、もしMookさんの指摘通りだとして（そうだろうけど）
 つまり、図の領域（基本手には円であろうが三角であろうが矩形の領域）だけど、見た目、図の外側というやつですか。
 なるほど。

 もし、そうだとすると、これは、かなりシビレルね。
 ものが三角形とか四角形とか楕円とか円ということならその図の線の方程式でなんたらかんたら計算すれば（それも結構面倒だけど）
 フリーフォームなんかはお手上げ？

 さらに、今気がついた。
 図形が回転していれば、矩形が重なっていれば重なりと見なす簡単な条件にしても、上記では
 正しくない結果になるねえ。
 せめてこれだけでも・・・と思ったけど、これまた面倒なのでパス。

 ということで

 >> 土俵の俵に足が掛かっていれば残す。

 回転を考えないで、しかも矩形ベースで重なりを判定するという限定要件にすれば
 ここはなんとかなるねぇ。
 Top あるいは Bottom が　基準のTopとBottomの間にあり、かつ Left あるいはRightが
 基準のLeftとRightの間にあれば残す、それ以外は消す。
 こういうコードになるね。

 (ぶらっと)

 とりあえず、最後に書いた、超限定要件だとして。（だから、実際のスレ主さんの要望は満たさないと思うけど）

 Sub Sample2()
    Dim mySP As Shape
    Dim yourSP As Shape
    Dim myL As Double
    Dim myT As Double
    Dim myB As Double
    Dim myR As Double
    Dim flag As Boolean

    Set mySP = ActiveSheet.Shapes("Rectangle 1")  '基準のシェープ名
    With mySP
        myL = .Left
        myT = .Top
        myB = .Top + .Height
        myR = .Left + .Width
    End With

    For Each yourSP In ActiveSheet.Shapes
        With yourSP
            flag = False
            If (.Top >= myT And .Top <= myB) Or (.Top + .Height >= myT And .Top + .Height <= myB) Then
                If (.Left >= myL And .Left <= myR) Or (.Left + .Width >= myL And .Left + .Width <= myR) Then flag = True
            End If
            If Not flag Then .Delete
        End With
    Next
 End Sub

 (ぶらっと)

マナさん、Mookさん、ぶらっとさん

皆さん、一晩のうちに多くの返信、本当にありがとうございます。

「あるオートシェープの上にたくさんの別のオートシェープを描いている」ということだよね？はい。そういうイメージで合っています。

皆さんからご指摘いただいたTop,Left,Width,Heightの変数を使って、土俵と力士を選別しようと思います。
やはり、土俵の場合、丸なので45度方向の描画領域(余白)の取り扱いですよね。
土俵は真円として、円の方程式で軌跡で判別しようと思うのですが、どのようにしたらよろしいのでしょうか？
引き続き教えて頂けませんか？

(まこと)

 とりあえず「あきらめたほうがいい」？？

 真ん中の「土俵」を円の方程式でどうこうというところも、結構大変だけど、それ以前に「力士」が問題。

 シェープは、皆さんからも指摘あるように、あくまで「矩形」の図形。（円であっても同様）
 いってみれば「四角い画用紙」がシェープ。三角やブロック矢印や楕円なんてのは、それそのものが図ではなく
 あくまで、画用紙の中に書かれた絵。絵の外側が、たまたま透明になっているだけで、これに対して、絵の外側なのか内側なのかを
 判定するのは、きわめて困難（というか無理？）

 たとえばマウスをあてた場所に図があるのか、図はなくセルがあるのかを判定することはできるけど
 それでも、そのマウスを置いた場所が、「描画領域(余白)」であっても、その図があるという判定になるし。

 超エキスパートさんなら、WindowAPIを駆使してなんとか判別はできるかもしれないけど。
 少なくとも私には無理。

 (ぶらっと)

「力士」が矩形限定であれば（マナ）

 「土俵」の中心から「力士」の頂点までの距離が半径より大きいかどうかで判定できるかな？

 でも三角形になるだけでもうどうしてよいか、わかりません。

 >「力士」が矩形限定であれば・・・・ 「土俵」の中心から「力士」の頂点までの距離が半径より大きいかどうかで判定できるかな？

 あぁ、マナさん、さすが。
 ということは、「力士」も「真円」なら、土俵の半径と力士の半径を足したものが、それぞれの中点を結んだ距離より大きければ、土俵に足が残っている・・・かな？

 (ぶらっと)

いやいや、ちょっと考えてみようと思ったら、矩形でも上の方法じゃ無理でした（マナ）

あれっ、やっぱりできるかな。ちょっと落ち着いて考えます（マナ）

冷静になって、考え直してみました。矩形は無理ですね。（マナ）

 真円は、ぶらっとさんの方法でよさそうです。

 マナさんのお墨付きがでたので、力士も真円という限定版で。

 Sub TestOval()
    Dim baseSP As Shape
    Dim sp As Shape
    Dim totR As Double
    Dim dist As Double

    Set baseSP = ActiveSheet.Shapes("Oval 1")

    For Each sp In ActiveSheet.Shapes
        If Not sp Is baseSP Then
            If TypeName(sp.DrawingObject) = "Oval" Then
                totR = baseSP.Width / 2 + sp.Width / 2
                dist = getDistance(baseSP, sp)
                If totR < dist Then sp.Delete
            End If
        End If
    Next

 End Sub

 Private Function getDistance(sp1 As Shape, sp2 As Shape) As Double
    Dim myX As Double
    Dim myY As Double

    myX = Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width / 2))
    myY = Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height / 2))

    getDistance = Sqr(myX ^ 2 + myY ^ 2)

 End Function

 (ぶらっと)

矩形の場合も、ぶらっとさんの方法をアレンジするとよいのかな（マナ）

 それぞれの中心の座標から、水平方向の距離と垂直方向の距離を求めればよいかも。
 で、円の半分（半径）と矩形の大きさの半分の和より、大きいかどうか。
 違うかな？

いつもながら、お仕事が早い。矩形対応もお願いします（マナ）

 すこしまだるっこしいけど、矩形の四隅の「いずれか」までの距離が半径以内なら、土俵に残っているというコードにしてもいいのでは？

 ということで、試作品。

 Sub TestRectangle()
    Dim baseSP As Shape
    Dim sp As Shape
    Dim dist As Double

    Set baseSP = ActiveSheet.Shapes("Oval 1")

    For Each sp In ActiveSheet.Shapes
        If Not sp Is baseSP Then
            If TypeName(sp.DrawingObject) = "Rectangle" Then
                dist = getDist2(baseSP, sp)
                If baseSP.Width / 2 < dist Then sp.Delete
            End If
        End If
    Next

 End Sub

 Private Function getDist2(sp1 As Shape, sp2 As Shape) As Double
    Dim dist As Double

    Dim myX As Double
    Dim myY As Double

    '左上隅
    myX = Abs((sp1.Left + sp1.Width / 2) - sp2.Left)
    myY = Abs((sp1.Top + sp1.Height / 2) - sp2.Top)
    getDist2 = Sqr(myX ^ 2 + myY ^ 2)
    '右上隅
    myX = Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width))
    myY = Abs((sp1.Top + sp1.Height / 2) - sp2.Top)
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist
    '左下隅
    myX = Abs((sp1.Left + sp1.Width / 2) - sp2.Left)
    myY = Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height))
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist
    '右下隅
    myX = Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width))
    myY = Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height))
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist

 End Function

 (ぶらっと)

 土俵が真円で、力士が真円、四角形のものを別々にアップしたけど、これらに加えて力士が
 通常の三角形、右三角形、菱形　等、あるいていど限定されているとすれば、それらもまとめて
 １つのプロシジャで対応することもできるね。

 かつ、この方式でやれば、力士の図が回転していても、回転座標を求めることができるので対応可能。

 追記）「通常の三角形、右三角形、菱形」 おおぼら（？）をふいたけど、これらは、やはり、この方法では
 　　　対応できないね。失礼！

 (ぶらっと)

ぶらっとさんありがとうございます。（マナ）

 矩形対応の修正版を作成中。
 久しぶりに、頭の体操です。

矩形の場合、４隅だけでは、やはり無理そうなので（マナ）

 さらに重なりがないか判定を加えました。

 Sub TestRectangle()
    Dim baseSP As Shape
    Dim sp As Shape
    Dim dist As Double
    Dim crossX As Boolean
    Dim crossY As Boolean

    Set baseSP = ActiveSheet.Shapes("Oval 1")
    For Each sp In ActiveSheet.Shapes
        If Not sp Is baseSP Then
            If TypeName(sp.DrawingObject) = "Rectangle" Then
                dist = getDist2(baseSP, sp)
                crossX = judgeCrossX(baseSP, sp)   '★
                crossY = judgeCrossY(baseSP, sp)   '★
                If baseSP.Width / 2 < dist Then
                    If crossX = False And crossY = False Then   '★
                        sp.Delete
                    End If
                End If
            End If
        End If
    Next
 End Sub
 Private Function getDist2(sp1 As Shape, sp2 As Shape) As Double
    Dim dist As Double
    Dim myX As Double
    Dim myY As Double
    '左上隅
    myX = Abs((sp1.Left + sp1.Width / 2) - sp2.Left)
    myY = Abs((sp1.Top + sp1.Height / 2) - sp2.Top)
    getDist2 = Sqr(myX ^ 2 + myY ^ 2)
    '右上隅
    myX = Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width))
    myY = Abs((sp1.Top + sp1.Height / 2) - sp2.Top)
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist
    '左下隅
    myX = Abs((sp1.Left + sp1.Width / 2) - sp2.Left)
    myY = Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height))
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist
    '右下隅
    myX = Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width))
    myY = Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height))
    dist = Sqr(myX ^ 2 + myY ^ 2)
    If dist < getDist2 Then getDist2 = dist
 End Function

 Private Function judgeCrossX(sp1 As Shape, sp2 As Shape) As Boolean

    If (sp1.Left + sp1.Width / 2 - sp2.Left) * (sp1.Left + sp1.Width / 2 - (sp2.Left + sp2.Width)) < 0 Then
        If Abs((sp1.Top + sp1.Height / 2) - (sp2.Top + sp2.Height / 2)) < sp1.Height / 2 + sp2.Height / 2 Then
           judgeCrossX = True
        End If
    End If

 End Function

 Private Function judgeCrossY(sp1 As Shape, sp2 As Shape) As Boolean

    If (sp1.Top + sp1.Height / 2 - sp2.Top) * (sp1.Top + sp1.Height / 2 - (sp2.Top + sp2.Height)) < 0 Then
        If Abs((sp1.Left + sp1.Width / 2) - (sp2.Left + sp2.Width / 2)) < sp1.Width / 2 + sp2.Width / 2 Then
           judgeCrossY = True
        End If
    End If

 End Function

何してるか非常にわかりにくいですね（マナ）

judgeCrossXは、
円の中心と矩形の中心の水平方向の距離＜半径＋矩形幅/2

judgeCrossYは、
円の中心と矩形の中心の垂直方向の距離＜半径＋矩形高さ/2

をそれぞれ判定しています。

 なるほどです。
 これを応用していろいろやれば三角形他も、頂点に加えて、各線から円の中心に引いた垂線の長さを判定すれば
 なんとかなりそうですねぇ・・・今日も暑いので、私は気力がないですが。

 (ぶらっと)

ぶらっとさん、マナさん

またまた、本当にありがとうございます。
うん十年前に習った、円の方程式と判別式を用いてゴリゴリ奮闘しましたが、力尽きました。

結局、皆さんからお知恵を頂いた、各4象限で矩形四隅の頂点と、土俵の半径の判別で対応しました。
ぶらっとさん、マナさん、ありがとうございました。

コメント返信：

[ 一覧(最新更新順) ]

[[20120915115344]] 『VBAで図形の重なり』（まこと） ページの最後に飛ぶ

[[20120915115344]]　『VBAで図形の重なり』（まこと）　ページの最後に飛ぶ