Excel VBAで全描画オブジェクトをシートに書き出して確認する-その1

「Excel VBA Tips」ではExcel VBAを使用していて気付いたことを取り上げて行きます。

今回と次回はExcel VBAを使って「すべての描画オブジェクトをActiveSheetに書き出して、書き出された描画オブジェクトの種類を確認するためのコーディング事例」を「グラフ」と「グラフ以外」に分けてご紹介いたします。

書き出すのはメソッドの指示に従えば良いのですが、書き出された描画オブジェクトを確認するところは一筋縄ではいかず、いろいろ試行錯誤した結果をご紹介していますので、もしかすると別なやり方があるかもしれません。

なお前々回の「VBA ShapesオブジェクトとItemメソッド・Rangeプロパティ」や前回の「Excel VBAのSelectionプロパティを描画オブジェクトで使うためには」でご説明した内容を引用する箇所がありますので、合わせてご確認いただければ幸いです。

また前回で宿題にした「TypeName(Selection)の戻り値の検証」についても今回ご説明いたします。

※動作は32bit版Excel 2016と64bit版Excel 2021の バージョン2209(ビルド 15629.20208)を使用して検証しています。(遅ればせながら64bit版Excel 2021も検証対象に加えました)

Shapesオブジェクトで描画オブジェクトを作成する17のメソッド

前々回の「VBA ShapesオブジェクトとItemメソッド・Rangeプロパティ」でもご紹介しましたが再度掲載いたします。

今回ご説明するのは、上記17のメソッドの内の「AddChart2 グラフ」以外の16メソッドを使って作成することができるすべての種類の描画オブジェクトになります。

グラフにつきましては次回ご紹介いたします。

描画オブジェクトの種類を決めるパラメータについて

これらのメゾッドの中にはオブジェクトの種類や属性などを指定する列挙型パラメータが存在するものがあります。
基本的には「この列挙型パラメータに何個値があるか?」によってメソッドを使って作成できる描画オブジェクトの種類の数が決まります。ただしパラメータの中には種類・形状に関わるもの以外に図形内テキストの向きやテキスト効果だったり、リンクの有無など様々で種類として分けた方が良いのか?悩ましいものもあります。

そうは言っても何がどうなるのか分からないので、一応設定されているものすべてを試して確認する事にします。

※なお「列挙型パラメータなど」列にはMicrosoft Officeの当該ドキュメントへのリンク(https://learn.microsoft.com/ja-jp/office/vba/api/xxx)を設定しています。
それぞれのドキュメントは本記事内随所で引用していますのでお含み置きいただければ幸いです。

No	メソッド	列挙型パラメータなど	種類・属性	値の範囲
1	AddCallout	MsoCalloutType	Type	1~4(「-2」：状態の組み合わせ)
2	AddConnector	MsoConnectorType	Type	1~3(「-2」：状態の組み合わせ)
3	AddCurve	－	－
4	AddLabel	MsoTextOrientation	テキストの向き	1~6(「-2」：非サポート)
5	AddLine	MsoLineStyle	スタイル	1~5(「-2」：非サポート)
6	AddPolyline	－	－
7	AddShape	MsoAutoShapeType	Type	1~183(「-2」：状態の組み合わせ)
8	AddTextbox	No4と同じ	No4と同じ	No4と同じ
9	BuildFreeform	MsoEditingType	引数：EditingType	0~3(図形としては1つに見なす)
10	AddChart2	XlChartType	グラフの種類	※表外に記載(詳細は次回その2で説明)
11	AddFormControl	XlFormControl	Controlの種類	0~9
12	AddOLEObject	なし	引数：Link	True：リンク有、False：リンク無
13	AddPicture	なし	引数：LinkToFile	〃
14	AddPicture2	なし	引数：LinkToFile	〃
15	AddSmartArt	SmartArtLayout(Index)	レイアウト	application.SmartArtLayouts.Count
16	AddTextEffect	MsoPresetTextEffect	テキスト効果	0~49(「-2」：不使用)
17	Add3DModel	なし	引数：LinkToFile	True：リンク有、False：リンク無

【補足説明】

• No9.BuildFreeformのMsoEditingTypeパラメータは図形の節点の形状を指定するためのもので図形の種類としては区別せずに「1」でカウントする。
  • BuildFreeformメソッドにより描画されるFreeformBuilderオブジェクトは、そのままでは可視化されないのでConvertToShapeメソッドでShapeオブジェクトに変換する必要があります。
• No10.AddChart2のXlChartType列挙の値の範囲は次のようになり、合計では74種類ありますが詳細は次回ご説明いたします。
  • -4169, -4151, -4120, -4102, -4101, -4100, -4098
  • 1, 4, 5, 15
  • 51~112, 140
• No15.AddSmartArtには列挙型ではなくレイアウトを表すオブジェクトとしてSmartArtLayout(Index)が使用されています。
  • Indexの最大値はapplication.SmartArtLayouts.Countで取得できますが、現状は134です。
  • SmartArtLayout オブジェクトはExcelだけではなくOffice製品全般で使用されます。

これらの数字を、パラメータが無いメソッドは1とカウントすると合計で486種類(グラフを除くと412種類)になります。

ただし詳細は後述いたしますが、実際に描画して見るとエラーになったり見た目が変わらないオブジェクトも存在しているので種類を正確にカウントするのは難しいところです。

描画したオブジェクトの種類を判定するためのプロパティ

次に描かれてた描画オブジェクトが「どのようなタイプ・種類であるのか?」を判定するためのプロパティなどについて見て行きます。

冒頭にも書きましたが実はこれが結構分かり難いと言いますかメソッドによってバラバラで、前章で上げたパラメータをそのまま取得できないメソッドも存在しています。

プロパティについては一通り確認したつもりですが、もしかすると抜け漏れがあるかもしれませんのでお含み置きいただければ幸いです。

※なお「帰属オブジェクト」列にはMicrosoft Officeの当該ドキュメントへのリンク(https://learn.microsoft.com/ja-jp/office/vba/api/xxx)を設定しています。
それぞれのドキュメントは本記事内随所で引用していますのでお含み置きいただければ幸いです。

No	メソッド	帰属オブジェクト	判定プロパティ	Shapeでの判定プロパティ等	補足
1	AddCallout	CalloutFormat	Type	callout.type
2	AddConnector	ConnectorFormat	Type	Connectorformat.type
3	AddCurve	ShapeNode	SegmentType	※nodes.item(1).segmenttype	1：曲線
4	AddLabel	TextFrame	Orientation	※textframe.orientation
5	AddLine	LineFormat	Style	Line.Style	追加属性
6	AddPolyline	No3と同じ	No3と同じ	※No3と同じ	0：Line
7	AddShape	Shape	AutoShapeType	←左と同じ
8	AddTextbox	No4と同じ	No4と同じ	※No4と同じ
9	BuildFreeform	FreeformBuilder	該当なし	※
10	AddChart2	Chart	ChartType	Shapeには存在しない	次回説明
11	AddFormControl	ControlFormat	該当なし	FormControlType
12	AddOLEObject	OLEObject	OLEType	OLEFormat.Object.OLEType	リンク判定
13	AddPicture	－	－	Type	疑似判定
14	AddPicture2	－	－	Type	疑似判定
15	AddSmartArt	SmartArtLayout	ID	SmartArt.Layout.ID	固有ID
16	AddTextEffect	TextEffectFormat	PresetTextEffect	texteffect.PresetTextEffect	スタイル判定
17	Add3DModel	ThreeDFormat	該当なし	Type	疑似判定

【補足説明】

• No3.AddCurveとNo6.AddPolylineは引かれる線が「曲線か直線か」の違いがあります。
  • この違いはnodes.item(1).segmenttypeで判定できるのでAddCurveとAddPolylineは切り分けができます。
    ただしNo9.BuildFreeformはデータの設定によって曲線でも直線でも引くことができるために、No3.AddCurveまたはNo6.AddPolylineとの切り分けはできません。
• No4.AddLabelとNo8.AddTextboxは設定されている「テキストの向き」はtextframe.orientationで判定できるのですが、AddLabelとAddTextboxの切り分けはできません。
• No13.AddPicture、No14.AddPicture2それとNo17.Add3DModelにはリンクの有・無を判定するためのプロパティは存在しません。その代わりにShapeオブジェクトのTypeプロパティでリンクの有無を判定する事はできるのですが、残念ながら対象が画像なのか3Dモデルなのかを切り分ける事はできません。
• No15.AddSmartArtはIndexそのものではなくSmartArtLayout(Index)が返す文字列「urn:microsoft.com/office/officeart/200…」によってレイアウトが設定されます。
  従ってSmartArt.Layout.IDが返す値は文字列になりIndexのような数値にはなりません。
  

描画オブジェクトを描くために必要なデータ

今回対象にしている16メソッドの中には描画オブジェクトを描くために「列挙型パラメータ」以外のデータが必要になるメソッドが7個あります。

それらを下記の一覧にまとめました。

No	メソッド	パラメータ	データ内容
3	AddCurve	SafeArrayOfPoints	2次元の座標の配列：曲線の両端とコントロールポイントを指定
6	AddPolyline	SafeArrayOfPoints	座標値の配列：折れ線の頂点を指定
9	BuildFreeform	X1,Y1	X軸,Y軸に対して節点の位置を左上隅からのポイント数で指定
12	AddOLEObject	FileName	OLEオブジェクトを作成するための「既存ファイル」
13	AddPicture	FileName	画像を作成するための「既存ファイル」
14	AddPicture2	FileName	画像を作成するための「既存ファイル」
17	Add3DModel	FileName	3Dモデルを作成するための「既存ファイル」

今回のコーディング事例では上記メソッドに関して次のようなデータを使用しています。

• No3.AddCurveとNo6.AddPolylineは同じ2次元座標のデータを使用して描画しています。ポイント箇所は7箇所です。
  • データはプログラムの中にコーディングしています。
• No9.BuildFreeformは節点5個のデータを使用して描画しています。
  • データはプログラムの中にコーディングしています。
• No12.AddOLEObjectは「Word.docx」というファイル名のWord文書を使用しています。
  • コーディング事例を保存したxlsmファイルと同じフォルダーにファイルを作って置く必要があります。
    • なお文章は1行あれば十分です。
  • なおWord文書以外にはExcelの「挿入」メニュタブ→「テキスト」→「オブジェクト」で開かれる「オブジェクトの挿入」画面で指定する事ができるものが使えます。
• No13.AddPictureでは「Pic1.png」、No14.AddPicture2では「Pic2.png」というファイル名の画像を使用しています。
  • コーディング事例を保存したxlsmファイルと同じフォルダーにファイルを作って置く必要があります。
    • 画像サイズは決められた行数に収まるようにメソッドで指定しますが、「高さ：幅」が「1：2」ぐらいの数Kbyteのファイルがあれば十分です。
  • 画像の種類は他に「bmp,gif,jpg」の各形式はリンクの有無に関わらず動きますが、「heic,tif」はリンク有の場合にエラーになるので注意が必要です。
• No17.Add3DModelでは「Cubic.glb」というファイル名の3Dモデルを使用しています。
  • コーディング事例を保存したxlsmファイルと同じフォルダーにファイルを作って置く必要があります。
    • サイズは決められた行数に収まるようにメソッドで指定しますが、「高さ：幅」が「1：1」ぐらいの数Kbyteのファイルがあれば十分です。
  • 3Dモデルはwindows標準アプリである「ペイント3D」を使って作成する事ができます。

描画したオブジェクトに対して調べる項目

今回すべての種類の描画オブジェクトを作成するコーディング事例をご紹介するに当たり、「描画したオブジェクトの種類を確認するためのプロパティ」以外に調べておきたい項目があります。それをご説明いたします。

描画したオブジェクトのTypeName関数の戻り値

これは前回の「Excel VBAのSelectionプロパティを描画オブジェクトで使うためには」で宿題にしていた「すべての描画オブジェクトのTypeName(Selection)の戻り値の検証」に対応するためのものです。

メソッドによって返される値はある程度固定化しているのですが、ものによって中にパラパラと別の値を返す場合があります。

詳細はコーディング事例をご紹介した後にご説明いたします。

描画したオブジェクトのTypeとAutoShapeTypeのプロパティ

今回はグラフ以外になるので、すべての描画したオブジェクトにTypeプロパティとAutoShapeTypeプロパティは存在しています。
※グラフの場合の対応については次回ご説明いたします。

Typeプロパティは相応した値を戻すのですが、AutoShapeTypeプロパティはものによって「-2：状態の組み合わせ」を返す場合があります。ただし、エラーが発生する事はありません。

本件も詳細はコーディング事例をご紹介した後にまとめてご説明いたします。

コーディング事例

グラフを除くすべての種類の描画オブジェクトを作成するためのコーディング事例をご紹介いたします。

プログラムの構造としてはメインサブルーチンから描画メソッドを呼び出す3種類のファンクションと、ファンクションから呼ばれる共通出力のための子サブルーチンの計5個になります。

ワークシート上への出力方法とその仕様

結果はアクティブシートの最初の行から出力しますので、空のシートをアクティブにしてからマクロを実行してください。

出力するデータ項目とその仕様

ワークシートに出力するデータ項目の並びはつぎのようになります。

1	2	3	4	5	6	7	8	9	10
No	種類	Name	Type	TypeName	AutoShapeType	判定プロパティ	比較数式		描画図形

各データ項目の内容は次のようになります。

1. No
   • 描画図形すべてに対する連番で、列挙型パラメータでエラーになる場合はカウントしない。
2. 種類
   • 列挙型パラメータなどの数値データで、存在しない時は「－」を表示する。
3. Name
   • Selection.ShapeRange(1).Nameの戻り値で、AddSmartArtの時はApplication.SmartArtLayouts(Index).Nameをつなげて表示する。
4. Type
   • Selection.ShapeRange(1).Typeの戻り値を表示する。
5. TypeName
   • TypeName(Selection)の戻り値を表示する。
6. AutoShapeType
   • Selection.ShapeRange(1).AutoShapeTypeの戻り値を表示する。
7. 判定プロパティ
   • 「描画したオブジェクトの種類を判定するためのプロパティ」の章でご説明した「Shapeでの判定プロパティ等」の戻り値で、存在しない時は”－”を表示する。
   • AddShapeの時は、6項目めにAutoShapeTypeの戻り値が表示されているので”←”を出力する。
   • AddSmartArtの時は”※”を出力して、別の場所にApplication.SmartArtLayouts(Index).IDの戻り値とSelection.ShapeRange(1).SmartArt.Layout.IDの戻り値を列挙する。
8. 比較数式
   • 2項目めの「列挙型パラメータなどの数値データ」と7項目めの「判定プロパティ」とを比較するExcelのIF関数の数式を指定したセルにセットします。両者が異なる時は”×”で、同じ時は空文字にします。
     ※数式をセットした時は背景色を付けます。
   • 2項目めが”－”の時は数式ではなく”－”を表示します。
     ※この場合は背景色はなしにします。
9. 空列
   • 列からはみ出た描画オブジェクトの一部がかからないようにしています。
10. 描画図形
    • メソッドで書き出される描画オブジェクトの左上が該当セルの左上に重なるようにします。

繰返しの回数と行送りの行数について

描画オブジェクトの種類や属性などを指定する列挙型パラメータの数だけ処理を繰り返す事になりますが、その繰り返し回数をメソッドごとに表にまとめています。

また描画する図形はなるべくデフォルトの1行(18ポイント)に収まるサイズにしていますが、オブジェクトによってはそれでは足りないのでメソッドごとに行数を変えています。

各メソッドに対する繰返しの回数と送り行数は下記のようになります。

実際のコーディング事例

コーディングの行数は少し長くなりますが、それそれのメソッドを順番に処理しているだけなので1つの基本的なパターンを押さえていただければ後はその応用でご理解いただけると思います。

メイン処理

• 列挙型パラメータの繰返し処理
• ヘッダー行と各メソッドのタイトル行のセットと行送りの値のセット
• 各メソッドごとの判定プロパティのセット
• 画面更新の制御と列幅自動調整

※コーディング行が横幅に入り切れていないのでマウスのドラックかキーボードの矢印ボタンでスクロールしてください。

Sub AllDrawingObject1()
Dim lid As Long  '列挙型数値の繰返しカウント
Dim lrow As Long  '送り行
Dim cnt As Long  '連番カウンター
    Application.ScreenUpdating = False   '画面固定
'ヘッダー行
    Cells(1, 1).Value = "No": Cells(1, 2).Value = "種類": Cells(1, 3).Value = "Name": Cells(1, 4).Value = "Type"
    Cells(1, 5).Value = "TypeName": Cells(1, 6).Value = "AutoShapeType": Cells(1, 7).Value = "判定プロパティ"
    Cells(1, 8).Value = "比較数式": Cells(1, 9).Value = "　": Cells(1, 10).Value = "描画図形": Range("A1:J1").Font.Bold = True
'初期値セット
    lrow = 2  '1行目はヘッダーなので2行目から
    cnt = 0  '連番カウンター初期化(サブルーチンで使用)
'AddCallout
    Cells(lrow, 3).Value = "AddCallout": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 4
        If drawPattern1(cnt, lrow, "AddCallout", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).Callout.Type
        lrow = lrow + 1  '行送り
    Next
'AddConnector
    Cells(lrow, 3).Value = "AddConnector": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 3
        If drawPattern1(cnt, lrow, "AddConnector", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).ConnectorFormat.Type
        lrow = lrow + 1  '行送り
    Next
'AddCurve
    Cells(lrow, 3).Value = "AddCurve": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern2(cnt, lrow, "AddCurve", "－") Then Cells(lrow, 7).Value = Selection.ShapeRange(1).Nodes.Item(1).SegmentType
    lrow = lrow + 2  '行送り
'AddLabel
    Cells(lrow, 3).Value = "AddLabel": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 6
        If drawPattern1(cnt, lrow, "AddLabel", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).TextFrame.Orientation
        lrow = lrow + 1  '行送り
    Next
'AddLine
    Cells(lrow, 3).Value = "AddLine": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 5
        If drawPattern1(cnt, lrow, "AddLine", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).Line.Style
        lrow = lrow + 1  '行送り
    Next
'AddPolyline
    Cells(lrow, 3).Value = "AddPolyline": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern2(cnt, lrow, "AddPolyline", "－") Then Cells(lrow, 7).Value = Selection.ShapeRange(1).Nodes.Item(1).SegmentType
    lrow = lrow + 2  '行送り
'AddShape
    Cells(lrow, 3).Value = "AddShape": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 183
        If drawPattern1(cnt, lrow, "AddShape", lid) Then Cells(lrow, 7).Value = "←"
        lrow = lrow + 1  '行送り
    Next
'AddTextbox
    Cells(lrow, 3).Value = "AddTextbox": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To 6
        If drawPattern1(cnt, lrow, "AddTextbox", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).TextFrame.Orientation
        lrow = lrow + 1  '行送り
    Next
'BuildFreeform
    Cells(lrow, 3).Value = "BuildFreeform": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern3(cnt, lrow, "BuildFreeform", "－") Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 2  '行送り
'AddFormControl
    Cells(lrow, 3).Value = "AddFormControl": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 0 To 9
        If drawPattern1(cnt, lrow, "AddFormControl", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).FormControlType
        lrow = lrow + 1  '行送り
    Next
'AddOLEObjectリンクなし
    Cells(lrow, 3).Value = "AddOLEObject": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern1(cnt, lrow, "AddOLEObject", "－", False) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).OLEFormat.Object.OLEType
    lrow = lrow + 1  '行送り
'   〃リンクあり
    If drawPattern1(cnt, lrow, "AddOLEObject", "－", True) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).OLEFormat.Object.OLEType
    lrow = lrow + 1  '行送り
'AddPictureリンクなし
    Cells(lrow, 3).Value = "AddPicture": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern1(cnt, lrow, "AddPicture", "－", False) Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 1  '行送り
'   〃リンクあり
    If drawPattern1(cnt, lrow, "AddPicture", "－", True) Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 1  '行送り
'AddPicture2リンクなし
    Cells(lrow, 3).Value = "AddPicture2": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern1(cnt, lrow, "AddPicture2", "－", False) Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 1  '行送り
'   〃リンクあり
    If drawPattern1(cnt, lrow, "AddPicture2", "－", True) Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 1  '行送り
'AddSmartArt
    Cells(lrow, 3).Value = "AddSmartArt": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 1 To Application.SmartArtLayouts.Count
        If drawPattern1(cnt, lrow, "AddSmartArt", lid) Then Cells(lrow, 7).Value = "※"
        lrow = lrow + 6  '行送り
    Next
'AddTextEffect
    Cells(lrow, 3).Value = "AddTextEffect": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    For lid = 0 To 49
        If drawPattern1(cnt, lrow, "AddTextEffect", lid) Then Cells(lrow, 7).Value = Selection.ShapeRange(1).TextEffect.PresetTextEffect
        lrow = lrow + 1  '行送り
    Next
'Add3DModelリンクなし
    Cells(lrow, 3).Value = "Add3DModel": Cells(lrow, 3).Font.Bold = True: lrow = lrow + 1  'メソッドタイトル&行送り
    If drawPattern1(cnt, lrow, "Add3DModel", "－", False) Then Cells(lrow, 7).Value = "－"
    lrow = lrow + 4  '行送り
'   〃リンクあり
    If drawPattern1(cnt, lrow, "Add3DModel", "－", True) Then Cells(lrow, 7).Value = "－"
'後処理
    Application.ScreenUpdating = True   '固定解除
    Cells.Select: Cells.EntireColumn.AutoFit '列幅自動調整
    ActiveSheet.Cells(1, 1).Select  'A1セルを選択する
End Sub

描画処理1

• AddCurve,AddPolyline,BuildFreeform以外のメソッドを指定したセルで実行
• 既存ファイル名のパスをセット
• 比較数式をセット(背景色を付ける)
• 共通出力処理をコールする。
• On Errorステートメントの処理

Function drawPattern1(ByRef cnt As Long, lrow As Long, stMethod As String, vType As Variant, Optional bLink As Boolean = False) As Boolean
On Error GoTo Err_Handle
Dim sp As Shape
Dim st_pic1 As String, st_pic2 As String
Dim st_doc As String, st_glb As String
    st_pic1 = ThisWorkbook.Path & "\Pic1.png"  '画像
    st_pic2 = ThisWorkbook.Path & "\Pic2.png"  '〃
    st_doc = ThisWorkbook.Path & "\Word.docx"  'ワード文書
    st_glb = ThisWorkbook.Path & "\Cubic.glb"  '3Dモデル
    drawPattern1 = True
    ActiveSheet.Cells(lrow, 10).Select  'セルを選択する
    Cells(lrow, 8).FormulaR1C1 = "=IF(RC[-1]<>RC[-6],""X"","""")"  '比較数式セット
    Cells(lrow, 8).Interior.Color = RGB(234, 234, 234)  '背景色
    With ActiveCell
        If stMethod = "AddCallout" Then
            Set sp = ActiveSheet.Shapes.AddCallout(vType, .Left, .Top, 20, 15)
        ElseIf stMethod = "AddConnector" Then
            Set sp = ActiveSheet.Shapes.AddConnector(vType, .Left, .Top, .Left + 20, .Top + 15)
        ElseIf stMethod = "AddLabel" Then
            Set sp = ActiveSheet.Shapes.AddLabel(vType, .Left, .Top, 50, 15)
        ElseIf stMethod = "AddLine" Then
            Set sp = ActiveSheet.Shapes.AddLine(.Left, .Top, .Left + 20, .Top + 15)
            sp.Line.Style = vType: sp.Line.Weight = 4#  '属性追加指定
        ElseIf stMethod = "AddShape" Then
            Set sp = ActiveSheet.Shapes.AddShape(vType, .Left, .Top, 20, 15)
            Cells(lrow, 8).FormulaR1C1 = "=IF(RC[-2]<>RC[-6],""X"","""")"  '数式変更
        ElseIf stMethod = "AddTextbox" Then
            Set sp = ActiveSheet.Shapes.AddTextbox(vType, .Left, .Top, 50, 15)
        ElseIf stMethod = "AddFormControl" Then
            Set sp = ActiveSheet.Shapes.AddFormControl(vType, .Left, .Top, 50, 15)
        ElseIf stMethod = "AddOLEObject" Then
            Set sp = ActiveSheet.Shapes.AddOLEObject(Filename:=st_doc, link:=bLink, _
                Left:=.Left, Top:=.Top, Width:=300, Height:=30)
            Cells(lrow, 8).Value = "－": Cells(lrow, 8).ClearFormats '数式なし
        ElseIf stMethod = "AddPicture" Then
            Set sp = ActiveSheet.Shapes.AddPicture(st_pic1, bLink, Not (bLink), .Left, .Top, 30, 15)
            Cells(lrow, 8).Value = "－": Cells(lrow, 8).ClearFormats '数式なし
        ElseIf stMethod = "AddPicture2" Then
            Set sp = ActiveSheet.Shapes.AddPicture2(st_pic2, bLink, Not (bLink), .Left, .Top, 30, 15, _
                msoPictureCompressTrue)  '(=1)
            Cells(lrow, 8).Value = "－": Cells(lrow, 8).ClearFormats '数式なし
        ElseIf stMethod = "AddSmartArt" Then
            Set sp = ActiveSheet.Shapes.AddSmartArt(Application.SmartArtLayouts(vType), _
                .Left, .Top, 100, 100)
            Cells(lrow, 8).FormulaR1C1 = "=IF(R[1]C[-5]<>R[2]C[-5],""X"","""")"  '数式変更
        ElseIf stMethod = "AddTextEffect" Then
            Set sp = ActiveSheet.Shapes.AddTextEffect(vType, "Hellow World", "游ゴシック", 11, _
                True, False, Left:=.Left, Top:=.Top)
        ElseIf stMethod = "Add3DModel" Then
            Set sp = ActiveSheet.Shapes.Add3DModel(Filename:=st_glb, LinkToFile:=bLink, _
                SaveWithDocument:=Not (bLink), Left:=.Left, Top:=.Top, Width:=70, Height:=70)
            Cells(lrow, 8).Value = "－": Cells(lrow, 8).ClearFormats '数式なし
        End If
    End With
    sp.Select
    Set sp = Nothing
    Call commonOutPut(cnt, lrow, stMethod, vType)
    Exit Function '<<<<<<<<
Err_Handle:
    Cells(lrow, 2).Value = vType: Cells(lrow, 3).Value = Err.Number & "-" & Err.Description
    Cells(lrow, 8).Clear  '数式削除
    drawPattern1 = False: Err.Clear: On Error GoTo 0
End Function

描画処理2

• AddCurve,AddPolylineのメソッドを指定したセルで実行
• 座標データをセット
• 比較数式はなく、共通出力処理をコールする。
• On Errorステートメントの処理

Function drawPattern2(ByRef cnt As Long, lrow As Long, stMethod As String, vType As Variant) As Boolean
Dim s_ptdt(1 To 7, 1 To 2) As Single
Dim sp As Shape
    drawPattern2 = True
    ActiveSheet.Cells(lrow, 10).Select  'セルを選択する
    With ActiveCell  '座標データをセット
        s_ptdt(1, 1) = .Left + 0: s_ptdt(1, 2) = .Top + 0
        s_ptdt(2, 1) = .Left + 35: s_ptdt(2, 2) = .Top + 10
        s_ptdt(3, 1) = .Left + 20: s_ptdt(3, 2) = .Top + 20
        s_ptdt(4, 1) = .Left + 10: s_ptdt(4, 2) = .Top + 30
        s_ptdt(5, 1) = .Left + 20: s_ptdt(5, 2) = .Top + 15
        s_ptdt(6, 1) = .Left + 15: s_ptdt(6, 2) = .Top + 30
        s_ptdt(7, 1) = .Left + 10: s_ptdt(7, 2) = .Top + 10
        Cells(lrow, 8).Value = "－"  '比較数式なし
        If stMethod = "AddCurve" Then
            Set sp = ActiveSheet.Shapes.AddCurve(SafeArrayOfPoints:=s_ptdt)
        ElseIf stMethod = "AddPolyline" Then
            Set sp = ActiveSheet.Shapes.AddPolyline(SafeArrayOfPoints:=s_ptdt)
        End If
    End With
    sp.Select
    Set sp = Nothing
    Call commonOutPut(cnt, lrow, stMethod, vType)
    Exit Function '<<<<<<<<
Err_Handle:
    Cells(lrow, 2).Value = vType: Cells(lrow, 3).Value = Err.Number & "-" & Err.Description
    Cells(lrow, 8).Clear  '数式削除
    drawPattern2 = False: Err.Clear: On Error GoTo 0
End Function

描画処理3

• BuildFreeformのメソッドを指定したセルで実行
• 座標データをセット
• 比較数式はなく、共通出力処理をコールする。
• On Errorステートメントの処理

Function drawPattern3(ByRef cnt As Long, lrow As Long, stMethod As String, vType As Variant) As Boolean
Dim sp As Shape
Dim fb As FreeformBuilder
    ActiveSheet.Cells(lrow, 10).Select  'セルを選択する
    Cells(lrow, 8).Value = "－"  '比較数式なし
    With ActiveCell
        Set fb = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, .Left, .Top)
        fb.AddNodes msoSegmentCurve, msoEditingCorner, .Left + 30, .Top + 15, _
            .Left + 45, .Top + 20, .Left + 30, .Top + 30
        fb.AddNodes msoSegmentLine, msoEditingAuto, .Left + 15, .Top + 35
        fb.AddNodes msoSegmentCurve, msoEditingSmooth, .Left, .Top
    End With
    Set sp = fb.ConvertToShape
    sp.Select
    Set fb = Nothing
    Set sp = Nothing
    Call commonOutPut(cnt, lrow, stMethod, vType)
    Exit Function '<<<<<<<<
Err_Handle:
    Cells(lrow, 2).Value = vType: Cells(lrow, 3).Value = Err.Number & "-" & Err.Description
    Cells(lrow, 8).Clear  '数式削除
    drawPattern3 = False: Err.Clear: On Error GoTo 0
End Function

共通出力処理

• 連番、種類(列挙パラメータ等)、Name、Type、TypeName、AutoShapeTypeの出力
• AddSmartArtの場合は個別処理を行う。
  • NameにSmartArtLayouts(Index).Nameを付与
  • 3列目にSmartArtLayouts(Index).IDとSmartArt.Layout.IDの戻り値を列挙

Sub commonOutPut(ByRef cnt As Long, lrow As Long, stMethod As String, vType As Variant)
    Cells(lrow, 2).Value = vType  '列挙パラメータ等
    With Selection.ShapeRange(1)
        Cells(lrow, 3).Value = .Name
        Cells(lrow, 4).Value = .Type
        Cells(lrow, 5).Value = TypeName(Selection)
        Cells(lrow, 6).Value = .AutoShapeType
        If stMethod = "AddSmartArt" Then  'SmartArt個別処理
            Cells(lrow, 3).Value = Cells(lrow, 3).Value & "/" & Application.SmartArtLayouts(vType).Name
            Cells(lrow + 1, 3).Value = Application.SmartArtLayouts(vType).ID
            Cells(lrow + 2, 2).Value = "※": Cells(lrow + 2, 3).Value = .SmartArt.Layout.ID
        End If
    End With
    cnt = cnt + 1: Cells(lrow, 1).Value = cnt  '連番出力
End Sub

実行結果のまとめ

前章5つのコーディングをVBA標準モジュールに保存してAllDrawingObject1を実行します。
※なお事前にWord.docx,Pic1.png,Pic2.png,Cubic.glbの4つのファイルを上記xlsmを保存したのと同じフォルダーに作成して置く必要があります。

• Word.docx
  • 文章は1行あれば十分です。
• Pic1.png,Pic2.png
  • 「高さ：幅」が「1：2」ぐらいの数Kbyteのファイルがあれば十分です。
• Cubic.glb
  • 「高さ：幅」が「1：1」ぐらいの数Kbyteのファイルがあれば十分です。

グラフを除くすべての種類の描画オブジェクトが作成されてヘッダー行のカラムに合わせてセットしたプロパティや関数の戻り値を取得できます。

なお弊社環境で実行すると終了まで約30秒弱かかり、410個の描画オブジェクトが出力されています。
※列挙パラメータなどから数えた時は描画オブジェクトの種類は412種類でしたが、2個の差については後段でご説明いたします。

各メソッドの実行結果のキャプチャー(一部分)

16メソッドそれぞれの実行結果の一部を画面キャプチャーでご紹介いたします。

エラーの発生状況

　メソッドがエラーになるのは次の2つになります。

No	メソッド	種類	エラー番号　－　メッセージ
1	AddShape	138	1004-指定された値は境界を超えています。
2	AddFormControl	3	1004-アプリケーション定義またはオブジェクト定義のエラーです。

【エラー要因の推測】

2種類のエラーがあるために出力される描画オブジェクトは410個になります。

比較結果のまとめ

「種類で指定した値」と「判定プロパティが返す戻り値」とを比較すると不一致になっているものがあるので下記にまとめています。

メソッド	種類	列挙説明	Auto Shape Type	判定 プロ パティ	列挙説明
AddCallout	2	一重の折れた吹き出し線	113	1	一重水平吹き出し線
AddLabel	4	アジア言語のサポートに必要な垂直	1	6	アジア言語のサポートに必要に応じて 水平方向と回転
AddShape	110	対角線付き吹き出し	109	←	罫線と水平方向の引き出し線を持つ 吹き出し
	117	水平線付き吹き出し	113	←	水平アクセント バー付きの吹き出し
	118	罫線と斜めの引き出し線がない吹き出し	113	←	水平アクセント バー付きの吹き出し
	121	罫線と水平方向のアクセント バーを持つ吹き出し	109	←	罫線と水平方向の引き出し線を持つ 吹き出し
	137	バルーン	106	←	四角形の丸い吹き出し
AddTextbox	4	アジア言語のサポートに必要な垂直	1	6	アジア言語のサポートに必要に応じて 水平方向と回転
AddTextEffect	2	3 番目のテキスト効果	1	-2	不使用
	3	4 番目のテキスト効果	1	-2	不使用
	30	31 のテキスト効果	1	-2	不使用
	31	33 分の 3 のテキスト効果	1	-2	不使用
	35	36 番目のテキスト効果	1	-2	不使用
	36	37 番目のテキスト効果	1	-2	不使用

そもそも不一致になっている原因が下記のどちらなのか?がハッキリと分かっていません。

• 「メソッド」が該当する種類を正しく反映していない。
• 「判定プロパティ」が該当する種類を正しく反映していない。

ただあまりメソッドでは使われていない種類での違いという認識ですので、この件につきましてはこれ以上掘り下げない事にいたします。

従いましてグラフを除くすべての描画オブジェクトの種類としては410種類といたします。

Type・TypeName・AutoShapeTypeの戻り値のまとめ

それぞれの戻り値を順番に表にまとめて行きます。

Typeプロパティの戻り値

• AutoShape(=1)
  • 3種類のメソッドによる描画図形が含まれていて、AddShape以外にAddConnectorとAddTextEffectが含まれる。
• 吹き出し(=2)
  • AddCallout以外にAddShapeが含まれる。
• 埋め込み OLE オブジェクト(=7)とリンク OLE オブジェクト(=10)
  画像(=13)とリンク画像(=10)
  3Dモデル(=30)とリンクされた3Dモデル(=31)
  • それぞれリンクの有無でTypeの戻り値が異なる。

TypeName関数の戻り値

• TypeName=Rectangleは5つのメソッドが値を返す。
  • Add3DModel,AddCallout,AddConnector,AddShape,AddTextEffect
• AddShapeメソッドで描画される図形にはTypeName=Arc,Oval,Rectangleの3つが含まれる。
• TypeName=Drawingは3つのメソッドが値を返す。
  • AddCallout,AddPolyline,BuildFreeform
• TypeName=LineにはAddConnector,AddLineが含まれる。
  • AddConnectorメソッドで描画される図形にはTypeName=Line,Rectangleの2つが含まれる。

AutoShapeTypeの戻り値

恐らくAutoShapeTypeプロパティはAddShapeメソッドで描画される図形に対して使用するのが本来のあるべき姿だと思います。

従って、これは「ご参考までに」とはなりますがAddShapeメソッド以外のメソッドで描画される図形でも「-2：その他の状態の組み合わせを示す」以外の戻り値を返す場合がありますので、それらを下記一覧にまとめました。

※AddShapeメソッドは一覧では個数のみを表示しています。

メソッド	Auto Shape Type	MsoAutoShapeType列挙の説明	個数
Add3DModel	-2	その他の状態の組み合わせを示す	2
AddCallout	113	水平アクセント バー付きの吹き出し	2
	119	罫線と角度付き引き出し線がない吹き出し	1
	120	U 字型を形成する罫線セグメントと引き出し線セグメントがない吹き出し	1
AddConnector	-2	その他の状態の組み合わせを示す	3
AddCurve	138	非サポート	1
AddFormControl	-2	その他の状態の組み合わせを示す	9
AddLabel	1	四角形	6
AddLine	-2	その他の状態の組み合わせを示す	5
AddOLEObject	-2	〃	2
AddPicture	1	四角形	2
AddPicture2	1	〃	2
AddPolyline	138	非サポート	1
AddShape	－	－	182
AddSmartArt	-2	その他の状態の組み合わせを示す	134
AddTextbox	1	四角形	6
AddTextEffect	1	〃	50
BuildFreeform	138	非サポート	1

• AddCalloutがAutoShapeTypeの値を返す事から、「両者は同じ描画図形になっているのでは?」と推察いたします。
• AddLabel,AddPicture,AddPicture2,AddTextbox,AddTextboxは1=四角形を返します。ただし「それに何か意味があるか?」と言われると特筆すべき点はない認識です。
• AddCurve,AddPolyline,BuildFreeformはAddShapeでは「非サポート」になっている138の値を返します。逆に言うとこの3メソッドの描画図形のためにAddShapeの138を割り当てているのかもしれませんが、これはあくまでも推測です。

以上からワークシート上の描画図形が何のメソッドで描かれたか判定できるのか?

描画図形に対するいろいなプロパティの戻り値を見て来ましたが、以上の結果から「ワークシート上の描画図形が何のメソッドで描かれたか判定できるのむか?」と言う疑問が沸いてくることと存じます。

今回の記事の文字数が多くなってしまっているので詳細は別の機会があればご紹介したいと思いますが、結論としては「ほぼほぼできるが完全には分からない」という事になります。

その理由の一つは「比較結果のまとめ」でご紹介した「種類で指定した値」と「判定プロパティが返す戻り値」とが不一致になるものがあるためです。

さらに前段でも述べましたがAddCurve及びAddPolylineとBuildFreeformとの切り分けができない事と、AddLabelとAddTextboxの違いがテキストボックスの属性の違いによっている事、AddPictureとAddPicture2の違いが図形の圧縮の有無になっている事などが挙げられます。

という事で「どうしても描画図形の種類を判別したい」時には、メソッドとは別に何かしらの図形の属性を使って書き出す際に印を付けて置くしか方法が無さそうです。

最後に

今回は「グラフ以外」の描画図形をVBAを使って「すべての描画オブジェクトをActiveSheetに書き出して、書き出された描画オブジェクトの種類を確認するためのコーディング事例」をご紹介いたしました。

次回は「グラフ」の場合のご説明をいたします。

「グラフ一種類であれば分ける必要が無いのでは?」と思われるかもしれませんが、「グラフ」は単独ではSelection.ShapeRange(1)が使用できない事と、グラフの種類によって個別のデータが描画するグラフの特定の位置に存在する必要がある事などの理由から「その2」としております。

以上最後までご一読いただき誠にありがとうございました。