| |
こんばんは。
再挑戦です。
>要は、平行四辺形を作成した後、円の奇跡で４角の内の２点を移動させると言う事です。
軌跡でした（実は、これ訂正するためにコード作ったりして・・）。
以下のコードで
>右斜め45度の線と真横の線
の平行四辺形が作成できると思います。
'=================================================================
Const stx = 150
Const sty = 100
Const edx = 300
Const edy = 220
'=================================================================
Sub Mk_Parallelogram2()
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 rs As Double
Dim pai As Double '円周率
If stx < edx And sty < edy Then
If stx - (edy - sty) >= 0 Then
Else
MsgBox "回転できませんから、処理中止"
Exit Sub
End If
End If
pai = WorksheetFunction.pi()
p_x(1) = stx: p_y(1) = sty
p_x(2) = edx: p_y(2) = sty
p_x(3) = edx: p_y(3) = edy
p_x(4) = stx: p_y(4) = edy
rs = edy - sty
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
rr = -pai / 4
.Nodes.SetPosition 1, p_x(4) + rs * Cos(rr), p_y(4) + rs * Sin(rr)
.Nodes.SetPosition 2, p_x(3) + rs * Cos(rr), p_y(3) + rs * Sin(rr)
p_x(1) = p_x(4) + rs * Cos(rr): p_y(1) = p_y(4) + rs * Sin(rr)
p_x(2) = p_x(3) + rs * Cos(rr): p_y(2) = p_y(3) + rs * Sin(rr)
DoEvents
MsgBox "平行四辺形が作れた？ ここから、右回り１回転します"
For rr = -pai / 4 To -pai / 4 + pai * 2 Step 0.001
.Nodes.SetPosition 1, p_x(4) + rs * Cos(rr), p_y(4) + rs * Sin(rr)
.Nodes.SetPosition 2, p_x(3) + rs * Cos(rr), p_y(3) + rs * Sin(rr)
Next
MsgBox "今度は、軸を変えて右回り１回転します"
For rr = pai * 3 / 4 To pai * 3 / 4 + pai * 2 Step 0.001
.Nodes.SetPosition 3, p_x(2) + rs * Cos(rr), p_y(2) + rs * Sin(rr)
.Nodes.SetPosition 4, p_x(1) + rs * Cos(rr), p_y(1) + rs * Sin(rr)
Next
End With
End Sub
Constの値を「stx<edx 且つ sty<edy」の条件下で設定してみて下さい。
前回と同じ様に2角を回転させましたが、
>右斜め45度の線と真横の線を上下に変えれたらと考えています。
の意味が他の意味合いだったら又考えます（平行移動だったらIncrementTopや
IncrementLeftでもいいかも・・）。
確認してみて下さい。
|
|
