文書の「作成者」を書き換える（Word）
文書情報を書き換える
BuiltInDocumentPropertiesプロパティ
私は、Microsoftアカウントを、実にふざけた名前で登録してしまっている。
だから、自宅のPCで作成したドキュメントをもとに、仕事で使うドキュメントを作成したときなんかには、「作成者」とか「最終更新者」のところに、非常に恥ずかしい名前が表示されてしまって困る。
まあ、そもそも「ファイル」タブをクリックして、「情報」を確認するような人は、わが業界にはほとんどいないので、バレることも滅多にないのであるが！
「作成者」を書き換える
「作成者」を表すDocumentPropertyオブジェクトを取得する
「作成者」を書き換えるには、まず、「作成者」を表すオブジェクトを取得せねばならない。
それは、DocumentPropertyオブジェクトである。
そして、それは[Document].BuiltInDocumentPropertiesプロパティから取得する。
簡単に言うと、
DocumentオブジェクトのBuiltInDocumentPropertiesプロパティから、BuiltInDocumentPropertiesコレクションオブジェクトを取得する！BuiltInDocumentPropertiesコレクションオブジェクトのItemプロパティから、「作成者」を司るDocumentPropertyオブジェクトを取得する！
こういうことである！
とりあえず、「オブジェクト ブラウザー」様によると、
ということなので、[Document].BuiltInDocumentPropertiesコレクションのItem(Index)プロパティで、「Index」に適当な値を渡してやればいい。
「作成者」の場合は、「"Author"」という文字列か、またはwdPropertyAuthor（WdBuiltInProperty列挙体のメンバ）を渡す。
そうすると、ItemプロパティがDocumentPropertyオブジェクトを返す、というしくみ。
DocumentPropertyオブジェクトのValueプロパティを書き換える
DocumentPropertyオブジェクトを取得しさえすれば、これは簡単。
Valueプロパティを書き換えるだけ。
リスト１
Private Sub test01()
Dim tgtDoc As Document
Set tgtDoc = ActiveDocument
tgtDoc.BuiltInDocumentProperties.Item("Author") = "TopSecret"
End Sub
「作成者」を「TopSecret」に書き換えるだけのマクロ。
こいつを、先の恥ずかしいドキュメントをアクティヴにして実行すると、
当然こうなる。
おわりに
これで、「作成者」欄に恥ずかしいアカウント名が刻印されたドキュメントが大量にあったとしても、簡単にクレンジングできる。
しかし、「最終更新者」はこの方法ではだめなんだよなあ……。
CharacterUnitFirstLineIndentプロパティ、おまえだったのか……（Word）
CharacterUnitFirstLineIndentプロパティ、おまえだったのか。いつもくりをくれたのは。
ついさきほど、
こんなことを書いたところだが、マルちゃん麺づくりばりにあっさり解決したので、報告。
CharacterUnitFirstLineIndentプロパティというものがある
テキトーにぐぐっていたら、
こんなのを見つけた。
コメント欄の「3.」に曰く、
通りすがりの者です。
もう解決済みかと思いますが、たまたま私も同じ問題に遭遇し悩んでおりましたので。
私の場合は、.CharacterUnitFirstLineIndent = 0 .FirstLineIndent = nとすることで設定値が反映されました。
上記の処理順が逆の場合や、CharacterUnitFirstLineIndentに0以外の値が設定されている場合はこちらが優先され、FirstLineIndentは変更できないような挙動でした。
ご参考になれば幸いです。
なにーーーー！ CharacterUnitFirstLineIndentだとーーー！
それもう、名前からしてモロに〝字数単位で指定している1行目のインデント〟のことじゃないっすかーーー！
コードの書き換え
で、前回のリスト1を次のように書き換える。
リスト１
Public Sub OffFirstLineIndent()
With Selection.ParagraphFormat
If .CharacterUnitFirstLineIndent <> 0 Then
.CharacterUnitFirstLineIndent = 0
End If
.FirstLineIndent = 0
End With
End Sub
もう、見てのとおり、CharacterUnitFirstLineIndentプロパティの値が「0以外の値」だったら「0」にしてから、FirstLineIndentプロパティの値を「0」にしてやるのだ！
うむ！ 万全である！
実行してみる
ははは！ 完璧ではないか！
おわりに
ichitnkさん、ありがとうございました！
字下げインデントを解除できない？（Word）
字下げインデントを解除できない？
実に不可思議な現象に出くわしたのでメモ。
なお、未解決である。
字下げインデントを解除する方法
段落の字下げインデントを司っているのは、ParagraphFormatオブジェクトのFirstLineIndentプロパティ。
理屈の上では、コイツの値を0にしてやれば、字下げインデントなしの状態にできるはずである。
そこで、カーソルのある段落の字下げインデントを解除するためのコードは次のようになる。
リスト１
Public Sub OffFirstLineIndent() Selection.ParagraphFormat.FirstLineIndent = 0 End Sub
これで万全のはずである。
一点の曇りもない。
いざ、実行！
満を持して、実際のドキュメントで試してみる。
いかがであろうか。
1段落目（「ビデオを使うと、」で始まる段落）では無反応なのに、2段落目（「Word に用意されている」で始まる段落）では、意図どおり字下げが解除されている。
おい、誰やねん。
プログラムは書いたとおりに動く！
とかほざいたやつは。
1段落目と2段落目の違い
実は、1段落目と2段落目は、字下げインデントの指定の仕方がちょっとだけ違うのである。
画像でお見せしよう。
おわかりだろうか。
1段落目が、字下げインデントの幅を「1 字」と文字数単位で指定しているのに対し、2段落目では「3.7 mm」とミリ単位で指定しているのである。（「3.7 mm」は、10.5ポイントの1字分の近似値。）
結論
どうも、
字下げインデントの幅が〝字数単位〟で指定されているとき（まあ、日本語環境なら普通そうすると思いますが。）には、VBAで字下げ幅等（ぶら下げインデントにするときは、
FirstLineIndentの値をマイナスにする。）を設定することができないっぽい。
おわりに
これは、実に困ったことである。
なんでVBAでクラスモジュールを使うのか
なんでVBAでクラスモジュールを使うのか
基本的には標準モジュールで十分
プログラムを書くときに、モノとして扱った方が楽な場合がある。
モノの機能だけが欲しいのなら、標準モジュールでいい。
機能のまとまりを表す名前を付けて、その中にメソッドをまとめておくのである。
たとえば、ユーザに選ばせたフォルダのフォルダパスを取得するという処理がある。
FileDialogオブジェクトを使う処理だが、毎回いちいちFileDialogオブジェクトを取得してフォルダパスを返す処理を書くのはめんどくさい。 だから、FileDialogオブジェクトをラップしたメソッドを書く。
Option Explicit
Private m_FSO As Object
Public Function GetSelectedFolderPath( _
Optional ByVal a_DefaultDir As String, _
Optional ByVal a_Title As String) As String
If m_FSO Is Nothing Then Set m_FSO = CreateObject("Scripting.FileSystemObject")
Dim ret As String
ret = ""
'第１引数省略なら最初に表示するディレクトリをこのブックのある'
'ディレクトリにする '
If a_DefaultDir = "" Then _
a_DefaultDir = ThisWorkbook.Path
If Not m_FSO.FolderExists(a_DefaultDir) Then _
a_DefaultDir = ThisWorkbook.Path
Dim folderPath As String
Dim isSelected As Boolean
Dim folderPicker As FileDialog
Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With folderPicker
.InitialFileName = a_DefaultDir
If a_Title <> "" Then
.Title = a_Title
Else
.Title = "フォルダ選択"
End If
isSelected = .Show
If isSelected Then
ret = .SelectedItems(1)
Else
ret = ""
End If
End With
GetSelectedFolderPath = ret
End Function
このように、たとえばFileDialogUtilという標準モジュールに、GetSelectedFolderPathというメソッドを作っておくと、あとは、
Dim rootDir As String rootDir = FileDialogUtil.GetSelectedFolderPath
というコードを書くだけで、〝ユーザが選択したフォルダのフルパスを取得する〟という処理が書けるようになる。
この調子で、FileDialogオブジェクトを利用する処理を、標準モジュールFileDialogUtilにまとめておくと、以後プログラムを書くのが非常に楽になる。
このように、FileDialogというモノが使いたい場合でも、機能が欲しいだけなら標準モジュールで十分である。
〝運用でカバー〟的にはなるが、〝メソッド呼び出し時には、必ずモジュール名を記述する〟というルールで用いれば、〝静的クラス〟のような使い方ができる。
クラスモジュールを使いたくなるとき
では、どういうときにクラスモジュールを使いたくなるか。
上記FileDialogUtilでは、モノ自体、つまり利用しようとするFileDialogオブジェクト自体には〝個性〟はなくてもよかった。
利用するFileDialogは、いついかなるときでも〝タダのFileDialogオブジェクト〟なのであって、色も味も身長も体重も、一切の特徴がない〝タダのFileDialogオブジェクト〟である。
それに対して次のような場合はどうか。
〝ある〟テキストファイルをプログラムの中でモノのように扱いたい。
このような場合である。
「〝ある〟テキストファイル」なので、そのモノには個性がある。
〝その〟テキストファイルのファイルパスであったり、〝その〟テキストファイルの内容（要するにテキストデータ）であったり、トータルの行数であったり。
だいたい、プログラムの中でテキストファイルを扱いたいという場合、〝テキストファイルの機能〟を使いたい、という場合はないと思う。（そんな状況は、想像できない。）
〝ある〟具体的なテキストファイルの各行のデータを利用したい。
このような場面のはずである。
そうすると、たとえば、
行数を指定したら、その行のテキストを返してくれたり、全行数を尋ねたら行数を答えてくれたり、指定した行にテキストを挿入したり、……というふうに振る舞ってくれるオブジェクト
があったら、非常に便利なはずである。
しかしながら、デフォルトではそのように振る舞ってくれる便利なオブジェクトは存在しない。
このようなときにクラスモジュールを使いたくなる。
上記の例でいえば、
ファイルパスや指定した行のテキストデータの内容なんかを問い合わせたら、それに応じた値を返してくれて、データを書き加えたり、書き換えたり、削除したり、上書き保存したりすることを命令したら、そのように実行してくれるオブジェクト
を自作するのである。
標準モジュールにメソッドを書いて上記の処理を実現しようと思ったら、必要になるその都度、そのメソッドに当該テキストファイルのフルパスを渡す必要がある。（テキストファイルをテキストファイルというモノとして変数に入れて保持する方法がないのだから、当たり前である。）テキストファイルを開き、読み込んだり書き込んだりする処理自体はまとめておくことができるものの、この〝テキストファイルのフルパスを渡す〟という手順自体は（基本的に）飛ばすことができない。
たとえば、テキストファイルのフルパスと行番号を渡して、当該テキストファイルの当該行のテキストを取得するGetTextData(FilePath As String, LineNumber As Long)というメソッドがあったとする。
そうして、たとえば変数tmpに、そのテキストファイルの3行目と5行目のテキストを結合して代入したい場合、次のようなコードを書くことになる。
Dim tmp As String
tmp = GetTextData("X:\hoge\hoge.txt", 3) & GetTextData("X:\hoge\hoge.txt", 5)
これは非常にめんどくさい上、直感的でない。〝テキストファイルそのもの〟を指し示すオブジェクトが（基本的には）ないので、毎度毎度当該テキストファイルのフルパスを指定することになる。（もちろん、Scripting.TextStreamオブジェクトを使うとか、一旦読み込んだテキストファイルの内容を配列に入れてしまうとか、方法はある。）
その点、たとえば、次のような機能を持ったEasyTextFileというクラスがあったとする。
Pathプロパティは、そのテキストファイルのフルパスを表す。Item(LineNumber)メソッドは、指定した行（引数LineNumber）にあるテキストデータを返す。
そうすると、上記「変数tmpに、そのテキストファイルの3行目と5行目のテキストを結合して代入」するという処理は、次のようなコードで書ける。
Dim etf As New EasyTextFile etf.Path = "X:\hoge\hoge.txt" Dim tmp = String tmp = etf.Item(3) & etf.Item(5)
処理の例が単純なので、有難味を感じにくいかも知れないが、ここで用いた「hoge.txt」のデータをプログラム内で参照する回数が増えるほど、恩恵を感じやすくなるはずである。 特に、一つのプログラム内で複数種類のテキストファイルを取り扱わなければならない場合に、より一層便利に感じるはずである。 たとえば、メールを自動で作成するプログラムで、
- 宛名人に関するデータをRecipient.txtから
- 差出人に関するデータをSender.txtから
- 本文に関するデータをMailBody.txtから
それぞれ取り出して使うとする。
上記クラスモジュールEasyTextFileを用いるなら、たとえば、それぞれ
recipientDatasenderDatabodyData
のように、役割明示的な変数名を付けてインスタンス化すれば、かなりコードの可読性が上がるはずである。
結論
〝個性のあるモノ〟をプログラム内で扱いたいときに、クラスモジュールを使いたくなる。
おわりに
素人の感想です。
EasyTextFileクラスは今……
EasyTextFileクラスは今……
クラスモジュールのコード
ただ、クラスモジュールのコードを晒すだけ……。
たぶん、盛大にヌケやモレがあると思うし、そもそもTextStreamオブジェクトのこととかADOSteramオブジェクトのことをろくに理解もせずに、手探りで書いたようなコードなので、ツッコミどころだらけだと思う。
達人の皆さんのご指南を仰ぎたく思う。
リスト１ クラスモジュール：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メソッドを実行するようにしてください。
簡易版TextFileクラスを作った
簡易版TextFileクラスを作った
テキストファイルの扱いとか、FileSystemObjectのTextStreamオブジェクトとか、ADODBオブジェクトあたりのことがよくわかっていないので、テキストファイルの中身を簡単に取得するためのクラスを作った。
クラスモジュールを触るのがめっちゃ久しぶりだったので、まあまあ苦戦した。
テキストファイルを読み込んで内容を保持するクラス
その名もEasyTextFileクラス。
機能は最小限にした。
テキストファイルのパスと文字コード（いちおう、Shift_JIS、UTF-8、UTF-16の3種類に対応している。ただ、私は素人なので、文字コードのこととか、実はよくわかっていない。）
まあ、Scripting.FileSystemObjectオブジェクトとADODB.Streamオブジェクトをラップしているだけ。
リスト１
クラスモジュール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
穴だらけなのだと思うけれど、一応エラー処理っぽいものも入れた。
使ってみる
準備
フォルダ内に、次の三つのテキストファイルを用意する。
上から順に、
このとおり。一つ目は、拡張子を.txtではなく、.ahoというわけのわからないものにしている。当然、中身はただのテキストファイルである。
ち～んｗbyShiftJIS.txtを開いたところ。
ち～んｗbyUTF8.txtを開いたところ。
ち～んｗ.ahoを開いたところ。
こんな感じ。
テキストファイルの内容をイミディエイトに出力するマクロ
たとえば、一つ目のち～んｗbyShiftJIS.txtの内容をイミディエイトに書き出すコードは次の通り。
リスト２
Private Sub test01() Dim etf As EasyTextFile Set etf = New EasyTextFile Dim flPath As String '===================================================================' flPath = ActiveDocument.Path & "\ち～んｗbyShiftJIS.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
「===」で囲ったところで、ファイルの指定と文字コードの指定をしている。
二つ目のち～んｗbyUTF8.txtなら、ここを
flPath = ActiveDocument.Path & "\ち～んｗbyUTF8.txt" Call etf.Init(flPath, tfUTF8)
にすりゃいいし、三つ目のち～んｗ.ahoなら、
flPath = ActiveDocument.Path & "\ち～んｗ.aho" Call etf.Init(flPath, tfUTF8)
にするだけ。
実行結果
一つ目。
うむ。
二つ目。
ふむ。
むふふ。
バッチリである！
おわりに
特にWordなんかをVBAで動かすときには、処理用のデータをどこに置くかで困ることが多い。
私は、テキストファイルで外部化することが多いっす。
ドキュメントを量産するときに文字列を差し込む（Word）
ドキュメントを量産するときに文字列を差し込む（Word）
ドキュメントにデータを差し込むといえば、差し込み印刷機能を思い浮かべる人が多いと思うが、簡単なものならブックマーク機能を使ったら十分いける。
準備
前回
と同じドキュメント（笑）を使う。
その上で、次のようにブックマークを設定する。
これだけ。
ブックマーク部分に文字列を書き込むマクロ
前回記事のリスト１に手を加える。
リスト１
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プロパティに値をセットしてやればよい。
これで、あたかもブックマーク部分に文字列を差し込んだかのような効果が得られるのである！
使ってみる
万全。
おわりに
[Bookmark]RangeオブジェクトのTextプロパティを直接書き換えると、ブックマークは消失します。
新しくできたドキュメントを汚さないという意味では便利なのかも知れませんが、これがありがたいことなのかどうか、よくわかりません。
あと、やっとWordのRangeオブジェクトがちょっとわかってきたような気もします。気のせいでしょうけど。
