Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

68829 / 76733

←次へ　｜　前へ→


	【12430】Re:ひし形(訂正)

ichinose - 04/4/3(土) 0:46 -


	引用なし

	パスワード

仕様が違っているので訂正しても・・・
と思いましたが、一応・・・。

>サンプルを作ってみました。
>'==============================================================
>Const stx = 135
>Const sty = 275
>Const edx = 395
>Const edy = 175
>'==============================================================
>Sub Mk_Parallelogram()
>　 Dim p_x(1 To 4) As Double　'平行四辺形の4角のｘ
>　 Dim p_y(1 To 4) As Double　'平行四辺形の4角のY
>　 Dim para As Shape '平行四辺形のShapeオブジェクト
>　 Dim cx As Double '対角線の交わるx
>　 Dim cy As Double '対角線が交わるY
>　 Dim rl As Double '指定した直線の長さの半分（対角線の長さ）/2
>　 Dim rs As Double 'もうひとつの対角線の長さ/2
>　 Dim pai As Double　'円周率
>　 pai = WorksheetFunction.pi()
>　 p_x(2) = edx: p_y(2) = edy
>　 p_x(4) = stx: p_y(4) = sty
>　
>　 rl = Sqr((edx - stx) ^ 2 + (edy - sty) ^ 2) / 2
>　 rs = rl * 2
>　 cx = Abs(edx + stx) / 2
>　 cy = Abs(edy + sty) / 2
>　 rs = rl / 2
>　 p_y(1) = cy
>　 p_y(3) = cy
>　 p_x(1) = cx - rs
>　 p_x(3) = cx + rs
>　 With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, p_x(1), p_y(1))
>　　　For idx = 2 To 4
>　　　　 .AddNodes msoSegmentLine, msoEditingAuto, p_x(idx), p_y(idx)
>　　　　 Next idx
>　　　.AddNodes msoSegmentLine, msoEditingAuto, p_x(1), p_y(1)
>　　　Set para = .ConvertToShape
>　　　End With
　　doevents '←これ入れといて
>　 MsgBox "平行四辺形が作れた？"
>　 '真横の対角線が縦になるまで移動
>　 With para
>　　　 For rr = 0 To pai / 2 Step 0.001
>　　　　 .Nodes.SetPosition 3, cx + rs * Cos(rr), cy + rs * Sin(rr)
>　　　　 .Nodes.SetPosition 1, cx + rs * Cos(rr + pai), cy + rs * Sin(rr + pai)
>　　　　 Next
>　　　 End With
>End Sub
>
>対角線を意識して考えました。
>Constの値を（stx<edx かつsty>edy)の条件を満たす範囲の
>値に設定して実行してみて下さい。
>・
>・
>・
>と、ここまで書いてnyan さんの意図していることと違っている事に
>気が付きました・・・。
>
>でも、参考程度にはなりますか？
>要は、平行四辺形を作成した後、円の奇跡で４角の内の２点を移動させると言う事です。
>例では、対角を移動していますが・・・。

3 hits

▼

【12403】ひし形 nyan 04/4/2(金) 15:24