Document.SaveAs2メソッドでドキュメントを量産する（Word）

WordVBA VBA覚書

[Document].SaveAs2メソッドでドキュメントを量産する（Word）

同じ内容のドキュメントを、名前だけ変えて量産したい。

準備

まず、元になるドキュメント（笑）を準備する。

f:id:akashi_keirin:20210905214752p:plain

こいつを、ファイル名を変えて別のフォルダに保存する。

フォルダ構成は、

f:id:akashi_keirin:20210905214756p:plain

こんな感じ。

Mass-ProductDocuments.docmが、今回司令塔になるドキュメント。

Productsフォルダは、名前を変えて保存するときの保存先。大量生産したときは、ここに新たにできたドキュメントがたまってゆく。

SrcDocumentフォルダには、大量生産するための元のドキュメントを入れておく。

ちなみに、中身は

f:id:akashi_keirin:20210905214759p:plain

このとおり。SrcDocument.docxというドキュメントが入っている。（上の「元になるドキュメント（笑）」のことね。）

ドキュメントを開き、別名で指定したフォルダに保存するマクロ

とりあえず、次の動作をするコードを書く。

  • 元になるドキュメント（笑）を開く
  • ファイル名を作る
  • 作ったファイル名で別フォルダに保存する

これだけ。

リスト１
Private Sub test00()
  Const SRC_FOLDER As String = "\SrcDocument\" '"
  Const SRC_FILE_NAME As String = "SrcDocument.docx"
  Const SAVE_FOLDER As String = "\Products\" '"
  
  'テンプレート用ファイルのフルパス組み立て'
  Dim srcPath As String
  srcPath = ThisDocument.Path & SRC_FOLDER & SRC_FILE_NAME
  '保存先フォルダパス'
  Dim saveDir As String
  saveDir = ThisDocument.Path & SAVE_FOLDER
  
  'ファイル名の部品を取得’ '""
  Dim psnNum As String
  psnNum = Format(2, "0#") '番号'
  Dim sectName As String
  sectName = "明訓"        '所属'
  Dim psnName As String
  psnName = "山田 太郎"    '名前'
  'ファイル名組み立て'
  Dim flName As String
  flName = psnNum & psnName & "@" & sectName & ".docx"
  
  'テンプレート用ファイルを開く'
  Dim templateDoc As Word.Document
  Set templateDoc = Word.Documents.Open(srcPath)
  '名前を付けて保存'
  Call templateDoc.SaveAs2(saveDir & flName)
  '閉じる'
  Call templateDoc.Close(SaveChanges:=False)
End Sub

コードについては、コメントをごらんください。

リスト内の「'ファイル名の部品を取得'」のところは、今回はそれぞれ決め打ちにしているが、量産体制に入るときには、ファイル名用の部品をテキストファイルから取得するようにすればよい。

たとえば、テキストファイルに、1件あたり1行になるように、上の例でいうと「番号」、「所属」、「名前」をタブ区切りでデータを作成しておけば、1行分のテキストをSplitで配列にしてやることで、ファイル名の作成に必要なデータを得ることができる。

あと、「名前を付けて保存」以下のところ。

SaveAs2メソッドを実行した時点で、元の「SrcDocument.docx」は、「02山田 太郎@明訓.docx」になってしまう。（手作業のときと同じである。）

で、変数templateDocが指し示しているのも「02山田 太郎@明訓.docx」になる。

したがって、最後の

Call templateDoc.Close(SaveChanges:=False)

を実行すると、「02山田 太郎@明訓.docx」が閉じられ、後には司令塔の「Mass-ProductDocuments.docm」だけが取り残される。

「SrcDocument.docx」が開いたままになる、ということはない。

実行後

Productsフォルダの中身は、

f:id:akashi_keirin:20210905214801p:plain

このとおり。ちゃんと保存されている。

こいつを開くと、

f:id:akashi_keirin:20210905214805p:plain

当然、内容は元の「SrcDocument.docx」と同じである。

おわりに

あとは、ファイル名のもとになるデータを用意して、ループさせれば大量生産が可能。

また、新しくできたドキュメントに、ちょっと手を加えて保存、ということもできる。

様式を大量生産して配布するときに便利です。

段落の末尾に文字列を追加する（Word）

WordVBA VBA覚書


段落の末尾に文字列を追加する（Word）

単なる個人的な覚え書き。

段落の末尾に文字列を追加するぐらい、簡単にできると思っていたが、意外に苦戦したので、記録として残しておく。

手っ取り早く結論だけ知りたい方はコチラ以降をどうぞ。

f:id:akashi_keirin:20210905110949p:plain

このようなドキュメント（笑）の最初の段落の末尾に文字列を挿入することを考える。

【失敗】[Paragraph].Range.InsertAfterメソッドを使う

対象の段落のParagraphオブジェクトを取得し、そのRangeプロパティが返すRangeオブジェクトのInsertAfterメソッドを使えばよいと考えた。

イミディエイトに次のコードを書く。

ActiveDocument.Paragraphs(1).Range.InsertAfter("ち～んｗ")

f:id:akashi_keirin:20210905110951p:plain

こいつを実行すると……。

f:id:akashi_keirin:20210905110954p:plain

あえなく失敗。まさに、「ち～んｗ」である。

【失敗】[Paragraph].Range.InsertBeforeメソッドを使う

では、〝2段落の前に挿入する〟と考えてはどうか。

イミディエイトに次のコードを書く。

ActiveDocument.Paragraphs(2).Range.InsertBefore("ち～んｗ")

f:id:akashi_keirin:20210905110957p:plain

対象の段落の次の段落のParagraphオブジェクトを取得し、そのRangeプロパティが返すRangeオブジェクトのInsertBeforeメソッドを使えばよいと考えたのである。

結果は……。

f:id:akashi_keirin:20210905111000p:plain

ち～んｗ

【成功】段落末尾の位置を取得して[Range].InsertAfterメソッドを使う①

[Paragraph].Rangeプロパティが返すRangeオブジェクトというのは、末尾の改段落まで含んでいるらしい。（当たり前だ。）

ならば、末尾の改段落を含まない部分のRangeオブジェクトを取得すればいいじゃないか。そう考えた。

リスト１
Private Sub test01()
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Call tgtDoc.Paragraphs.Item(1).Range.Select       '……(1)'
  Call Selection.MoveLeft(wdCharacter, 1, wdExtend) '……(2)'
  Call Selection.Range.Collapse(wdCollapseEnd)      '……(3)'
  Call Selection.Range.InsertAfter("ち～んｗ")
End Sub

我ながら、バカ丸出しのコードである。

(1)で第1段落のRangeオブジェクト全体を選択し、(2)で選択範囲を左に1文字分だけ縮めて、(3)で選択範囲の末尾に向けて選択範囲を潰す。

これで、第1段落の改段落マーク直前のところにカーソルが置かれるので、そのRangeオブジェクトのInsertAfterメソッドを使っている。

f:id:akashi_keirin:20210905111003p:plain

やっとできた。

【成功】段落末尾の位置を取得して[Range].InsertAfterメソッドを使う②

しかし、先のやり方は、あまりにもぶさいくである。

よく考えたら、[Paragraph].RangeでRangeオブジェクトが取れる、ということは、その開始位置と終了位置が取れる、ということだ。StartプロパティとEndプロパティで。

だったら、対象のDocumentオブジェクトのRangeメソッドで〝最後の改段落マークを含まないRangeオブジェクト〟を取得すれば良いだけのことである。

リスト２
Private Sub test02()
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim tgtRange As Range
  Set tgtRange = tgtDoc.Paragraphs.Item(1).Range
  Call tgtDoc.Range(tgtRange.Start, _
                    tgtRange.End - 1).InsertAfter("ち～んｗ")
End Sub

うん。この方がスマートだね。

実行すると、

f:id:akashi_keirin:20210905111114p:plain

ほれ、このとおり。挿入語の文字列が無駄に選択状態にならないから、この方がやっぱりいいね。

おわりに

WordのVBAは、地味～な罠が至るところにあるので、ほんとに面白い。

まさに、〝男坂〟……。

f:id:akashi_keirin:20210905111615p:plain

VBAでRangeオブジェクトの場所に連番フィールドを挿入する（Word）

WordVBA VBA覚書

VBAでRangeオブジェクトの場所に連番フィールドを挿入する（Word）

ちょっとした覚書。

Fields.Addメソッドでフィールド追加

文書内にフィールドを追加するには、Fields.Addメソッドを使う。（参考）

Fields.Addメソッドには、引数が四つ。

  • Range
  • Type
  • Text
  • PreserveFormatting

一つ目のRangeは挿入する箇所、二つ目のTypeはフィールドの種類（WdFieldType列挙体で指定できる。）、三つ目のTextプロパティは、フィールドコード文字列のうち、フィールド名以外の部分。

ここまでは、上の「参考」のところを読んだらすぐにわかる。

四つ目のPreserveFormattingというのがよくわからん。

知っている人がいたら教えろえてください。

丸囲み数字の連番フィールドをカーソル位置に挿入するマクロ

リスト１
Private Sub test01()
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim fld As Field
  Set fld = tgtDoc.Fields.Add(Range:=Selection.Range, _
                              Type:=wdFieldSequence, _
                              Text:="傍線番号 \* circlenum")
End Sub

ほとんど手探りでコードを書いた。（最後、無駄に変数fldを使っていますけど、特に意味はないです。Call tgtDoc.Fields.Add〔以下略〕でいいです。）

連番フィールドのフィールド名は「SEQ」なので、引数TypeにはwdFieldSequenceを指定。

Textプロパティには、とりあえずガチでフィールドコードを書くときの「SEQ」以外の部分を書いた。

（一般書式）スイッチ（「\*」以下の部分。）を指定することによって、色んなタイプの連番が使えるので実によい。

スイッチについては、コチラで勉強した。実にありがたい。

実行結果

リスト１を実行すると、カーソル位置に丸数字で連番が挿入される。

f:id:akashi_keirin:20210823085917p:plain

それぞれ、下線部の先頭でリスト１を実行したところ。

ちなみに、引数Textに渡した文字列の「circlenum」を「iroha」に変えると、

f:id:akashi_keirin:20210823085914p:plain

こんなふうにイロハになる。まあ素敵。（連番にカッコとか付ける方法を学ばねばならぬ。）

おわりに

フィールドコードも、面白いですね。

下線（傍線）を施した部分のRangeオブジェクトを取得するFunction（Word）

WordVBA VBA自作メソッド

下線（傍線）を施した部分のRangeオブジェクトを取得するFunction（Word）

なんとなく、役所広司ばりにチャチャっと作ってみた。

ソースコード

リスト１
Public Function GetNextUnderlinedRange( _
          Optional ByVal a_LineStyle As WdUnderline _
                         = wdUnderlineSingle) As Range
  Dim ret As Range
  Set ret = Nothing
  With Selection.Find
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  With Selection.Find
    With .Font	               '……(1)'
      .Underline = a_LineStyle '……(2)'
      .StrikeThrough = False
      .DoubleStrikeThrough = False
      .Hidden = False
      .SmallCaps = False
      .AllCaps = False
      .Superscript = False
      .Subscript = False
    End With
    .Text = ""                 '……(3)'
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True             '……(4)'
    .Highlight = False
    .MatchFuzzy = False '←注意！　こいつだけ初期値True'
    .MatchCase = False
    .MatchWholeWord = False
    .MatchByte = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
  End With
  Call Selection.Find.Execute
  If Not Selection.Find.Found Then GoTo ReturnObject
  Set ret = Selection.Range
ReturnObject:
  With Selection.Find
    Call .ClearFormatting
    Call .Replacement.ClearFormatting
  End With
  Set GetNextUnderlinedRange = ret
End Function

もう、大事なのは(1)の

With Selection.Find.Font
  .Underline = a_LineStyle '……(2)'
  .StrikeThrough = False
  .DoubleStrikeThrough = False
  .Hidden = False
  .SmallCaps = False
  .AllCaps = False
  .Superscript = False
  .Subscript = False
End With

だけと言っても過言ではない。（コードは省略を補完しています。）

FindオブジェクトのFontプロパティを参照して、Fontオブジェクトを取得し、そのUnderlineプロパティに値をセットしているだけ。

それが(2)の

Selection.Find.Font.Underline = a_LineStyle

です。（これまた省略を補完してあります。）

a_LineStyleは、このGetNextUnderlinedRangeメソッドが受け取る引数。WdUnderline型にしてある。

あとは、(3)の

Selection.Find.Text = ""

で、FindオブジェクトのTextプロパティを""に設定。これで、どんな文字列かに関係なく検索にヒットする。

ちなみに、(4)の

Selection.Find.Format = True

のところを、

Selection.Find.Format = False

にすると、わけのわからない箇所が検索に引っ掛かる。

原因は不明。

使ってみる

準備

次のような文書を用意して、先頭にカーソルを置き、

f:id:akashi_keirin:20210823074457p:plain

次のコードを実行してみる。

リスト２
Private Sub test01()
  Dim rng As Range
  Set rng = GetNextUnderlinedRange(wdUnderlineSingle)
  Debug.Print rng.Text
End Sub

一重下線の箇所を検索し、その部分の文字列をイミディエイトに出力するだけ、というコード。

実行結果

f:id:akashi_keirin:20210823074500p:plain

このとおり。一応意図どおりの結果が得られた。

おわりに

Findオブジェクトは、プロパティが多くてなかなかとっつきにくいが、こうやって一つづつ機能を試していくと、徐々にわかってくると思う。

おまけ

Findオブジェクトの各プロパティは、「検索と置換」ダイアログボックスの各部分との対応を確認していけば、理解が早いと思う。

おなじみ、［Ctrl］＋［ H ］を押したら出てくる「検索と置換」ダイアログボックス。

f:id:akashi_keirin:20210823074503p:plain

左下の「書式」ボタンをクリックし、「フォント」を選ぶと、「検索する文字」ダイアログボックスが出てくる。

f:id:akashi_keirin:20210823074506p:plain

テキストボックス挿入の自動化（Word）

WordVBA VBA自作メソッド

テキストボックス挿入の自動化（Word）

表題のとおり、Wordの文書内にテキストボックスを挿入する作業を自動化したくなったので、やってみた。

きっかけとお題

きっかけ

文字ばっかりのPowerPointスライドを図として挿入するのに、画像で入れてしまったら、文字列の検索が利用できず、不便なので、テキストボックスで再現して挿入しようと思った。

お題

すると、次のような作業が発生することになる。

  • テキストボックスを挿入する
  • 枠線を設定する
  • テキストボックス内の段落書式を設定する
  • テキストボックス自体に段落スタイル（図用）を適用する
  • テキストボックスの寸法（横幅）を決める
  • 図表番号を設定する

ざっとこんな感じ。まあ、テキストボックスの複製自体は、一つ作っておけば、それをたとえば［Ctrl］＋ドラッグで次のやつが作れるんだけれど、図表番号を挿入することを考えると、大した回数発生しない作業とはいえめんどくさい。

そこで、男坂WordVBAの登場ですよ！

要するに、上の作業を1クリックでやりたいわけです。

テキストボックスを挿入するマクロ

まずは、コードを掲載。

リスト１
Option Explicit

Private Const FIGURE_STYLE_1 As String = "My図1"  '……(1)'

Private Const TEXTBOX_STYLE_1 As String = "MyTextBox1"
Private Const TEXTBOX_STYLE_2 As String = "MyTextBox2"

Private Const TEXTBOX_WIDTH As Single = 419.5276  '148ミリ'
Private Const TEXTBOX_HEIGHT As Single = 204.0945 '72ミリ'
Private Const TEXTBOX_MARGIN As Single = 11.33858 '4ミリ'

Public Sub InsertInlineTextBox()
  Dim tgtDoc As Document  '……(2)'
  Set tgtDoc = ActiveDocument
  Dim tb As Word.Shape
  Set tb = tgtDoc.Shapes.AddTextbox( _
                           Orientation:=msoTextOrientationHorizontal, _
                           Left:=0, Top:=0, _
                           Width:=TEXTBOX_WIDTH, _
                           Height:=TEXTBOX_HEIGHT)
  tb.WrapFormat.Type = wdWrapInline  '……(3)'
  With tb    '……(4)'
    With .Line    '……(5)'
      .Visible = msoTrue
      .Weight = 1
      .Style = msoLineSingle
      .ForeColor = vbBlack
    End With
    With .TextFrame    '……(6)'
      .TextRange.Style = TEXTBOX_STYLE_1
      .MarginTop = TEXTBOX_MARGIN
      .MarginBottom = TEXTBOX_MARGIN
      .MarginLeft = TEXTBOX_MARGIN
      .MarginRight = TEXTBOX_MARGIN
    End With
  End With
  Selection.Style = FIGURE_STYLE_1  '……(7)'
End Sub

まず、(1)からの6行（空行除く）、

Private Const FIGURE_STYLE_1 As String = "My図1"

Private Const TEXTBOX_STYLE_1 As String = "MyTextBox1"
Private Const TEXTBOX_STYLE_2 As String = "MyTextBox2"

Private Const TEXTBOX_WIDTH As Single = 419.5276  '148ミリ'
Private Const TEXTBOX_HEIGHT As Single = 204.0945 '72ミリ'
Private Const TEXTBOX_MARGIN As Single = 11.33858 '4ミリ'

これは、後のプロシージャ中で使う定数。

「My図1」とか、「MyTextBox1」、「MyTextBox2」は、全部自作の段落スタイル名。

「TEXTBOX_WIDTH」、「TEXTBOX_HEIGHT」、「TEXTBOX_MARGIN」は、寸法にかかわる値を定数化。

Wordを直接操作するときはミリ単位なんだけれど、VBAのメソッドではポイント単位の指定でわかりにくいので、Word.MillimetersToPointsメソッドで変換した値を定数として設定している。

f:id:akashi_keirin:20210817085043p:plain

次に、(2)からの8行（実質4行）、

Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim tb As Word.Shape
  Set tb = tgtDoc.Shapes.AddTextbox( _
                           Orientation:=msoTextOrientationHorizontal, _
                           Left:=0, Top:=0, _
                           Width:=TEXTBOX_WIDTH, _
                           Height:=TEXTBOX_HEIGHT)

で、ひとまずテキストボックスを挿入。

アクティブなドキュメントを変数「tgtDoc」にぶち込み、[Document].Shapes（コレクション）オブジェクトのAddTextBoxメソッドを使う。

「行内」に配置したいのだが、[Document].InlineShapes（コレクション）オブジェクトには、AddTextBoxメソッドがないので、仕方なくこうしている。

つまり、一旦位置を指定している。（引数LeftとTopに0を指定。）

引数WidthとHeightは、文字どおりテキストボックスの幅と高さ。ここでは先に値を定めた定数をそれぞれ渡している。

(3)の

tb.WrapFormat.Type = wdWrapInline

では、tbつまり、ShapeオブジェクトのWrapFormatプロパティからWrapFormatオブジェクトを取得し、そのTypeプロパティにwdWrapInlineという値を設定している。

ちなみに、wdWrapInlineは、WdWrapType列挙体のメンバ。

これで、一旦左上端に設置されたテキストボックスの配置が「行内」になる。

(4)からの15行、

With tb
  With .Line    '……(5)'
    .Visible = msoTrue
    .Weight = 1
    .Style = msoLineSingle
    .ForeColor = vbBlack
  End With
  With .TextFrame    '……(6)'
    .TextRange.Style = TEXTBOX_STYLE_1
    .MarginTop = TEXTBOX_MARGIN
    .MarginBottom = TEXTBOX_MARGIN
    .MarginLeft = TEXTBOX_MARGIN
    .MarginRight = TEXTBOX_MARGIN
  End With
End With

は、テキストボックス自体の書式設定と、テキストボックス内の書式設定。

こういうふうにまとめて書ける、というのはVBAのいいところ。

まず、(5)からの6行、

With .Line
  .Visible = msoTrue
  .Weight = 1
  .Style = msoLineSingle
  .ForeColor = vbBlack
End With

[Shape].Lineプロパティを参照してLineオブジェクトを取得。その各プロパティを設定している。要するに、テキストボックス自体の枠線の調整である。

(6)からの7行、

With .TextFrame
  .TextRange.Style = TEXTBOX_STYLE_1
  .MarginTop = TEXTBOX_MARGIN
  .MarginBottom = TEXTBOX_MARGIN
  .MarginLeft = TEXTBOX_MARGIN
  .MarginRight = TEXTBOX_MARGIN
End With

では、今度は[Shape].TextFrameプロパティを参照してTextFrameオブジェクトを取得。その各プロパティを設定している。

まず、TextRangeプロパティを参照してTextRangeオブジェクトを取得。そのStyleプロパティに、適用したいスタイル名を設定している。当然、当該文書にそのスタイル（この場合は、定数TEXTBOX_STYLE_1の中身、すなわち「MyTextBox1」スタイル。）が存在しなかったら実行時エラーになる。

残りの四つ（「Margin～」）は、テキストボックス内のマージンの設定。

すでに設定済みの定数で設定。

最後に、(7)の

Selection.Style = FIGURE_STYLE_1

で、カーソル位置（つまり、テキストボックスが挿入された段落。）にスタイルを適用する。もちろん、この場合も定数FIGURE_STYLE_1で指定したスタイルが文書に存在しなければ実行時エラーになる。

図表番号を付加するマクロ

これについては、コチラをどうぞ。

完成したマクロ

リスト２
Private Sub setTextBoxMain()
  Call TextBoxUtil.InsertInlineTextBox  '……(1)'
  Call Selection.MoveRight(wdCharacter, 1, wdMove)  '……(2)'
  Call Selection.InsertAfter(Chr(13))
  Call UsefulMacros.SetCaption("図", wdCaptionPositionBelow)  '……(3)'
End Sub

(1)の

Call TextBoxUtil.InsertInlineTextBox

で、まずはテキストボックスを文書内に挿入する。

TextBoxUtilというのは、リスト１のInsertInlineTextBoxメソッドを書いた標準モジュールの名前。

(2)からの2行、

Call Selection.MoveRight(wdCharacter, 1, wdMove)
Call Selection.InsertAfter(Chr(13))

(1)の直後の段階では、カーソルがテキストボックスの左側にあるので、

f:id:akashi_keirin:20210817085046p:plain

(2)からの2行、

Call Selection.MoveRight(wdCharacter, 1, wdMove)  '……(2)'
Call Selection.InsertAfter(Chr(13))

でカーソルを一つ右に動かし、新しい段落を追加する。

f:id:akashi_keirin:20210817085049p:plain

最後に(3)の

Call UsefulMacros.SetCaption("図", wdCaptionPositionBelow)

で図表番号を追加。

「UsefulMacros」というのも、自作の標準モジュール名。SetCaptionメソッドはその中にある。（そろそろ「UsefulMacros」モジュールから切り離さないといけないと思っている。）SetCaptionメソッドのコードはコチラをどうぞ。

全部実行すると、

f:id:akashi_keirin:20210817085052p:plain

こうなる。

ちなみに、PDF化した後でも、

f:id:akashi_keirin:20210817085055p:plain

ちゃんと検索に引っかかる。ありがたい。

おわりに

Wordのマクロづくりは、楽しいなあ。

【意味】Paragraphオブジェクトの謎挙動【不明】（Word）

WordVBA VBA覚書

【意味】Paragraphオブジェクトの謎挙動【不明】

WordのVBAで、ParagraphオブジェクトのRange.Textプロパティを書き換えたら、わけのわからないことが起こったので報告。

もとの文書

もとのWord文書は、

f:id:akashi_keirin:20210808163624p:plain

このとおり。何の変哲もない、至ってフツーのドキュメントである。

f:id:akashi_keirin:20210808163629p:plain

1段落目のスタイルは、「表題」。

f:id:akashi_keirin:20210808163632p:plain

2段落目のスタイルは、「副題」である。

各段落のRange.Textプロパティを書き換えるマクロ

この文書に対して、次のようなマクロを実行してみる。

リスト１
Private Sub test01()
  Dim tgtDoc As Document
  Set tgtDoc = ActiveDocument
  Dim para As Paragraph
  Dim tmp As String
  For Each para In tgtDoc.Paragraphs
    tmp = para.Range.Text  '……①'
    para.Range.Text = tmp  '……②'
    Debug.Print para.Range.Text  '……③'
  Next
End Sub

アクティブドキュメントからParagraphsコレクションを取得し、Paragraphオブジェクト一つ一つに対して、まずはそのRange.Textプロパティを取得し（①）、直後に取得した文字列をRange.Textプロパティにセットし直す（②）、というアホみたいなマクロだ。

また、一連のアホな処理が終わった後は、ParagraphオブジェクトのRange.Textプロパティの値をイミディエイトに表示する（③）。

さて、こいつを実行するとどうなるとお思いだろうか？

衝撃の実行結果

実は、次のような奇想天外な結果が得られる。

上記リスト１の①のところを実行した時点では、当然何も起こらない。

問題は、②の実行後である。

f:id:akashi_keirin:20210808163636p:plain

なんと、こうなってしまうのである。

なんでやねん。

続けて③を実行してみる。

当然1段落目の文字列が表示されると思いきや、

f:id:akashi_keirin:20210808163640p:plain

このように、2段落目の文字列が表示されるのである。

いつの間にか、変数paraが2段落目のParagraphオブジェクトを指し示すようになっているのである。

おわりに

どうも、私はまだParagraphオブジェクトについて、満足に理解できていないらしい。

なんとも、WordのVBAというものは、

男坂

である！

f:id:akashi_keirin:20210808163653p:plain

VBAで文書にインライン画像を挿入する（Word）

VBA覚書 WordVBA

VBAで文書に画像を挿入するときの注意

最近、Wordでマニュアルとか手順書の類を作成することがやたら増えた。

PDF配布を前提とすると、画像をふんだんに盛り込むことができるので、非常に良いのだが、当然画像の挿入が非常にめんどくさくなってくる。

そこで、VBAで画像挿入を楽にできるようにしようとした。

そのときに、ちょっと予定外のことが起こったので、報告。

カーソル位置にインライン画像を挿入するマクロ

まずは、カーソル位置にインライン画像を挿入するマクロ。

ドキュメントのあるフォルダ内に、「img」というフォルダがあり、その中に「アホの坂田.png」という画像ファイルがあるとする。

リスト１
Private Sub test01()
  Dim imgPath As String
  imgPath = ThisDocument.Path & "\img\アホの坂田.png"
  Dim ilShp As InlineShape
  Set ilShp = Selection.Range.InlineShapes.AddPicture(imgPath)
  Call ilShp.Select
End Sub

カーソル位置のRangeオブジェクトのInlineShapesプロパティからInlineShapesコレクションオブジェクトを取得し、そのAddPictureメソッドにより、画像を挿入する。

AddPictureメソッドの返り値はInlineShapeオブジェクトなので、InlineShape型の変数ilShpで受け取り、最後にSelectメソッドを実行して、挿入した画像を選択状態にするようにしている。

リスト１を実行すると、当然、

f:id:akashi_keirin:20210807151631p:plain

こうなる。

実にめでたい。

画像の大きさを変えようとすると悲劇が起こる

しかし……。

f:id:akashi_keirin:20210807154319g:plain

これは全然だめである。

画像の書式を調べてみる。

f:id:akashi_keirin:20210807152008p:plain

なんと、デフォルトでは「縦横比を固定する」のチェックが外れているのである。なんでやねん。

LockAspectRatioプロパティ

画像の縦横比の固定を司るのは、[InlineShape].LockAspectRatioプロパティである。

画像を挿入するマクロ、リスト１を、次のように変えて実行してみる。

リスト２
Private Sub test01()
  Dim imgPath As String
  imgPath = ThisDocument.Path & "\img\アホの坂田.png"
  Dim ilShp As InlineShape
  Set ilShp = Selection.Range.InlineShapes.AddPicture(imgPath)
  Call ilShp.Select
  Debug.Print ilShp.LockAspectRatio
End Sub

画像挿入直後のLockAspectRatioプロパティの値をイミディエイトに出力する。

結果は、

f:id:akashi_keirin:20210807151641p:plain

このとおり、「0」と出た。

オブジェクト ブラウザーで調べると、

f:id:akashi_keirin:20210807151645p:plain

LockAspectRatioプロパティはMsoTriState型。

同様にオブジェクト ブラウザーで調べると、MsoTriState列挙体のメンバは、

f:id:akashi_keirin:20210807151648p:plain

このとおり。

つまり、LockAspectRatioプロパティのデフォルト値はmsoFalseだとわかる。

これは、タンザニアのイカンガーである。

コードの修正

そこで、リスト１を次のように書き換える。

リスト３
Private Sub test01()
  Dim imgPath As String
  imgPath = ThisDocument.Path & "\img\アホの坂田.png"
  Dim ilShp As InlineShape
  Set ilShp = Selection.Range.InlineShapes.AddPicture(imgPath)
  ilShp.LockAspectRatio = msoTrue
  Call ilShp.Select
End Sub

画像を挿入するや否や、LockAspectRatioプロパティの値をmsoTrueにするのである！

実行結果

f:id:akashi_keirin:20210807153116g:plain

当然、画像の書式は、

f:id:akashi_keirin:20210807152012p:plain

このとおり、ちゃんと「縦横比を固定する」にチェックが入っている。

うむ、万全である！

おわりに

手動で動画を挿入すると、普通に「縦横比を固定する」にチェックが入っているものだから、ちょっと焦りましたよ。

関連記事

akashi-keirin.hatenablog.com