| |
仕様が違っているので訂正しても・・・
と思いましたが、一応・・・。
>サンプルを作ってみました。
>'==============================================================
>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 さんの意図していることと違っている事に
>気が付きました・・・。
>
>でも、参考程度にはなりますか？
>要は、平行四辺形を作成した後、円の奇跡で４角の内の２点を移動させると言う事です。
>例では、対角を移動していますが・・・。
|
|
ichinose
- 04/4/3(土) 0:46 -
