地図ソフトをマクロで作ったときのマクロ動作の説明です。意外と便利な機能もあるので忘れないようにまとめてみました。マクロは「Visual Basic」系ですが、将来的にはエクセルにも「Python」が対応するのか興味津々です。
文字を自由に入力する
最初の1行で四角形を作成。後で、大きさは無視するので適当な数値です。
TextFrame2で基本的なフォントを設定しています。
TextFrameで文字が図形からはみ出してもそのまま表示されるようにしています。
最後の3行は「塗りつぶしなし」「枠なし」「文字の初期データ」です。
Sub text1()
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 46, 25, 70, 26). _
Select
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
With Selection.ShapeRange.TextFrame2
.TextRange.Font.NameComplexScript = "Meiryo UI"
.TextRange.Font.NameFarEast = "Meiryo UI"
.TextRange.Font.Name = "Meiryo UI"
.TextRange.Font.Size = 10
.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.WordWrap = msoFalse
End With
With Selection.ShapeRange.TextFrame
.HorizontalOverflow = xlOartHorizontalOverflowOverflow
.VerticalOverflow = xlOartHorizontalOverflowOverflow
End With
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Line.Visible = msoFals
Selection.Text = "文字入力"
End Sub
シングル線から鉄道路線を作成する
選択された1本の線から鉄道は2本使って作ります。最初に二重線を作り、コピーした新しい線は点線し重ねて鉄道路線にします。コピーしてそのまま貼り付けると必ず、ずれるようなのでコピーしてできた線は位置合わせ「-12」を行ってます。
また、ここの処理では選択された線が必要なので、選択されていないときはエラー処理が必要になるため、以下の構文で処理をしています。
On Error GoTo myError
～～～～～～
Exit Sub
myError:
～～～～～～
Styleと書かれているプロパティでいろいろと線の種類などは変更できます。
Sub Railway()
On Error GoTo myError
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
.Weight = 8
.DashStyle = msoLineSolid
End With
Selection.ShapeRange.Line.Style = msoLineThinThin
'
Selection.Copy
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -12
Selection.ShapeRange.IncrementTop -12
'
Selection.ShapeRange.Line.Style = msoLineSingle
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 8
.DashStyle = msoLineDash
End With
Exit Sub
myError:
MsgBox "ラインを選択してください"
End Sub
複数図形使って建物を作成する
建物はセルの「形」に合わせて作るので最初にセルの形を高さと幅で、整えておいてください(例えば正方形)。この例ではDA～DZまでを高さに合わせて幅を生保受けになるように調整しています。この例では最初、立体的な縦長ビルを書いて、次に縦に2個窓ができるビルを作っています。
次に「Call Group」と言うマクロをこのマクロから呼び出しています。マクロは関数のように呼び出せます。このマクロは今回作画した3個の図形をグループ化します。
次に「塗りつぶし」「線」のプロパティ、今回は色だけ変更しています。その後、サイズを0.75倍に縮小してから、「切り取り」「貼り付け」で他の場所に移動してます。
Sub Building1()
Dim tshape As Shape
'建物作成
With ActiveSheet.Range("DA1:DF5")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeCube, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
With ActiveSheet.Range("DB3:DC3")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
With ActiveSheet.Range("DB4:DC4")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
Set tshape = Nothing
Call Group_part
'色の変更
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(150, 150, 150)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(10, 10, 10)
.Transparency = 0
.Weight = 1
End With
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = Selection.ShapeRange.Height * 0.75
Selection.Cut
Range("B2").Select
ActiveSheet.Paste
End Sub
複数図形をグループ化する
ネットで調べてみたら、同じコードが何箇所かにあったので動くことを確認して作業エリアだけ変更して使っています。図形を1個に合成するコードです。
Sub Group()
Dim cRng As Range
Dim Sh As Shape
Dim ShCnt As Integer
Set cRng = Range("D2:BZ42")
For Each Sh In ActiveSheet.Shapes
If Not Intersect(Range(Sh.TopLeftCell, Sh.BottomRightCell), cRng) Is Nothing Then
ShCnt = ShCnt + 1
If ShCnt = 1 Then Sh.Select Else Sh.Select Replace:=False
End If
Next Sh
If ShCnt > 1 Then Selection.Group.Select
End Sub
図形にマクロを自動で複数登録する
エクセルのセル上にある図形にマクロを自動的に貼り付ける方法です。四角いボタンにマクロを4個登録します。最初に図形と図形に書く文字のプロパティを設定し、その後、ボタン毎に文字を登録、続いてマクロ名を登録します。Sub A_Map_Installer()
'--ボタンを作成--
For i = 0 To 2
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 34, 32 * i + 71.25, 91.5, 28.5). _
Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 255)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = _
msoAlignCenter
With Selection.ShapeRange.TextFrame2.TextRange.Font
.NameComplexScript = "Meiryo UI"
.NameFarEast = "Meiryo UI"
.Name = "Meiryo UI"
End With
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 12
'--ボタン名を設定--
If i = 0 Then
Selection.Text = "テキスト"
ElseIf i =1 Then
Selection.Text = "幅広道路"
Else
Selection.Text = "細い道路"
End If
'--ボタンにマクロを登録--
If i = 0 Then
Selection.OnAction = "text1"
ElseIf i = 1 Then
Selection.OnAction = "LINE1"
Else
Selection.OnAction = "LINE2"
End If
Next i
Range("a1").Select
End Sub
今回もいろいろなマクロを覚えました。本当の目的は地図ソフト作成だったんだけどなんか、マクロを楽しく使うのに気持ちが移ってしまった感じです(笑)
