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

Excel VBA Tips
この記事は約47分で読めます。

「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プロパティ」でもご紹介しましたが再度掲載いたします。

図形を作成する9個

  1. AddCallout 吹き出し
  2. AddConnector コネクタ
  3. AddCurve 曲線
  4. AddLabel ラベル
  5. AddLine 線
  6. AddPolyline 多角形
  7. AddShape オートシェープ
  8. AddTextbox テキストボックス
  9. BuildFreeform フリーフォーム

図形以外の描画オブジェクトを作成する8個

  1. AddChart2 グラフ
  2. AddFormControl フォームコントロール
  3. AddOLEObject OLEオブジェクト
  4. AddPicture 画像
  5. AddPicture2 画像(圧縮あり)
  6. AddSmartArt 図表(SmartArt)
  7. AddTextEffect ワードアート
  8. Add3DModel 3Dモデル

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

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

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

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

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

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

Noメソッド列挙型パラメータなど種類・属性値の範囲
1AddCalloutMsoCalloutTypeType1~4(「-2」:状態の組み合わせ)
2AddConnectorMsoConnectorTypeType1~3(「-2」:状態の組み合わせ)
3AddCurve
4AddLabelMsoTextOrientationテキストの向き1~6(「-2」:非サポート)
5AddLineMsoLineStyleスタイル1~5(「-2」:非サポート)
6AddPolyline
7AddShapeMsoAutoShapeTypeType1~183(「-2」:状態の組み合わせ)
8AddTextboxNo4と同じNo4と同じNo4と同じ
9BuildFreeformMsoEditingType引数:EditingType0~3(図形としては1つに見なす)
10AddChart2XlChartTypeグラフの種類※表外に記載(詳細は次回その2で説明)
11AddFormControlXlFormControlControlの種類0~9
12AddOLEObjectなし引数:LinkTrue:リンク有、False:リンク無
13AddPictureなし引数:LinkToFile      〃
14AddPicture2なし引数:LinkToFile      〃
15AddSmartArtSmartArtLayout(Index)レイアウトapplication.SmartArtLayouts.Count
16AddTextEffectMsoPresetTextEffectテキスト効果0~49(「-2」:不使用)
17Add3DModelなし引数:LinkToFileTrue:リンク有、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での判定プロパティ等補足
1AddCalloutCalloutFormatTypecallout.type
2AddConnectorConnectorFormatTypeConnectorformat.type
3AddCurveShapeNodeSegmentTypenodes.item(1).segmenttype1:曲線
4AddLabelTextFrameOrientationtextframe.orientation
5AddLineLineFormatStyleLine.Style追加属性
6AddPolylineNo3と同じNo3と同じNo3と同じ0:Line
7AddShapeShapeAutoShapeType←左と同じ
8AddTextboxNo4と同じNo4と同じNo4と同じ
9BuildFreeformFreeformBuilder該当なし
10AddChart2ChartChartTypeShapeには存在しない次回説明
11AddFormControlControlFormat該当なしFormControlType
12AddOLEObjectOLEObjectOLETypeOLEFormat.Object.OLETypeリンク判定
13AddPictureType疑似判定
14AddPicture2Type疑似判定
15AddSmartArtSmartArtLayoutIDSmartArt.Layout.ID固有ID
16AddTextEffectTextEffectFormatPresetTextEffecttexteffect.PresetTextEffectスタイル判定
17Add3DModelThreeDFormat該当なし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メソッドパラメータデータ内容
3AddCurveSafeArrayOfPoints2次元の座標の配列:曲線の両端とコントロールポイントを指定
6AddPolylineSafeArrayOfPoints座標値の配列:折れ線の頂点を指定
9BuildFreeformX1,Y1X軸,Y軸に対して節点の位置を左上隅からのポイント数で指定
12AddOLEObjectFileNameOLEオブジェクトを作成するための「既存ファイル」
13AddPictureFileName画像を作成するための「既存ファイル」
14AddPicture2FileName画像を作成するための「既存ファイル」
17Add3DModelFileName3Dモデルを作成するための「既存ファイル」

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

  • 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個になります。

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

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

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

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

12345678910
No種類NameTypeTypeNameAutoShapeType判定プロパティ比較数式 描画図形

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

  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ポイント)に収まるサイズにしていますが、オブジェクトによってはそれでは足りないのでメソッドごとに行数を変えています。

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

Noメソッド繰返し回数送り行数
1AddCallout1~41
2AddConnector1~31
3AddCurveなし2
4AddLabel1~61
5AddLine1~51
6AddPolylineなし2
7AddShape1~1831
8AddTextbox1~61
Noメソッド繰返し回数送り行数
9BuildFreeformなし2
10AddFormControl0~91
11AddOLEObjectリンク有無1
12AddPictureリンク有無1
13AddPicture2リンク有無1
14AddSmartArt1~※6
15AddTextEffect0~491
16Add3DModelリンク有無4
※はSmartArtLayouts.Countの値

実際のコーディング事例

コーディングの行数は少し長くなりますが、それそれのメソッドを順番に処理しているだけなので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メソッド種類エラー番号 - メッセージ
1AddShape1381004-指定された値は境界を超えています。
2AddFormControl31004-アプリケーション定義またはオブジェクト定義のエラーです。

【エラー要因の推測】

  1. MsoAutoShapeType列挙の値138(=msoShapeNotPrimitive)の説明は「非サポート」になっているのでエラーになるものと推察されます。
  2. XlFormControl列挙の値3(=xlEditBox)はテキスト ボックスなのですが、左図キャプチャーのよう開発タブメニュ→コントロールの挿入→フォームコントロールではテキスト ボックスはデフォルト選択できないのでエラーになるものと推察されます。

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

比較結果のまとめ

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

メソッド種類列挙説明Auto
Shape
Type
判定
プロパティ
列挙説明
AddCallout2一重の折れた吹き出し線1131一重水平吹き出し線
AddLabel4アジア言語のサポートに必要な垂直16アジア言語のサポートに必要に応じて水平方向と回転
AddShape110対角線付き吹き出し109罫線と水平方向の引き出し線を持つ吹き出し
117水平線付き吹き出し113水平アクセント バー付きの吹き出し
118罫線と斜めの引き出し線がない吹き出し113水平アクセント バー付きの吹き出し
121罫線と水平方向のアクセント バーを持つ吹き出し109罫線と水平方向の引き出し線を持つ吹き出し
137バルーン106四角形の丸い吹き出し
AddTextbox4アジア言語のサポートに必要な垂直16アジア言語のサポートに必要に応じて水平方向と回転
AddTextEffect23 番目のテキスト効果1-2不使用
34 番目のテキスト効果1-2不使用
3031 のテキスト効果1-2不使用
3133 分の 3 のテキスト効果1-2不使用
3536 番目のテキスト効果1-2不使用
3637 番目のテキスト効果1-2不使用

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

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

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

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

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

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

Typeプロパティの戻り値

Type説明メソッド個数
1AutoShapeAddConnector3
AddShape166
AddTextEffect50
2吹き出しAddCallout4
AddShape16
5フリーフォームAddCurve1
AddPolyline1
BuildFreeform1
7埋め込み OLE オブジェクトAddOLEObject1
8フォーム コントロールAddFormControl9
9直線AddLine5
10リンク OLE オブジェクトAddOLEObject1
11リンク画像AddPicture1
AddPicture21
13画像AddPicture1
AddPicture21
17テキスト ボックスAddLabel6
AddTextbox6
24SmartArt グラフィックAddSmartArt134
303DモデルAdd3DModel1
31リンクされた3DモデルAdd3DModel1
メソッドType個数
Add3DModel301
311
AddCallout24
AddConnector13
AddCurve51
AddFormControl89
AddLabel176
AddLine95
AddOLEObject71
101
AddPicture111
131
AddPicture2111
131
AddPolyline51
AddShape1166
216
AddSmartArt24134
AddTextbox176
AddTextEffect150
BuildFreeform51
  • AutoShape(=1)
    • 3種類のメソッドによる描画図形が含まれていて、AddShape以外にAddConnectorとAddTextEffectが含まれる。
  • 吹き出し(=2)
    • AddCallout以外にAddShapeが含まれる。
  • 埋め込み OLE オブジェクト(=7)とリンク OLE オブジェクト(=10)
    画像(=13)とリンク画像(=10)
    3Dモデル(=30)とリンクされた3Dモデル(=31)
    • それぞれリンクの有無でTypeの戻り値が異なる。

TypeName関数の戻り値

TypeNameメソッド個数
ArcAddShape2
ButtonAddFormControl1
CheckBoxAddFormControl1
DrawingAddCurve1
AddPolyline1
BuildFreeform1
DropDownAddFormControl1
GroupBoxAddFormControl1
GroupObjectAddSmartArt134
LabelAddFormControl1
LineAddConnector1
AddLine5
ListBoxAddFormControl1
OLEObjectAddOLEObject2
OptionButtonAddFormControl1
OvalAddShape1
PictureAddPicture2
AddPicture22
RectangleAdd3DModel2
AddCallout3
AddConnector2
AddShape179
AddTextEffect50
ScrollBarAddFormControl1
SpinnerAddFormControl1
TextBoxAddLabel6
AddTextbox6
メソッドTypeName個数
Add3DModelRectangle2
AddCalloutRectangle3
AddConnectorLine1
Rectangle2
AddCurveDrawing1
AddFormControlButton1
CheckBox1
DropDown1
GroupBox1
Label1
ListBox1
OptionButton1
ScrollBar1
Spinner1
AddLabelTextBox6
AddLineLine5
AddOLEObjectOLEObject2
AddPicturePicture2
AddPicture2Picture2
AddPolylineDrawing1
AddShapeArc2
Oval1
Rectangle179
AddSmartArtGroupObject134
AddTextboxTextBox6
AddTextEffectRectangle50
BuildFreeformDrawing1
  • 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つが含まれる。

前回の記事で「オートシェープ」と言う言葉で表したのは、Excelユーザインターフェースの挿入タブメニュの図から図形を選択して開かれるサブメニュから描画できる集合になります。

それに対して今回はVBAのShapesメソッドで描画できる図形の集合としてまとめていますので、前回の「オートシェープ」の表現とは差が生じています事お詫び申し上げます。

前回「オートシェープ」と表現したのは下記メソッドの描画図形です。

  • AddCallout,AddConnector,AddCurve,AddLine,AddPolyline,AddShape,BuildFreeform

AutoShapeTypeの戻り値

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

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

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

メソッドAuto
Shape
Type
MsoAutoShapeType列挙の説明個数
Add3DModel-2その他の状態の組み合わせを示す2
AddCallout113水平アクセント バー付きの吹き出し2
119罫線と角度付き引き出し線がない吹き出し1
120U 字型を形成する罫線セグメントと引き出し線セグメントがない吹き出し1
AddConnector-2その他の状態の組み合わせを示す3
AddCurve138非サポート1
AddFormControl-2その他の状態の組み合わせを示す9
AddLabel1四角形6
AddLine-2その他の状態の組み合わせを示す5
AddOLEObject-22
AddPicture1四角形2
AddPicture212
AddPolyline138非サポート1
AddShape182
AddSmartArt-2その他の状態の組み合わせを示す134
AddTextbox1四角形6
AddTextEffect150
BuildFreeform138非サポート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」としております。

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

Excel VBA Tips
スポンサーリンク
スポンサーリンク
シェアする
∞ワークスKenをフォローする
∞ワークス