More than 3 years have passed since last update.

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

【メモ】

Last updated at 2021-03-23Posted at 2021-03-21

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

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

ちょうど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)

End Sub

Sub ひし形()

Dim shape As shape

Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeDiamond, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)

End Sub

Sub データ()

Dim shape As shape

Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartMagneticDisk, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)

End Sub

Sub 書類()

Dim shape As shape

Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeFlowchartDocument, Left:=ActiveCell.Left, Top:=ActiveCell.Top, Width:=60, Height:=35)

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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)

'線の色を変えたい場合はこのあたりに記入？

End With

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

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

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up