Powerpoint VBA 道や線路を描くマクロ

皆さんのブログは楽しく眺めさせてもらっているんですが，とにかく時間が無い毎日を送っているところで，まったく自分では書けていませんでした。

暇だけではありませんね，ネタもすぐにはポンと出てこない。

とりあえず，半端ない忙しさの毎日ですので，仕事を家でも職場でもやっている毎日。

嫌いならブラック極まりないですね。

好きなことなので，どこまでが趣味でどこまでが仕事か判別しにくいところ。

ストレスフリーではあります。（ΦωΦ）

本題に。。

数年間使われ続けていた地図を含む資料を作り直して印刷屋さんにお願いする，という仕事も同時並行で来まして，

すげーめんどくさいなぁと思いながらも，その地図を使い続けるのが気持ち的に許せない。

海岸線などはトレースしていけばある程度描いてくれるので，それでまぁできました。

学校での使用については問題ないと書かれていたので，国土地理院さんの地図を利用させていただいて，Illustratorである程度トレース。

さて，道路全部描くとうざいので，通学に使われている道だけを描かないといけないんですが，道って少なくとも二本線くらいでは描かないと，というところです。

電車の路線はもちょいめんどくさいですよね。。

そこで，それをなんとかするマクロを作ってみました。すごい単純ですが，私にはとてもいいものとなりました。（ΦωΦ）

時間が無いので雑ですみませんが，結果とコードを載せます。

　元絵です
　曲線でなぞって
　マクロで修正

こんなマクロです。

Option Explicit

Sub MakeRoad()
    Dim roadOutline As Shape
    Dim roadInline As Shape
    
    Set roadOutline = ActiveWindow.Selection.ShapeRange(1)
    Set roadInline = roadOutline.Duplicate(1)
    
    roadOutline.Line.Weight = 4.5
    roadOutline.Line.ForeColor.RGB = vbBlack
    roadInline.Line.Weight = 2.25
    roadInline.Line.ForeColor.RGB = vbWhite
    roadInline.Left = roadInline.Left - 12
    roadInline.Top = roadInline.Top - 12
    
    Dim ActiveSlide As Slide: Set ActiveSlide = ActiveWindow.View.Slide
    ActiveSlide.Shapes.Range(Array(SIndex(roadOutline), SIndex(roadInline))).Group
End Sub
Sub MakeRailroad()
    Dim roadOutline As Shape
    Dim roadInline As Shape
    
    Set roadOutline = ActiveWindow.Selection.ShapeRange(1)
    Set roadInline = roadOutline.Duplicate(1)
    
    roadOutline.Line.Weight = 4.5
    roadOutline.Line.ForeColor.RGB = vbBlack
    roadInline.Line.Weight = 2.25
    roadInline.Line.ForeColor.RGB = vbWhite
    roadInline.Line.DashStyle = msoLineLongDash
    roadInline.Left = roadInline.Left - 12
    roadInline.Top = roadInline.Top - 12
    
    Dim ActiveSlide As Slide: Set ActiveSlide = ActiveWindow.View.Slide
    ActiveSlide.Shapes.Range(Array(SIndex(roadOutline), SIndex(roadInline))).Group
End Sub

Sub Edit2ndItemNode()
    Dim targetShape As Shape: Set targetShape = ActiveWindow.Selection.ShapeRange(1).GroupItems(1)
    targetShape.Select
End Sub

Function SIndex(ByVal targetShape As PowerPoint.Shape) As Long
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(targetShape.Parent.SlideIndex)
    
    If targetShape.Child = msoTrue Then '完全に真似させてもらった。グループ内図形の場合は親を返す
        Let SIndex = SIndex(targetShape.ParentGroup)
        Exit Function
    End If
    
    Dim db As Object: Set db = CreateObject("Scripting.Dictionary")
    Dim s As Shape
    Dim i As Long: i = 1
    
    For Each s In TargetSlide.Shapes
        db(s.Id) = i
        i = i + 1
    Next
    
    Let SIndex = db.Item(targetShape.Id)
    
End Function

MakeRoadというのが，一本線を　道のような二重線にします。
MakeRailroadというのが，一本線を　路線のようにします。白の点線のっけてるだけです。

ちょこっと編集したいというときに，二本の線を重ねていますので，下の線を選ぶのが大変です。
その時のために，下の黒線(グループ内のインデックスでは１となります。)を選ぶマクロがEidt2ndItemNodeです。
選ぶとこまではできますが，編集状態にするやり方はわからないので，キーボードにあるメニュー出すキーを押して頂点の編集を選べば下の線が編集できます。
完全に自分用マクロです(´▽`) '`,、'`,、

こんなものが役に立つ人がいるのかわかりませんが，とりあえず目新しいことが書けるネタだったので書きました。

今年度安定して記事が書けるまでとりあえず仕事がんばらないとなぁ( ´ー｀)ﾌｩｰ．．．

Duplicate後の図形のずれって私が前扱ったときは15だったと思うんですが，今回数値を書き出させると12でした。

何に依存するのかなぁ。

もし，きちんと図形が重ならなくてだめやんとなった方は，

    roadInline.Left = roadInline.Left - 12
    roadInline.Top = roadInline.Top - 12

イミディエイトウィンドウでずれの数値を確認して，上記部分をいじってもらえば，どうにかなると思われます。