なのでもっと作業を簡単にできないかと思い、良く使う地図変換機能をマクロでエクセルにアドインするソフト？を作ってみました。確認は「Excel 2016」でしか動作確認はしていませんが、特別なマクロは使ってないつもりなので少し前のバーションでも動くと思います。
マクロをエクセルへ挿入
先ずは、マクロコードをエクセルに挿入する必要があります。やり方は例えば、エクセルを立ち上げてメニューから
「開発」→「Visual Basic」→「挿入」→「標準モジュール」
で表示された画面にマクロコードをコピーします。次に、マクロ「Sub A_Map_Installer」を動させてソフトをエクセルにインストールします。動作の方法は色々あり、マクロコードをコピーした状態で直接実行してもいいし、エクセルのメニューボタンから「開発」→「マクロ」で選択でもOKです。
A_Map_Installerが動作するとアクティブなエクセルシートにソフトが自動的にインストールされます。
上記左画面のようになっていればインストール作業は終わりです。
地図ソフトの使い方
基本はエクセルの図形で色々書くのですが、このソフトで単純な線が、単純な「線」が鉄道や道路的な飾り付けに簡単に変換されます。もちろんエクセル機能で変更してもいいのですが、ワンクリックで動作させるのがこのソフトです。
線以外にも、簡単な建物も準備しました。基本はエクセルの図形で作ればいいのですが、ちょっとだけ私がよく使う建物を作っておきました。最後に描いたすべてのデータを一つにまとめて一枚の地図としてコピーできるようにしました。
「地図合成」すると丁度、選択状態になっているのでマウスの右クリックでそのまま、コピーして、他に貼り付けることができます。もし地図のサイズが大きければこの状態で縮小して下さい。
使い方は簡単で左側のボタンを押すだけで選択された線は鉄道などに変ります。建物などはボタンの上の部分に表示されるのでそれを移動して使用します。
地図ソフト用マクロコード
エクセルファイルをそのまま置ければいのですがブログなので自分でインストールするしかないようなので以下にマクロコードを載せておきます。エクセルのマクロは基本Visual Basicなので適当に変更して楽しんで下さい。マクロの詳細説明は後程．．．
取りあえず、使えそうだと思ったらインストールして試して下さい。
Sub text1()
'
'文字入力 Macro
'
'
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
Sub Building3()
'
' 目的位置 Macro
'
'
Dim tshape As Shape
With ActiveSheet.Range("DA3:Dd5")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeCan, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
With ActiveSheet.Range("DB1:Dc2")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeDownArrow, _
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(230, 0, 0)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 10, 10)
.Transparency = 0
.Weight = 1
End With
Selection.ShapeRange.Width = Selection.ShapeRange.Width * 0.75
Selection.Cut
Range("B2").Select
ActiveSheet.Paste
End Sub
Sub Building2()
'
' 横長ビル Macro
'
'
Dim tshape As Shape
'建物作成
With ActiveSheet.Range("DA1:DL4")
Set tshape = ActiveSheet.Shapes.AddShape(Type:=msoShapeCube, _
Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
End With
With ActiveSheet.Range("DC3:DH4")
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(180, 180, 180)
.Transparency = 0
.Solid
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(20, 20, 20)
.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
Sub Building1()
'
' 縦長ビル Macro
'
'
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
Sub Railway()
'
' 鉄道 Macro
'
'
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
Sub LINE1()
'
' 幅広道路LINE1 Macro
'
On Error GoTo myError
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(150, 150, 150)
.Transparency = 0
.Weight = 14
.DashStyle = msoLineSolid
End With
Exit Sub
myError:
MsgBox "ラインを選択してください"
End Sub
Sub LINE2()
'
' 細め道路 Macro
'
On Error GoTo myError
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(150, 150, 150)
.Transparency = 0
.Weight = 8
.DashStyle = msoLineSolid
End With
Exit Sub
myError:
MsgBox "ラインを選択してください"
End Sub
Sub LINE_dot()
'
' 点線 Macro
'
On Error GoTo myError
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(10, 10, 10)
.Transparency = 0
.Weight = 2.5
.DashStyle = msoLineSysDot
End With
Exit Sub
myError:
MsgBox "ラインを選択してください"
End Sub
Sub Group_part()
'
' 部品合成 Macro
'
'
Dim cRng As Range
Dim Sh As Shape
Dim ShCnt As Integer
Set cRng = Range("DA1:DZ20")
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
Sub Group_Pic()
'
' 地図合成 Macro
'
'
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
Sub A_Map_Installer()
'
' 作画マクロインストール Macro
'
'
Columns("A").Select
Selection.ColumnWidth = 5
Columns("D:CZ").Select
Selection.ColumnWidth = 1
Columns("DA:DZ").Select
Selection.ColumnWidth = 0.5
Rows("1:100").Select
Selection.RowHeight = 10
Range("A1").Select
'作画エリア指定
Range("D2:BZ42").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'--ボタンを作成--
For i = 0 To 9
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 = "幅広道路"
ElseIf i = 2 Then
Selection.Text = "細い道路"
ElseIf i = 3 Then
Selection.Text = "地下鉄(点線)"
ElseIf i = 4 Then
Selection.Text = "鉄道"
ElseIf i = 5 Then
Selection.Text = "縦長ビル"
ElseIf i = 6 Then
Selection.Text = "横長ビル"
ElseIf i = 7 Then
Selection.Text = "目的地"
ElseIf i = 8 Then
Selection.Text = "--------"
Else
Selection.Text = "地図合成"
End If
'--ボタンにマクロを登録--
If i = 0 Then
Selection.OnAction = "text1"
ElseIf i = 1 Then
Selection.OnAction = "LINE1"
ElseIf i = 2 Then
Selection.OnAction = "LINE2"
ElseIf i = 3 Then
Selection.OnAction = "LINE_dot"
ElseIf i = 4 Then
Selection.OnAction = "Railway"
ElseIf i = 5 Then
Selection.OnAction = "Building1"
ElseIf i = 6 Then
Selection.OnAction = "Building2"
ElseIf i = 7 Then
Selection.OnAction = "Building3"
ElseIf i = 8 Then
Selection.OnAction = ""
Else
Selection.OnAction = "Group_Pic"
End If
Next i
Range("a1").Select
End Sub
マクロは基本、ネットで検索したり「マクロ記録」で大まかな動作を記録してそのコードから余分なところを省いたりして作っているので余りスマートとは言えませんが、悪しからず。
学研パブリッシング 学研マーケティング 2015-03-31
マクロを使ったソフトを作ってみるといろいろ、新しいマクロの使い方を発見します。たまには頭の体操になるので楽しいかも(笑)
なぜ、こんなソフトを作ってるのかと言うと、以前は『グーグルマップを簡単につかうには「API」でなくて「iframe」』で書いたように、著作権の関係でオンライン系マップを埋め込んで使ってブログ等に乗せていましたが、情報が多過ぎてブログで使うと意外と見た目がゴチャゴチャした感じになってしまいました。
シンプル画像として使うために取り出して変更すると著作権に引っかかりそうだし、地図はブログやSNSでは取り扱い注意な案件ですね！！
