|
▼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角のx
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 さんの意図していることと違っている事に
気が付きました・・・。
でも、参考程度にはなりますか?
要は、平行四辺形を作成した後、円の奇跡で4角の内の2点を移動させると言う事です。
例では、対角を移動していますが・・・。
|
|