【メモ】VBA勉強・フロー図作成補助ツール

仕事上、業務フロー等を作成させられる機会が結構ある。
一方で、定型のフォーマットが有る訳でもなく、その都度気ままに描いていた。

これが結構困ったことに（人に指摘されて気づくという恥ずかしいものであったが）、
その時々で、レイアウトや図のサイズ感が異なっているらしく、見栄えが悪い。

ちょうどVBAを自分でやってみようと思っていたタイミングと重なったため、
作成補助ツールを作ってみようと思う。

只いまいち分からないのが、これをどのブックでも使えたらいいのだが…。
アドインか？という術が有るらしいので、少し調べて見ようと思う

参考リンク
https://www.atmarkit.co.jp/ait/articles/2009/28/news018.html
https://tech-paclab.com/macro-quickaccsess/


①標準モジュール１





'■■■■■■■■■■■■■■■■■■■■■■■■■
'１．単純な図形追加
'■■■■■■■■■■■■■■■■■■■■■■■■■

Sub 開始()

Dim shape As shape

 Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRoundedRectangle, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)
 
 With shape
  .Name = "図形"
  .Fill.ForeColor.RGB = RGB(255, 255, 255)
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .TextFrame.Characters.Text = ""
  .TextFrame.HorizontalAlignment = xlHAlignCenter
  .TextFrame.VerticalAlignment = xlVAlignCenter
  .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  .Select

 End With

End Sub


Sub 処理()

Dim shape As shape

 Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)
 
 With shape
  .Name = "図形"
  .Fill.ForeColor.RGB = RGB(255, 255, 255)
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .TextFrame.Characters.Text = ""
  .TextFrame.HorizontalAlignment = xlHAlignCenter
  .TextFrame.VerticalAlignment = xlVAlignCenter
  .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  .Select
 End With

End Sub


Sub ひし形()

Dim shape As shape

 Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeDiamond, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)
 
 With shape
  .Name = "図形"
  .Fill.ForeColor.RGB = RGB(255, 255, 255)
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .TextFrame.Characters.Text = ""
  .TextFrame.HorizontalAlignment = xlHAlignCenter
  .TextFrame.VerticalAlignment = xlVAlignCenter
  .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  .Select
 End With
 
End Sub


Sub データ()

Dim shape As shape

 Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartMagneticDisk, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)
 
 With shape
  .Name = "図形"
  .Fill.ForeColor.RGB = RGB(255, 255, 255)
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .TextFrame.Characters.Text = ""
  .TextFrame.HorizontalAlignment = xlHAlignCenter
  .TextFrame.VerticalAlignment = xlVAlignCenter
  .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  .Select
 End With

End Sub


Sub 書類()

Dim shape As shape

 Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartDocument, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)
 
 With shape
  .Name = "図形"
  .Fill.ForeColor.RGB = RGB(255, 255, 255)
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .TextFrame.Characters.Text = ""
  .TextFrame.HorizontalAlignment = xlHAlignCenter
  .TextFrame.VerticalAlignment = xlVAlignCenter
  .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  .Select
 End With
  
End Sub


Sub 矢印のみ追加()

Dim R As Range
Dim shapeCon As shape

Set R = Selection

 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, R.Left, R.Top + R.Height / 2, R.Left + R.Width, R.Top + R.Height / 2)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5

 End With

End Sub


Sub かぎ線のみ追加()

Dim R As Range
Dim shapeCon As shape

Set R = Selection

 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorElbow, R.Left, R.Top + R.Height / 2, R.Left + R.Width, R.Top + R.Height / 2)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
 
 End With

End Sub



'■■■■■■■■■■■■■■■■■■■■■■■■■
'２．選択した図形から特定の位置に新たに図形追加
'■■■■■■■■■■■■■■■■■■■■■■■■■


Sub 右に処理追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl '後続でエラーとなった場合はErrHandlの処理をする

 Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=shape1.Left + 100, _
              Top:=shape1.Top, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
  With shapeCon
   .Name = "線"
   .Line.EndArrowheadStyle = msoArrowheadOpen
   .Line.ForeColor.RGB = RGB(127, 127, 127)
   .Line.Weight = 0.5
   .ConnectorFormat.BeginConnect shape1, 1
   .ConnectorFormat.EndConnect shape2, 1
   .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
  End With
  
  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select

Exit Sub

ErrHandl:
Err.Clear
Call 処理

End Sub



Sub 左に処理追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=shape1.Left - 100, _
              Top:=shape1.Top, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select

Exit Sub

ErrHandl:
Err.Clear
Call 処理
  
End Sub


Sub 下に処理追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=shape1.Left, _
 Top:=shape1.Top + 80, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select


Exit Sub

ErrHandl:
Err.Clear
Call 処理

End Sub



Sub 上に処理追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=shape1.Left, _
              Top:=shape1.Top - 80, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select

Exit Sub
ErrHandl:
Err.Clear
Call 処理
  
End Sub



Sub 右にひし形追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeDiamond, Left:=shape1.Left + 100, _
              Top:=shape1.Top, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select

Exit Sub
ErrHandl:
Err.Clear
Call ひし形
  
End Sub



Sub 右にデータ追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartMagneticDisk, Left:=shape1.Left + 100, _
              Top:=shape1.Top, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select


Exit Sub

ErrHandl:
Err.Clear
Call データ
  
End Sub



Sub 右に書類追加()

Dim shape1 As shape
Dim shape2 As shape
Dim shp As shape
Dim shapeCon As shape

On Error GoTo ErrHandl

Set shape1 = Selection.ShapeRange(1)

 Set shape2 = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartDocument, Left:=shape1.Left + 100, _
              Top:=shape1.Top, Width:=shape1.Width, Height:=shape1.Height)
 
 Set shapeCon = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 1, 1, 1, 1)
 With shapeCon
  .Name = "線"
  .Line.EndArrowheadStyle = msoArrowheadOpen
  .Line.ForeColor.RGB = RGB(127, 127, 127)
  .Line.Weight = 0.5
  .ConnectorFormat.BeginConnect shape1, 1
  .ConnectorFormat.EndConnect shape2, 1
  .RerouteConnections
  
  '線の色を変えたい場合はこのあたりに記入？
  
 End With

  shape2.Name = "図形"
  shape2.Fill.ForeColor.RGB = RGB(255, 255, 255)
  shape2.Line.ForeColor.RGB = RGB(127, 127, 127)
  shape2.TextFrame.Characters.Text = ""
  shape2.TextFrame.HorizontalAlignment = xlHAlignCenter
  shape2.TextFrame.VerticalAlignment = xlVAlignCenter
  shape2.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(127, 127, 127)
  shape2.Select


Exit Sub
ErrHandl:
Err.Clear
Call 書類
  
End Sub



'■■■■■■■■■■■■■■■■■■■■■■■■■
'３．線の変換（直線⇔かぎ線）
'■■■■■■■■■■■■■■■■■■■■■■■■■


Sub 選択した線を一括し直線へ変更()

    Dim shp As shape
    Dim i
    
    If VarType(Selection) <> vbObject Then        'オートシェイプ未選択時は処理を行わない
    Exit Sub
    End If
    
    For i = 1 To Selection.ShapeRange.Count
    Set shp = Selection.ShapeRange.Item(i)
      With shp
           .ConnectorFormat.Type = msoConnectorStraight
      End With
    Next i

End Sub


Sub 選択した線を一括しかぎ線へ変更()

    Dim shp As shape
    Dim i
    
    If VarType(Selection) <> vbObject Then        'オートシェイプ未選択時は処理を行わない
    Exit Sub
    End If
    
    For i = 1 To Selection.ShapeRange.Count
    Set shp = Selection.ShapeRange.Item(i)
      With shp
           .ConnectorFormat.Type = msoConnectorElbow
      End With
    Next i

End Sub





'■■■■■■■■■■■■■■■■■■■■■■■■■
'４．一括選択（線のみ・図形のみ）
'■■■■■■■■■■■■■■■■■■■■■■■■■

'１～３までの処理で追加した図形及び線には全て"図形""線"の名前を付けている
'その名前をもとにeach文で選択/不選択を分岐させる

Sub 図形のみ選択()
    Dim myShape As shape
    For Each myShape In ActiveSheet.Shapes
        If myShape.Name = "図形" Then
            myShape.Select False              'falseだと複数選択になる
        End If
    Next
End Sub



Sub 線のみ選択()
    Dim myShape As shape
    For Each myShape In ActiveSheet.Shapes
        If myShape.Name = "線" Then
            myShape.Select False              'falseだと複数選択になる
        End If
    Next
End Sub





②ここから標準モジュール2（単にフォームを表示させるためのやつ）

Sub myform1()
    UserForm1.Show vbModeless
    
'ユーザーフォームを使う場合はこれを使用、フォーム内ボタンにマクロを割り当て
'ボタンに割り当てるときは「call（マクロ名）」でつかえるようになる
'Show vbModelessでエクセルを操作しながらフォームを使える
    
End Sub


③ユーザーフォームに各ボタンを配置しマクロを割り当てる。