Excel VBA質問箱 IV

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

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


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

68831 / 76734

←次へ　｜　前へ→


	【12429】Re:ひし形

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


	引用なし

	パスワード

▼nyan さん、皆さん、こんばんは。
サンプルを作ってみました。
'==============================================================
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
　 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 さんの意図していることと違っている事に
気が付きました・・・。

でも、参考程度にはなりますか？
要は、平行四辺形を作成した後、円の奇跡で４角の内の２点を移動させると言う事です。
例では、対角を移動していますが・・・。

0 hits

▼

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