| |
こんばんは
ちょっと仕様を変更したので再投稿です。
>フリーフォームの頂点を方向キー(↑,↓,→,←)で移動したいんですが、どうすればよろしいでしょうか?
新規ブックの標準モジュールに
'==============================================================
Option Explicit
Dim shp As Shape
Dim nidx As Long
Dim ok As Long
'====================================================================
Sub main()
On Error Resume Next
Dim g1 As Long
Set shp = Selection.ShapeRange(1)
g1 = shp.Nodes.Count
If Err.Number = 0 Then
ok = 0
For g1 = 1 To shp.Nodes.Count
With ActiveSheet.Ovals.Add(shp.Nodes(g1).Points(1, 1) - 3, _
shp.Nodes(g1).Points(1, 2) - 3, 6, 6)
.Name = "ovl" & g1
.OnAction = "search_node"
End With
Next
Do Until ok = 1
DoEvents
Loop
For g1 = 1 To shp.Nodes.Count
ActiveSheet.Shapes("ovl" & g1).Delete
Next
End If
End Sub
'====================================================================
Sub search_node()
nidx = Val(Replace(Application.Caller, "ovl", ""))
ok = 1
Application.OnKey "{RIGHT}", "m_right"
Application.OnKey "{LEFT}", "m_left"
Application.OnKey "{UP}", "m_up"
Application.OnKey "{DOWN}", "m_down"
Application.OnKey "{ENTER}", "m_Enter"
Application.OnKey "~", "m_enter"
End Sub
'====================================================================
Sub m_enter()
Application.OnKey "{RIGHT}"
Application.OnKey "{LEFT}"
Application.OnKey "{UP}"
Application.OnKey "{DOWN}"
Application.OnKey "{ENTER}"
Application.OnKey "~"
Set shp = Nothing
ok = 0
nidx = 0
End Sub
'====================================================================
Sub m_right()
Dim x As Double
Dim y As Double
x = shp.Nodes(nidx).Points(1, 1)
y = shp.Nodes(nidx).Points(1, 2)
shp.Nodes.SetPosition nidx, x + 4.5, y
End Sub
'====================================================================
Sub m_left()
Dim x As Double
Dim y As Double
x = shp.Nodes(nidx).Points(1, 1)
y = shp.Nodes(nidx).Points(1, 2)
shp.Nodes.SetPosition nidx, x - 4.5, y
End Sub
'====================================================================
Sub m_up()
Dim x As Double
Dim y As Double
x = shp.Nodes(nidx).Points(1, 1)
y = shp.Nodes(nidx).Points(1, 2)
shp.Nodes.SetPosition nidx, x, y - 4.5
End Sub
'====================================================================
Sub m_down()
Dim x As Double
Dim y As Double
x = shp.Nodes(nidx).Points(1, 1)
y = shp.Nodes(nidx).Points(1, 2)
shp.Nodes.SetPosition nidx, x, y + 4.5
End Sub
別の標準モジュールに
サンプル図形作成用のプロシジャー
'=======================================================================
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
para.Select
End Sub
まず、プロシジャーMk_Parallelogramを実行して、サンプルのフリーフォームを
作成します。ここでは、平行四辺形をサンプルとしています。
次にこの図形を選択した状態でmainを実行してください。
図形の頂点に図形の円が作成されます。
移動したい頂点にある円をクリックしてください。
円が消えてクリックした頂点が方向キーで移動可能になります。
移動してみてください。
移動が終了したら、Enterキーを押してください。
頂点移動処理が終了します。
尚、細かいエラー処理はしていません。
|
|
ichinose
- 07/4/21(土) 18:23 -
