EasyTextFileクラスは今……

EasyTextFileクラスは今……

f:id:akashi_keirin:20210918103251p:plain

クラスモジュールのコード

ただ、クラスモジュールのコードを晒すだけ……。

たぶん、盛大にヌケやモレがあると思うし、そもそもTextStreamオブジェクトのこととかADOSteramオブジェクトのことをろくに理解もせずに、手探りで書いたようなコードなので、ツッコミどころだらけだと思う。

達人の皆さんのご指南を仰ぎたく思う。

リスト1 クラスモジュール:EasyTextFile
Option Explicit

'設定用のテキストファイルを扱うためだけに使うクラス'
'必要最小限の機能にとどめる'
'2021-09-18現在の機能'
'・テキスト読み込み'
'・行のテキストの書きかえ'
'・行の追記:Appendメソッド'
'・テキストファイルの上書き保存:Saveメソッド'
'・テキストファイルの別名保存:SaveAsメソッド'

'Public enums'
'Enumerations for Scripting.FileSystemObject object'
Public Enum TFCharCode
  tfShiftJIS = 0
  tfUTF8 = 1
  tfUTF16 = -1
'  tfUseDefault = -2'
End Enum

'Private enums'
'Enumerations for ADODB.Stream object'
Private Enum StreamTypeEnum
  adTypeBinary = 1
  adTypeText = 2
End Enum

Private Enum SaveOptionsEnum
  adSaveCreateNotExist = 1
  adSaveCreateOverWrite = 2
End Enum

Private Enum StreamReadEnum
  adReadAll = -1
  adReadLine = -2
End Enum

Private Enum StreamWriteEnum
  adWriteChar = 0
  adWriteLine = 1
End Enum

'Enumerations for Scripting.FileSystemObject'
Private Enum IOMode
  ForReading = 1
  ForWriting = 2
  ForAppending = 8
End Enum

Private Enum Tristate
  TristateFalse = 0
  TristateTrue = -1
  TristateUseDefault = 2
End Enum

'Enumerations for error'
Private Enum TFErrType
  tfErrNotInitialized = 1
  tfErrFileNotExist
  tfErrArgInvalid
End Enum

'Constants'
Private Const ERR_NUMBER As Long = 10000

'Module level variables'
'実行時バインディングにしている'
Private m_FSO As Object
Private m_TextStream As Object
Private m_ADOStream As Object

'Field variables'
Private m_Path As String
Private m_TextLines As Collection
Private m_Encoding As TFCharCode
Private m_HasInitialized As Boolean

'Constructor'
Private Sub Class_Initialize()
  Set m_FSO = CreateObject("Scripting.FileSystemObject")
  Set m_ADOStream = CreateObject("ADODB.Stream")
  Set m_TextLines = New Collection
End Sub

Public Sub Init(ByVal a_Path As String, _
                ByVal a_CharCode As TFCharCode)
  'If file not exists, raise error.'
  If Not m_FSO.FileExists(a_Path) Then
    Call raiseError(tfErrFileNotExist)
  End If
  'LinesTextに値があったら一旦全部消しておく'
  '※Collectionの要素は上書きができないため'
  Dim i As Long
  Dim cnt As Long
  cnt = m_TextLines.Count
  If cnt > 0 Then
    For i = 1 To cnt
      Call m_TextLines.Remove(CStr(i))
    Next
  End If
  m_Path = a_Path
  m_HasInitialized = True
  Dim tmp As String
  Dim n As Long
  n = 1
  m_Encoding = a_CharCode
  Select Case m_Encoding
    Case tfUTF8
    'UTF-8のテキスト読み込み'
      With m_ADOStream
        .Charset = "UTF-8"
        'ストリームを開いてファイルをロードする'
        Call .Open
        Call .LoadFromFile(Me.Path)
        '1行づつテキストを読み込む'
        Do Until .EOS
          tmp = .ReadText(adReadLine)
          Call m_TextLines.Add(tmp, CStr(n))
          n = n + 1
        Loop
      End With
      '読み込みが終わったら閉じる'
      Call m_ADOStream.Close
    Case tfShiftJIS
    'Shift_JISのテキスト読み込み'
      Call readFromTextSteram(tfShiftJIS)
    Case tfUTF16
    'UTF-16のテキスト読み込み'
      Call readFromTextSteram(tfUTF16)
  End Select
End Sub

Private Sub readFromTextSteram(ByVal a_CharCode As TFCharCode)
  Set m_TextStream = m_FSO.OpenTextFile(FileName:=Me.Path, _
                                        IOMode:=ForReading, _
                                        Create:=False, _
                                        Format:=a_CharCode)
  Dim tmp As String
  Dim n As Long
  n = 1
  With m_TextStream
    Do Until .AtEndOfStream
      tmp = .ReadLine
      Call m_TextLines.Add(Item:=tmp, Key:=CStr(n))
      n = n + 1
    Loop
  End With
  Call m_TextStream.Close
End Sub

'Destructor'
Private Sub Class_Terminate()
  Set m_ADOStream = Nothing
  Set m_TextStream = Nothing
  Set m_TextLines = Nothing
End Sub

'Properties'
Public Property Get Path() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Path = m_Path
End Property

Public Property Let Path(ByVal a_Path As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  m_Path = a_Path
End Property

Public Property Get Encoding() As String
  Dim ret As String
  Select Case m_Encoding
    Case tfUTF8: ret = "UTF-8"
    Case tfShiftJIS: ret = "Shift_JIS"
    Case tfUTF16: ret = "UTF-16"
  End Select
  Encoding = ret
End Property

Public Property Get FileName() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Dim ret As String
  ret = m_Path
  Dim arr() As String
  arr = Split(ret, "\")  '"
  ret = arr(UBound(arr))
  FileName = ret
End Property

Public Property Get LinesCount() As Long
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  LinesCount = m_TextLines.Count
End Property

Public Property Let LineText(ByVal a_index As Variant, _
                             ByVal a_Text As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  If Not IsNumeric(a_index) Then Call raiseError(tfErrArgInvalid)
  If CLng(a_index) < 0 Or _
     CLng(a_index) > Me.LinesCount Then Call raiseError(tfErrArgInvalid)
  '既存のアイテムを削除してから追加する'
  Call m_TextLines.Remove(CStr(a_index))
  Call m_TextLines.Add(Item:=a_Text, _
                      Key:=CStr(a_index))
End Property

Public Property Get LineText(ByVal a_index As Variant) As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  If Not IsNumeric(a_index) Then Call raiseError(tfErrArgInvalid)
  If CLng(a_index) < 0 Or _
     CLng(a_index) > Me.LinesCount Then Call raiseError(tfErrArgInvalid)
  LineText = m_TextLines.Item(CStr(a_index))
End Property

'Methods'
Public Sub Append(ByVal a_Text As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Dim cnt As Long
  cnt = m_TextLines.Count
  Call m_TextLines.Add(Item:=a_Text, _
                       Key:=CStr(cnt + 1))
End Sub

Public Sub Save()
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Select Case m_Encoding
    'UTF-8'
    Case tfUTF8
      Call SaveAs(Me.Path)
    'Shif_JIS or UTF-16'
    Case tfShiftJIS
      Call SaveAs(Me.Path)
    Case tfUTF16
      Call SaveAs(Me.Path)
  End Select
End Sub

Public Sub SaveAs(ByVal a_Path As String)
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Select Case m_Encoding
    'UTF-8'
    Case tfUTF8
      Call writeUTF8TextFile(a_Path)
    'Shif_JIS or UTF-16'
    Case tfShiftJIS
      Call writeToTextStream(a_Path, tfShiftJIS)
    Case tfUTF16
      Call writeToTextStream(a_Path, tfUTF16)
  End Select
  '最新の状態で読み込み直しておく'
  Call Me.Init(a_Path, m_Encoding)
End Sub

Private Sub writeUTF8TextFile(ByVal a_Path As String)
  Dim createNew As SaveOptionsEnum
  If m_FSO.FileExists(a_Path) Then
    createNew = adSaveCreateOverWrite
  Else
    createNew = adSaveCreateNotExist
  End If
  Dim i As Long
  With m_ADOStream
    .Charset = "UTF-8"
    Call .Open
    For i = 1 To Me.LinesCount
      Call .WriteText(Data:=Me.LineText(CStr(i)), _
                      Options:=adWriteLine)
    Next
    Call .SaveToFile(a_Path, createNew)
    Call .Close
  End With
End Sub

Private Sub writeToTextStream(ByVal a_Path As String, _
                              ByVal a_CharCode As TFCharCode)
  Dim createNew As Boolean
  If m_FSO.FileExists(a_Path) Then
    createNew = False
  Else
    createNew = True
  End If
  Set m_TextStream = m_FSO.OpenTextFile(FileName:=a_Path, _
                                        IOMode:=ForWriting, _
                                        Create:=createNew, _
                                        Format:=a_CharCode)
  Dim i As Long
  With m_TextStream
    For i = 1 To Me.LinesCount
      Call .WriteLine(Me.LineText(CStr(i)))
    Next
    Call .Close
  End With
End Sub

'Raise Error'
Private Sub raiseError(ByVal a_ErrType As TFErrType)
  Call Err.Raise(Number:=ERR_NUMBER + a_ErrType, _
                 Description:=getErrMessage(a_ErrType))
  Call Err.Clear
End Sub

Private Function getErrMessage( _
             ByVal a_ErrType As TFErrType) As String
  Dim ret As String
  Select Case a_ErrType
    Case tfErrNotInitialized: ret = "Sorry, class has not initialized yet..."
    Case tfErrFileNotExist: ret = "Sorry, file not exists..."
    Case tfErrArgInvalid: ret = "Sorry,argument is invalid... "
  End Select
  getErrMessage = ret
End Function

とりあえず、以上。

おわりに

外部ライブラリは全部実行時バインディングにしてあるので、まるごとコピッペすれば使えます。

ただし、Newした後に、必ずInitメソッドを実行するようにしてください。

VBAには、有名な〝コンストラクタに引数渡せねえ〟問題があるので、ここだけは〝運用でカバー〟になってしまいます。

簡易版TextFileクラスを作った

簡易版TextFileクラスを作った

テキストファイルの扱いとか、FileSystemObjectTextStreamオブジェクトとか、ADODBオブジェクトあたりのことがよくわかっていないので、テキストファイルの中身を簡単に取得するためのクラスを作った。

クラスモジュールを触るのがめっちゃ久しぶりだったので、まあまあ苦戦した。

テキストファイルを読み込んで内容を保持するクラス

その名もEasyTextFileクラス。

機能は最小限にした。

テキストファイルのパスと文字コード(いちおう、Shift_JISUTF-8UTF-16の3種類に対応している。ただ、私は素人なので、文字コードのこととか、実はよくわかっていない。)

まあ、Scripting.FileSystemObjectオブジェクトとADODB.Streamオブジェクトをラップしているだけ。

リスト1

クラスモジュールEasyTextFile

Option Explicit

'設定用のテキストファイルを読み込むためだけに使うクラス'
'必要最小限の機能にとどめる'

'Public enums'
'Enumerations for Scripting.FileSystemObject object'
Public Enum TFCharCode
  tfShiftJIS = 0
  tfUTF8 = 1
  tfUTF16 = -1
'  tfUseDefault = -2'
End Enum

'Private enums'
'Enumerations for Scripting.FileSystemObject'
Private Enum IOMode
  ForReading = 1
  ForWriting = 2
  ForAppending = 8
End Enum

Private Enum Tristate
  TristateFalse = 0
  TristateTrue = -1
  TristateUseDefault = 2
End Enum

'Enumerations for error'
Private Enum TFErrType
  tfErrNotInitialized = 1
  tfErrFileNotExist
  tfErrArgInvalid
End Enum

'Constants'
Private Const ERR_NUMBER As Long = 10000

'Module level variables'
Private m_FSO As Object
Private m_TextStream As Object
Private m_ADOStream As Object
Private m_HasInitialized As Boolean

'Field variables'
Private m_Path As String
Private m_TextLines As Collection

'Constructor'
Private Sub Class_Initialize()
  Set m_FSO = CreateObject("Scripting.FileSystemObject")
  Set m_ADOStream = CreateObject("ADODB.Stream")
  Set m_TextLines = New Collection
End Sub

Public Sub Init(ByVal a_Path As String, _
                ByVal a_CharCode As TFCharCode)
  'If file not exists, raise error.'
  If Not m_FSO.FileExists(a_Path) Then
    Call raiseError(tfErrFileNotExist)
  End If
  m_Path = a_Path
  m_HasInitialized = True
  Dim tmp As String
  Dim n As Long
  n = 1
  Select Case a_CharCode
    Case tfUTF8
    'UTF-8のテキスト読み込み'
      With m_ADOStream
        .Charset = "UTF-8"
        Call .Open
        Call .LoadFromFile(Me.Path)
        Do Until .EOS
          tmp = .ReadText(adReadLine)
          Call m_TextLines.Add(tmp, CStr(n))
          n = n + 1
        Loop
      End With
      '読み込みが終わったら閉じる'
      Call m_ADOStream.Close
    Case tfShiftJIS
    'Shift_JISのテキスト読み込み'
      Call readFromTextSteram(tfShiftJIS)
    Case tfUTF16
    'UTF-16のテキスト読み込み'
      Call readFromTextSteram(tfUTF16)
  End Select
End Sub

Private Sub readFromTextSteram(ByVal a_CharCode As TFCharCode)
  Set m_TextStream = m_FSO.OpenTextFile(FileName:=Me.Path, _
                                        IOMode:=ForReading, _
                                        Create:=False, _
                                        Format:=a_CharCode)
  Dim tmp As String
  Dim n As Long
  n = 1
  With m_TextStream
    Do Until .AtEndOfStream
      tmp = .ReadLine
      Call m_TextLines.Add(Item:=tmp, Key:=CStr(n))
      n = n + 1
    Loop
  End With
  Call m_TextStream.Close
End Sub

'Destructor'
Private Sub Class_Terminate()
  Set m_ADOStream = Nothing
  Set m_TextStream = Nothing
  Set m_TextLines = Nothing
End Sub

'Properties'
Public Property Get Path() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Path = m_Path
End Property

Public Property Get FileName() As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  Dim ret As String
  ret = m_Path
  Dim arr() As String
  arr = Split(ret, "\") '"
  ret = arr(UBound(arr))
  FileName = ret
End Property

Public Property Get LinesCount() As Long
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  LinesCount = m_TextLines.Count
End Property

Public Property Get LineText(ByVal a_Index As Variant) As String
  If Not m_HasInitialized Then Call raiseError(tfErrNotInitialized)
  If Not IsNumeric(a_Index) Then Call raiseError(tfErrArgInvalid)
  If CLng(a_Index) < 0 Or _
     CLng(a_Index) > Me.LinesCount Then Call raiseError(tfErrArgInvalid)
  LineText = m_TextLines.Item(CStr(a_Index))
End Property

'Methods'

'Raise Error'
Private Sub raiseError(ByVal a_ErrType As TFErrType)
  Call Err.Raise(Number:=ERR_NUMBER + a_ErrType, _
                 Description:=getErrMessage(a_ErrType))
  Call Err.Clear
End Sub

Private Function getErrMessage( _
             ByVal a_ErrType As TFErrType) As String
  Dim ret As String
  Select Case a_ErrType
    Case tfErrNotInitialized: ret = "Sorry, class has not initialized yet..."
    Case tfErrFileNotExist: ret = "Sorry, file not exists..."
    Case tfErrArgInvalid: ret = "Sorry,argument is invalid... "
  End Select
  getErrMessage = ret
End Function

穴だらけなのだと思うけれど、一応エラー処理っぽいものも入れた。

使ってみる

準備

フォルダ内に、次の三つのテキストファイルを用意する。

f:id:akashi_keirin:20210912125544p:plain

上から順に、

このとおり。一つ目は、拡張子を.txtではなく、.ahoというわけのわからないものにしている。当然、中身はただのテキストファイルである。

f:id:akashi_keirin:20210912125546p:plain

ち~んwbyShiftJIS.txtを開いたところ。

f:id:akashi_keirin:20210912125549p:plain

ち~んwbyUTF8.txtを開いたところ。

f:id:akashi_keirin:20210912125551p:plain

ち~んw.ahoを開いたところ。

こんな感じ。

テキストファイルの内容をイミディエイトに出力するマクロ

たとえば、一つ目のち~んwbyShiftJIS.txtの内容をイミディエイトに書き出すコードは次の通り。

スト2
Private Sub test01()
  Dim etf As EasyTextFile
  Set etf = New EasyTextFile
  Dim flPath As String
'==================================================================='
  flPath = ActiveDocument.Path & "\ち~んwbyShiftJIS.txt '"
  Call etf.Init(flPath, tfShiftJIS)
'==================================================================='
  Debug.Print "Read from the file called """ & etf.FileName & """..."
  Dim i As Long
  For i = 1 To etf.LinesCount
    Debug.Print etf.LineText(i)
  Next
End Sub

===」で囲ったところで、ファイルの指定と文字コードの指定をしている。

二つ目のち~んwbyUTF8.txtなら、ここを

flPath = ActiveDocument.Path & "\ち~んwbyUTF8.txt"
Call etf.Init(flPath, tfUTF8)

にすりゃいいし、三つ目のち~んw.ahoなら、

flPath = ActiveDocument.Path & "\ち~んw.aho"
Call etf.Init(flPath, tfUTF8)

にするだけ。

実行結果

一つ目。

f:id:akashi_keirin:20210912125554p:plain

うむ。

二つ目。

f:id:akashi_keirin:20210912125556p:plain

ふむ。

f:id:akashi_keirin:20210912125558p:plain

むふふ。

バッチリである!

おわりに

特にWordなんかをVBAで動かすときには、処理用のデータをどこに置くかで困ることが多い。

私は、テキストファイルで外部化することが多いっす。

ドキュメントを量産するときに文字列を差し込む(Word)

ドキュメントを量産するときに文字列を差し込む(Word)

ドキュメントにデータを差し込むといえば、差し込み印刷機能を思い浮かべる人が多いと思うが、簡単なものならブックマーク機能を使ったら十分いける。

準備

前回

akashi-keirin.hatenablog.com

と同じドキュメント(笑)を使う。

その上で、次のようにブックマークを設定する。

f:id:akashi_keirin:20210912073352p:plain

f:id:akashi_keirin:20210912073354p:plain

f:id:akashi_keirin:20210912073357p:plain

これだけ。

ブックマーク部分に文字列を書き込むマクロ

前回記事のリスト1に手を加える。

リスト1
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)
'=========================================================='
  'ブックマーク箇所に文字列を書き込む'
  With templateDoc
    .Bookmarks("PersonNumber").Range.Text = psnNum
    .Bookmarks("SectionName").Range.Text = sectName
    .Bookmarks("PersonName").Range.Text = psnName
  End With
'=========================================================='
  '上書き保存して閉じる'
  Call templateDoc.Close(SaveChanges:=True)  '……(*)
End Sub

===」で挟んだ部分を追加し、(*)の部分を変えた。

[Bookmarks]("index").Rangeで、ブックマークした部分のRangeオブジェクトが取得できるので、そのTextプロパティに値をセットしてやればよい。

これで、あたかもブックマーク部分に文字列を差し込んだかのような効果が得られるのである!

使ってみる

f:id:akashi_keirin:20210912073400p:plain

f:id:akashi_keirin:20210912073402p:plain

f:id:akashi_keirin:20210912073405p:plain

f:id:akashi_keirin:20210912073410g:plain

万全。

おわりに

[Bookmark]RangeオブジェクトのTextプロパティを直接書き換えると、ブックマークは消失します。

新しくできたドキュメントを汚さないという意味では便利なのかも知れませんが、これがありがたいことなのかどうか、よくわかりません。

あと、やっとWordのRangeオブジェクトがちょっとわかってきたような気もします。気のせいでしょうけど。

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

[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というドキュメントが入っている。(上の「元になるドキュメント(笑)」のことね。)

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

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

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

これだけ。

リスト1
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)


段落の末尾に文字列を追加する(Word)

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

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

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

f:id:akashi_keirin:20210905110949p:plain

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

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

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

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

ActiveDocument.Paragraphs(1).Range.InsertAfter("ち~んw")

f:id:akashi_keirin:20210905110951p:plain

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

f:id:akashi_keirin:20210905110954p:plain

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

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

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

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

ActiveDocument.Paragraphs(2).Range.InsertBefore("ち~んw")

f:id:akashi_keirin:20210905110957p:plain

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

結果は……。

f:id:akashi_keirin:20210905111000p:plain

ち~んw

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

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

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

リスト1
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("ち~んw")
End Sub

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

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

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

f:id:akashi_keirin:20210905111003p:plain

やっとできた。

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

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

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

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

スト2
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("ち~んw")
End Sub

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

実行すると、

f:id:akashi_keirin:20210905111114p:plain

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

おわりに

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

まさに、〝男坂〟……。

f:id:akashi_keirin:20210905111615p:plain

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

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

ちょっとした覚書。

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

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

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

  • Range
  • Type
  • Text
  • PreserveFormatting

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

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

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

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

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

リスト1
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」以外の部分を書いた。

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

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

実行結果

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

f:id:akashi_keirin:20210823085917p:plain

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

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

f:id:akashi_keirin:20210823085914p:plain

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

おわりに

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

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

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

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

ソースコード

リスト1
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

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

スト2
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