Results of 1 - 1 of about 1039 for オートシェイプ (0.001 sec.)
- [[20120915115344]]
- #score: 6703
- @digest: 679abb63e75c5783080a056d53ae559c
- @id: 60200
- @mdate: 2012-09-17T04:40:44Z
- @size: 13679
- @type: text/plain
- #keywords: getdist2 (130826), basesp (94485), 土俵 (86546), 力士 (74779), yoursp (71599), 隅my (61991), dist (49336), sp1 (39152), 矩形 (35741), judgecrossy (29523), judgecrossx (29523), 真円 (27830), 半径 (27691), 俵の (27628), 画領 (26192), myx (25186), myy (21735), sp2 (20134), ェー (12367), mysp (11533), rectangle (10886), height (10491), width (9794), shape (9746), double (9537), 中心 (9471), シェ (9033), 方程 (8754), 頂点 (8647), 三角 (8563), 程式 (8528), 下隅 (8396)
- 『VBAで図形の重なり』（まこと）
お世話になります。 マクロを使ってオートシェープを複数描いています。 オートシェープ1の上に、オートシェイプ2をたくさん描いております。 オートシェイプ1上に描かれたオートシェイプ2は残し、 オートシェイプ1からはみ出した、オートシェイプ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 ---- ↑ ん? 左右上下の1つでもが、それぞれの基準値の外側ということで、いいと思うけど? ところで、基準の図形が基準の図形をはみだすことはないので以下でもいいね。 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 (ぶらっと) ---- 土俵が真円で、力士が真円、四角形のものを別々にアップしたけど、これらに加えて力士が 通常の三角形、右三角形、菱形 等、あるいていど限定されているとすれば、それらもまとめて 1つのプロシジャで対応することもできるね。 かつ、この方式でやれば、力士の図が回転していても、回転座標を求めることができるので対応可能。 追記）「通常の三角形、右三角形、菱形」 おおぼら（?）をふいたけど、これらは、やはり、この方法では 対応できないね。失礼! (ぶらっと) ---- ぶらっとさんありがとうございます。（マナ） 矩形対応の修正版を作成中。 久しぶりに、頭の体操です。 ---- 矩形の場合、4隅だけでは、やはり無理そうなので（マナ） さらに重なりがないか判定を加えました。 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象限で矩形四隅の頂点と、土俵の半径の判別で対応しました。 ぶらっとさん、マナさん、ありがとうございました。... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201209/20120915115344.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97050 documents and 608253 words.
訪問者：