| |
こんばんは
いつも掲示板で勉強させてもらっています。
質問ですが、Excel2003でオートセイプの直線で三角形を作って展開図作成マクロを作りましたが、位置あわせのため図形を回転したい時があります。
困ったことに1度回転すると作業が続けられなくなります。
原因は回転すると三角形がバラけてしまうためのようです。
そこで下記のコードで確かめました。
１「準備」で三角形を2つ作ります。
２「右回転」または「左回転」を実行してメッセージでズレを確認します。
なぜ回転するとずれてしまうのでしょうか？
Sub 準備()
'三角形を2つ作る
ActiveSheet.Shapes.AddLine(100, 100, 100, 50).Select
ActiveSheet.Shapes.AddLine(100, 50, 150, 30).Select
'分かりやすいように3本目から色と名前を付ける
With ActiveSheet.Shapes.AddLine(100, 100, 150, 30)
.Name = "aLine"
.Line.ForeColor.RGB = RGB(0, 255, 0)
End With
With ActiveSheet.Shapes.AddLine(150, 30, 180, 130)
.Name = "bLine"
.Line.ForeColor.RGB = RGB(0, 0, 255)
End With
With ActiveSheet.Shapes.AddLine(100, 100, 180, 130)
.Name = "cLine"
.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
Application.Wait (Now + TimeValue("0:00:1"))
'ズレを確認
MsgBox ズレ
End Sub
Sub 右回転()
'グループ化して名前を「グループ1」とする
ActiveSheet.Shapes.SelectAll
Selection.Group.Name = "Group1"
'15度回転
Shapes("Group1").Rotation = 15
'グループ解除
Shapes("Group1").Ungroup
Application.Wait (Now + TimeValue("0:00:1"))
'ズレを確認
MsgBox ズレ
End Sub
Sub 左回転()
ActiveSheet.Shapes.SelectAll
Selection.Group.Name = "Group1"
Shapes("Group1").Rotation = -15
Shapes("Group1").Ungroup
Application.Wait (Now + TimeValue("0:00:1"))
MsgBox ズレ
End Sub
Function ズレ()
With ActiveSheet
With .Shapes("cLine")
cTop = .Top
cLeft = .Left
End With
With .Shapes("aLine")
aBottom = .Top + .Height
aLeft = .Left
End With
End With
'取り敢えず赤い線と緑の線の接点を調べる
If cLeft = aLeft And cLeft = aBottom Then
ズレ = "ズレなし"
Else
ズレ = "ずれている!" & "aBottom" & aBottom & "<>" & "cTop" & cTop
End If
End Function
ズレていると、前に作った三角形の３辺がどのような位置関係にあるかを調べ、次の三角形の頂点を反対方向に作るということが出ません。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
