中途半端に規則的な数列
中途半端に規則的な循環数列を簡単に実現する
Excelで座席表なんかを作る場合を想定。
表示用シートに
こんな枠を作っておいて、VLOOKUPなんかで
こういったデータ用シートから値を引っ張ってくる。
各座席の左上のセルに番号を入力したら、必要なデータが残りの３セルに返るようにしてある。
番号を全部手入力するなら、これで十分だが、たとえば
番号をシャッフルして番号入力用セルに自動で入力させたいなあ！
という欲求がしばしば湧き上がってくる。
そうすると、番号入力用セルの位置を一般化する必要がある。
行番号の割り出しは簡単
上の画像の場合だと、行番号の割り出しは簡単だ。
「3,6,9,12,15」というだけなので、単なる「初項3、公差3の等差数列」に過ぎない。たとえば、「ret = (i - 1) * 3 + 3」とでも書けばオッケー。
このぐらいなら、特にコメントを残しておかなくても見たらわかるレベルだろう。
列番号の割り出しは結構めんどくさい
問題は列番号の方だ。
上の画像の場合だと、「2,4,7,9,12,14」を繰り返す必要がある。
頭のいい人だと一般項がパッとわかったりするのだろうけど、凡人の身にはなかなかむつかしいし、仮に頑張って一般化したところで、後で見たときに「これ、何がしたかったんだっけ？」となること必定。
定数と配列を使う
で、次のようなアイディアを考えた。
ひとまずコードをご覧に入れよう。
座席表の枠を作成したシートのモジュールに次のコードを書いた。
リスト１ シートモジュール
Option Explicit
Private Const COLUMN_NUMBERS As String = _
"2 4 7 9 12 14" '……(1)'
Private Const MAX_NUMBER As Long = 30
Private Function getColumnNumber( _
ByVal number As Long) As Long
Dim ret As Long
ret = -1
If number < 1 Or _
number > MAX_NUMBER Then GoTo Finalizer '……(2)'
On Error GoTo Finalizer
Dim ar() As String '……(3)'
ar = Split(COLUMN_NUMBERS)
Dim columnsCount As Long
columnsCount = UBound(ar) + 1 '……(4)'
Dim targetIndex As Long
targetIndex = (number - 1) Mod columnsCount '……(5)'
ret = CLng(ar(targetIndex)) '……(6)'
Finalizer:
getColumnNumber = ret
End Function
まず、(1)の
Private Const COLUMN_NUMBERS As String = _
"2 4 7 9 12 14"
で、欲しい数列を文字列としてジカ書きして定数にしておく。
Splitでバラすために半角スペースで区切っている。こうしておくとSplitの第２引数を省略することができるので便利。
まあ、身も蓋もないやり方ｗ
(2)の
If number < 1 Or _ number > MAX_NUMBER Then GoTo Finalizer
はガード節。
座席表は30席まで対応なので、対象外の数字が渡されたら抜ける。冒頭でretに-1を代入しているので、対象外の数字が渡されたときはあり得ない数字が返るしくみ。
(3)の
Dim ar() As String ar = Split(COLUMN_NUMBERS)
で、定数にした「"2 4 7 9 12 14"」をバラして配列にし、arにぶち込む。
後は、配列から必要な要素を取り出すだけなのだが、その前に(4)の
columnsCount = UBound(ar) + 1
で配列の要素数を求めておく。
今回の場合要素数は6に決まっているので、COLUMN_NUMBERS同様定数にするという手もあるが、今後COLUMN_NUMBERSの内容が変わったときに併せて書き換える手間が生ずるのでこのようにした。
(5)の
targetIndex = (number - 1) Mod columnsCount
で配列のどの要素を取り出すのかを決定。
次の(6)の式の中に埋め込んでしまうという手もあるが、後でわかりやすいようにあえてこのようにした。
1番目なら配列の添字は「0」、6番目なら配列の添字は「5」、7番目なら配列の添字は「0」、12番目なら配列の添字は「5」、13番目なら配列の添字は「0」、……という風になる。
後は(6)の
ret = CLng(ar(targetIndex))
で取り出した配列の要素をLong型に変換して返す。型変換はしなくてもVBAが勝手にやってくれるんだが、できる限り暗黙の型変換で済ませないように心がけている。
実行
引数numberにいろいろな数値を指定して実行。
バッチリ。
おわりに
こういう身も蓋もない方法も悪くないと思う。
標準モジュールのPropertyとは
標準モジュールのPropertyとは
標準モジュールにもPropertyを生やすことができる。
では、標準モジュールのPropertyとFunctionは何が違うのだろうか。
Fucntionならば、同名のPublicなものが他のモジュールにない限りはメソッド名だけで呼び出せる。Propertyというぐらいだから、[モジュール名].Property名の形でしか呼び出せない、とかなら便利なんだが。
比較
標準モジュールを用意し、オブジェクト名をProvokeにする。
ユーザーをいらだたせる機能をあつめたモジュールにするのだ。
リスト１ 標準モジュール Provoke
Option Explicit Public Enum ProvokeMessageType pmtAtype pmtBtype pmtCtype End Enum Public Property Get PropMessage( _ ByVal msgType As ProvokeMessageType) As String Dim ret As String ret = getMessage(msgType) PropMessage = ret End Property Public Function FuncMessage( _ ByVal msgType As ProvokeMessageType) As String Dim ret As String ret = getMessage(msgType) FuncMessage = ret End Function Private Function getMessage( _ ByVal msgType As ProvokeMessageType) As String Dim ret As String Select Case msgType Case pmtAtype: ret = "（ ´_ゝ｀）ﾌｰﾝ" Case pmtBtype: ret = "（ ´,_ゝ｀）ﾌﾟｯ" Case pmtCtype: ret = "(ﾟДﾟ)ﾊｧ?" Case Else: ret = "ち～んｗ" End Select getMessage = ret End Function
まったく同じ処理内容の「PropMessage」プロパティと、「FuncMessage」メソッドを置いた。
本来、このようなハンガリアン的な命名は嫌いなんだが、今回はPropertyとFunctionの比較のためなのでガマン。
使ってみる
新たに標準モジュールを挿入し、別モジュールから使用を試みる。
リスト２ 標準モジュール
Option Explicit Private Sub testProvokeModule() Call MsgBox(PropMessage(pmtAtype)) Call MsgBox(FuncMessage(pmtBtype)) End Sub
ちなみに、入力中の様子は
このとおり。
イヤーな予感……。
これ、もしかしてuniqueなProperty名なら、モジュールを指定しなくても呼び出せちゃうのか……？
実行
リスト２を実行してみると……。
フツーに呼び出せてんじゃん……。
おわりに
ますますPropertyとFunctionの違いがわからなくなってしまったじゃねえか。
全VBAerのみなさんへ。
思わせぶりなタイトルで書いてしまってすみません。
真摯に反省してま～す。
TextFileクラスの改良
TextFileクラスの改良
「改良」なのかどうかはわからんが。
ちなみに、元祖TextFileクラスについては、
コチラをどうぞ。
改良後のTextFileクラス
リスト１ クラスモジュール
'オブジェクト名はTextFile' Option Explicit 'Constants' Private Enum ErrorTypes '……(**)' etFileNotFound = 1 etLineNotExists etNotInitialized etErrorOccurred End Enum 'Module Level Variables' Private isInitialized As Boolean Private fileFullName As String Private line_() As String Private fsObj As FileSystemObject 'Properties' Public Property Get Line(ByVal numberOf As Long) As String Const ERR_SOURCE As String = _ "TextFile Class, Property Get Line" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) Dim ret As String '存在しない行番号を指定していたらエラー。' If UBound(line_) + 1 < numberOf Or _ numberOf < 0 Then _ Call raiseError(etLineNotExists, ERR_SOURCE) On Error GoTo ErrorHandler ret = line_(numberOf - 1) Line = ret Exit Property ErrorHandler: '何かしらエラーが出たら、イミディエイトに情報を表示して中断。' Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Property Public Property Get LineCount() As Long Const ERR_SOURCE As String = _ "TextFile Class, Property Get LineCount" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) On Error GoTo ErrorHandler Dim ret As Long If IsEmpty(line_) Then ret = 0: GoTo Finalizer ret = UBound(line_) + 1 Finalizer: LineCount = ret Exit Property ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Property 'Constructor' Private Sub Class_Initialize() isInitialized = False Set fsObj = New FileSystemObject End Sub Public Sub init(ByVal targetFullName As String) Const ERR_SOURCE As String = _ "TextFile class,init Method" '対象ファイルの存否確認。なければエラー。' If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, "TextFile Class, init Method") On Error GoTo ErrorHandler 'モジュールレベル変数に対象ファイルのフルパスを保存' fileFullName = targetFullName 'テキストファイルからデータを取得' line_ = getLines(targetFullName) isInitialized = True Exit Sub ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Sub 'テキストファイル読み込み' Private Function getLines( _ ByVal targetFullName As String) As String() Const ERR_SOURCE As String = _ "TextFile class, getLines Method" On Error GoTo ErrorHandler Dim ret() As String Dim n As Long n = 0 ReDim ret(n) Dim txtStream As Scripting.TextStream Set txtStream = fsObj.OpenTextFile( _ FileName:=targetFullName, _ IOMode:=ForReading, _ Create:=False) Do ret(n) = txtStream.ReadLine '最終行まで読み込んだらExit' If txtStream.AtEndOfLine Then Exit Do n = n + 1 ReDim Preserve ret(n) Loop Call txtStream.Close Set txtStream = Nothing line_ = ret getLines = line_ Exit Function ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Function 'Destructor' Private Sub Class_Terminate() Set fsObj = Nothing End Sub 'Methods' Public Sub regetData(Optional ByVal targetFullName As String) Const ERR_SOURCE As String = _ "TextFile Class, regetData Method" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) If targetFullName = "" Then GoTo MainProcess If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, ERR_SOURCE) '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする' fileFullName = targetFullName MainProcess: On Error GoTo ErrorHandler Erase line_ Call Me.init(fileFullName) Exit Sub ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Sub 'データ書き換え' '……(*)' Public Sub setData(ByVal targetLine As Long, _ ByVal targetData As String) Const ERR_SOURCE As String = _ "TextFile Class, setData Method" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) Dim ret As String '存在しない行番号を指定していたらエラー。' If targetLine < 1 Or _ UBound(line_) + 1 < targetLine Then _ Call raiseError(etLineNotExists, ERR_SOURCE) On Error GoTo ErrorHandler 'メインの処理' line_(targetLine - 1) = targetData Dim txtStream As Scripting.TextStream Set txtStream = fsObj.OpenTextFile( _ FileName:=fileFullName, _ IOMode:=ForWriting, _ Create:=False) Dim i As Long For i = 0 To UBound(line_) Call txtStream.WriteLine(line_(i)) Next Call txtStream.Close Set txtStream = Nothing Exit Sub ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Sub 'エラー発生用' Private Sub raiseError(ByVal typeOfError As ErrorTypes, _ Optional ByVal errorSource As String) Dim msg As String msg = getErrorMessage(typeOfError) Call Err.Raise(Number:=10000 + typeOfError, _ Source:=errorSource, _ Description:=msg) End Sub Private Function getErrorMessage( _ ByVal typeOfError As ErrorTypes) As String '……(***)' Const ERR_SOURCE As String = _ "TextFile class, getErrorMessage Method" On Error GoTo ErrorHandler Dim ret As String Select Case typeOfError Case etFileNotFound ret = "The file you specified isn't found." Case etLineNotExists ret = "This file doesn't have so many lines." Case etNotInitialized ret = "You must run ""init"" method!" Case etErrorOccurred ret = "Some Error has occurred" End Select getErrorMessage = ret Exit Function ErrorHandler: Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Function
メソッドを一つ追加した(*)ことに伴い、列挙体の要素を増やし(**)、エラーメッセージのパターンも増やした(***)。
setDataメソッド
Public Sub setData(ByVal targetLine As Long, _
ByVal targetData As String) '……(1)'
Const ERR_SOURCE As String = _
"TextFile Class, setData Method"
'initメソッド未実行ならエラー。' '……(2)'
If Not isInitialized Then _
Call raiseError(etNotInitialized, ERR_SOURCE)
Dim ret As String
'存在しない行番号を指定していたらエラー。' '……(3)'
If targetLine < 0 Or _
UBound(line_) + 1 < targetLine Then _
Call raiseError(etLineNotExists, ERR_SOURCE)
On Error GoTo ErrorHandler
'メインの処理'
line_(targetLine - 1) = targetData '……(4)'
Dim txtStream As Scripting.TextStream '……(5)'
Set txtStream = fsObj.OpenTextFile( _
FileName:=fileFullName, _
IOMode:=ForWriting, _
Create:=False)
Dim i As Long '……(6)'
For i = 0 To UBound(line_)
Call txtStream.WriteLine(line_(i))
Next
Call txtStream.Close '……(7)'
Set txtStream = Nothing
Exit Sub
ErrorHandler:
Debug.Print "Number : " & Err.Number
Debug.Print "Description : " & Err.Description
Call raiseError(etErrorOccurred, ERR_SOURCE)
End Sub
まず(1)の
Public Sub setData(ByVal targetLine As Long, _
ByVal targetData As String)
で引数の設定。
targetLineで何行目のデータを書き換えるのかを指定し、targetDataで書き換えるデータを指定する。
(2)の２行（実質１行）
If Not isInitialized Then _
Call raiseError(etNotInitialized, ERR_SOURCE)
はガード節。
擬似コンストラクタinitメソッドの末尾に
isInitialized = True
があり、Module LevelのisInitializedをTrueにするようにしている。こうすることで擬似コンストラクタinitメソッドの実行を強制している。
(3)の３行（実質１行）もガード節。
If targetLine < 1 Or _ UBound(line_) + 1 < targetLine Then _ Call raiseError(etLineNotExists, ERR_SOURCE)
このメソッドでは、既にある行のデータを書き換えることを想定しているので、元のテキストファイルの行数を超える行番号は指定できないようにしている。もちろん、0行目とか、負の数行目もあり得ないので、ここで弾く。
不正な引数とか、あり得ない操作については、このようにメソッド冒頭で弾いてしまう、という「ガード節」の考え方が気に入っている。good mannerだと思う。
テキストファイルにデータを追記するために、次はappendDataメソッドを作る必要があるかもしれない。
ここまで来たら、ほぼ安全なので、メインの処理に移る。
(4)の
line_(targetLine - 1) = targetData
で、元のテキストファイルの各行のデータを保持したModule Levelの配列line_()の書き換え対象データを書き換える。
行番号と配列の添字がずれるのはイマイチなので、今にして思えば配列を1はじまりにした方が良かったかもしれない。このTextFileクラスのLineプロパティはItemみたいなものなのだから……。
まあ、「1ずれる」という部分は、クラスモジュール内に隠蔽してしまっているので、利用する側は何も困らないのだけれど。これもオブジェクト指向の強みだね。
次に、(5)からの５行（実質２行）
Dim txtStream As Scripting.TextStream
Set txtStream = fsObj.OpenTextFile( _
FileName:=fileFullName, _
IOMode:=ForWriting, _
Create:=False)
でScripting.TextStreamオブジェクトを準備する。
OpenTextFileメソッドの引数IOModeをForWritingにしているので、書き込みモードだ。
Scripting.TextStreamオブジェクトについては、詳しくはコチラをどうぞ。とにかく、テキストファイルの読み書きを行うときには、TextStreamオブジェクトを通して行う、ぐらいの理解で良いと思う。
これで、TextStreamクラスのインスタンスtxtStreamが用意できたので、コイツを通じてテキストファイルを操作することができる。
あとは、(6)からの４行
Dim i As Long For i = 0 To UBound(line_) Call txtStream.WriteLine(line_(i)) Next
で配列line_()の各要素を１行目から最終行まで書き込む。
変更していない行まで書き込みし直すのは無駄な気がするけれど、仕方ない。
指定した行だけを書き換える方法ってあるのかな？？？ あったら誰か教えてくだされ。
最後に(7)の
Call txtStream.Close
でtxtStream（テキストファイルとの接続？）を閉じておしまい。
実験
このプロジェクトと同じフォルダ内に、test.txtというテキストファイルを置き、内容を
にしておく。相変わらずアホな内容ですまん。
次のコードを標準モジュールに書く。
リスト２ 標準モジュール
Private Sub testTextFileClass()
Dim targetPath As String
targetPath = ThisDocument.Path & "\" & "test.txt" '"
Dim txtFile As TextFile
Set txtFile = New TextFile
Call txtFile.init(targetPath)
Dim ar() As String
Dim i As Long '……(1)'
For i = 1 To txtFile.LineCount
Debug.Print txtFile.Line(i)
Call WindowsAPI.waitFor(300)
Next
Debug.Print "3行目を書き換えるよ。" '……(2)'
Call txtFile.setData(3, "ち～んｗ")
Call WindowsAPI.waitFor(500)
For i = 1 To txtFile.LineCount '……(3)'
Debug.Print txtFile.Line(i)
Call WindowsAPI.waitFor(300)
Next
End Sub
(1)の
Dim i As Long '……(1)' For i = 1 To txtFile.LineCount Debug.Print txtFile.Line(i) Call WindowsAPI.waitFor(300) Next
では、まずは普通にtxtFileインスタンスに蓄えられた元のテキストファイル（test.txt）の各行のデータ（笑）を吐き出している。
ループ1回ごとに自作WindowsAPIクラスのwaitForメソッドでポーズを入れている（(2)も(3)も同様。）。
WindowsAPIクラスについては、
コチラをどうぞ。
(2)の
Debug.Print "3行目を書き換えるよ。" Call txtFile.setData(3, "ち～んｗ")
では、イミディエイトに書き換え宣言を表示させた後、
Call txtFile.setData(3, "ち～んｗ")
で新作のsetDataメソッドを実行。引数に「3」と「"ち～んｗ"」を渡しているので、test.txtの「3」行目を「ち～んｗ」というデータ（笑）に書き換えることになる。
あとは、(3)の
For i = 1 To txtFile.LineCount Debug.Print txtFile.Line(i) Call WindowsAPI.waitFor(300) Next
で、新生test.txtのデータ（笑）を全てゆっくり吐き出す。
リスト２を実行すると……
このとおり。
test.txtは
こうなっている。
おわりに
異様に長い割に、読んでもあまりためにならない記事になってしまい、深く反省している……。
さらに追記
今はこんなことになっています。
差し込み印刷のデータソース接続前にデータソースの存否確認をする(Word)
差し込み印刷のデータソース接続前にデータソースの存否確認をする
……などと、大それた標題をブチ上げたが、実質的な
敗北宣言
だと思っていただきたい。
いわば、爆負宣言である。
差し込み印刷のデータソースはExcel限定
実は、差し込み印刷の差し込みデータソースには、実に多様なものを指定することができる。
私は、Excel→Wordパターンしか知らなかった（だいたい、差し込み印刷というテクニックｗを覚えたのが５年前ぐらいなのだ。）ので、驚いた。ヒマな人は自分で調べてみてください。
今回は、Excel限定にする。……というか、それしか思い浮かばなかったのだ。結局。だから、敗北宣言。
ファイルの存在確認
まず、Excelのワークシートなり、セル範囲なりをデータソースに指定しているときは、当該のExcelブックが存在しなくてはいけない。これはめっちゃ簡単。
FileSystemObjectクラスのFileExsistsメソッドでOK。
シート・セル範囲の存在確認
で、問題はこいつ。
最初は、簡単にできると思っていた。
データソースに接続するときに、Document.MailMergeオブジェクトのOpenDataSourceメソッドでSQLを投げているっぽいので、データソースに指定したシート名なりセル範囲名に誤りがあったら、そこでエラーが出るやろ、と。
しかし、Word様は一枚上手だった。
データソースが見当たらなかったら、こんな風に、データソースの指定を促してくるのである。やられた。（ちなみに、ここで[キャンセル]を選択すると、実行時エラーになる。自動で[キャンセル]を選択するようにすれば、ここでエラーキャッチできるが、あまり美しいやり方ではない……。）
紆余曲折の末、現在の私のスキルレベルでは無理、と判断し、一番アホみたいな解決策をとった。
リスト１ 標準モジュール
Private Function isCorrectTable( _
ByVal dataSourceFilePath As String, _
ByVal dataSourceTableName As String) As Boolean
'Microsoft Excel XX.X Object Libraryを参照設定する'
Dim ret As Boolean
ret = False
Dim tgtXls As Excel.Application
Set tgtXls = New Excel.Application
Dim tgtBook As Workbook
Set tgtBook = tgtXls.Workbooks.Add(dataSourceFilePath)
On Error GoTo Finalizer
'テーブル名の右端が「$」ならば、シートを指定している'
If Right(dataSourceTableName, 1) = "$" Then
Dim tgtSheetName As String
tgtSheetName = Left(dataSourceTableName, Len(dataSourceTableName) - 1)
'シートの存否を確認'
If sheetExists(targetBook:=tgtBook, _
targetSheetName:=tgtSheetName) Then
ret = True: GoTo Finalizer
Else
GoTo Finalizer
End If
End If
'テーブル名の右端が「$」でないならば、名前付きセル範囲を指定している'
'アテ馬変数を準備'
Dim stalkingHorse As Variant
Set stalkingHorse = tgtXls.Range(dataSourceTableName)
If stalkingHorse Is Nothing Then GoTo Finalizer '……(*)'
Set stalkingHorse = Nothing
'ここまでたどり着いたということは、名前付きセル範囲があったということ'
ret = True
Finalizer:
Call tgtBook.Close(SaveChanges:=False)
Call tgtXls.Quit
Set tgtXls = Nothing
Set tgtBook = Nothing
isCorrectTable = ret
If Err.Number > 0 Then Call Err.Clear
End Function
Private Function sheetExists( _
ByVal targetBook As Workbook, _
ByVal targetSheetName As String) As Boolean
Dim ret As Boolean
ret = False
Dim i As Long
With targetBook
For i = 1 To .Worksheets.Count
If .Worksheets(i).Name = targetSheetName Then
ret = True
Exit For
End If
Next
End With
sheetExists = ret
End Function
単なる力業ですよ、はい。
Excel→Wordの差し込み印刷についても、ちゃんと理解しているわけではないので、〈シート名での指定〉、〈セル範囲の名前での指定〉以外に指定方法があったらアウトｗ
エラーキャッチもたぶんかなり杜撰ｗ
(*)の
If stalkingHorse Is Nothing Then GoTo Finalizer
なんて、本当に必要なんかな、と思いますがｗ
実行
まず、このプロジェクト（SettingFile.docm）があるフォルダ内は
こんな状態。
差し込みデータソースInsertionData.xlsxは、この状態。
右側のセル範囲には、ご覧のようにSumoDataと名前を付けている。
この状態で実行してみる。
何せ、たかがデータソースの存否を確認するためだけに、わざわざExcelを起動するのだから、さぞかし時間がかかるに違いない、とお思いでしょう。
そこで、次のようなプロシージャで処理に要した時間を計測してみようと思う。
まず、リスト１を呼び出すプロシージャを作る。
リスト２ 標準モジュール
Public Sub callIsCorrectTable()
Debug.Print isCorrectTable( _
ThisDocument.Path & "\InsertionData.xlsx", _
"InsertionData$")
End Sub
で、こいつを自作の処理時間計測用メソッドにわたす。
参考 標準モジュール
'Declare Section' Private Declare Function GetTickCount Lib "kernel32" () As Long Public Function getElapsedTime(ByVal procedureName As String) As Double Dim startTime As Long Dim endTime As Long startTime = GetTickCount Call Application.run(procedureName) endTime = GetTickCount getElapsedTime = (endTime - startTime) / 1000 End Function
イミディエイト・ウインドウに、
?getElapsedTime("callIsCorrectTable")
と入力して[Enter]。
何と、5秒近くもかかっている……。
おわりに
Document.MailMergeオブジェクトのOpenDataSourceメソッドでSQLを投げるときに、何かうまくやる方法があるように思えてならない。
FileSystemObjectを用いてテキストファイルを読み込む
FileSystemObjectを用いてテキストファイルを読み込む
〈FileSystemObject使い宣言〉をしていた（いつ？！）にもかかわらず、
このときは、テキストファイルの読み込みにFileSystemObjectを利用していなかった。
深く反省して、FileSystemObjectを用いる形に書き換えたい。
TextFileクラスのコード
めんどくさいので、改良（？）したTextFileクラスのコードを全掲載する。
リスト１ クラスモジュール
'オブジェクト名は"TextFile"。' Option Explicit 'Constants' Private Enum ErrorTypes etFileNotFound = 1 etLineNotExists etNotInitialized etErrorOccurred End Enum 'Module Level Variables' Private isInitialized As Boolean Private fileFullName As String Private line_() As String Private fsObj As FileSystemObject 'Properties' Public Property Get Line(ByVal numberOf As Long) As String Const ERR_SOURCE As String = "TextFile Class, Property Get Line" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) Dim ret As String '存在しない行番号を指定していたらエラー。' If UBound(line_) + 1 < numberOf Or _ numberOf < 0 Then _ Call raiseError(etLineNotExists, ERR_SOURCE) On Error GoTo ErrorHandler ret = line_(numberOf - 1) Line = ret Exit Property ErrorHandler: '何かしらエラーが出たら、イミディエイトに情報を表示して中断。' Debug.Print "Number : " & Err.Number Debug.Print "Description : " & Err.Description Call raiseError(etErrorOccurred, ERR_SOURCE) End Property Public Property Get LineCount() As Long Const ERR_SOURCE As String = "TextFile Class, Property Get LineCount" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) Dim ret As Long If IsEmpty(line_) Then ret = 0: GoTo Finalizer ret = UBound(line_) + 1 Finalizer: LineCount = ret End Property 'Constructor' Private Sub Class_Initialize() isInitialized = False Set fsObj = New FileSystemObject End Sub Public Sub init(ByVal targetFullName As String) '対象ファイルの存否確認。なければエラー。' If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, "TextFile Class, init Method") 'モジュールレベル変数に対象ファイルのフルパスを保存' fileFullName = targetFullName 'テキストファイルからデータを取得' line_ = getLines(targetFullName) isInitialized = True End Sub 'テキストファイル読み込み' Private Function getLines( _ ByVal targetFullName As String) As String() Dim ret() As String Dim n As Long n = 0 ReDim ret(n) Dim txtStream As Scripting.TextStream Set txtStream = fsObj.OpenTextFile( _ FileName:=targetFullName, _ IOMode:=ForReading, _ Create:=False) Do ret(n) = txtStream.ReadLine '最終行まで読み込んだらExit' If txtStream.AtEndOfLine Then Exit Do n = n + 1 ReDim Preserve ret(n) Loop Call txtStream.Close Set txtStream = Nothing line_ = ret getLines = line_ End Function 'Destructor' Private Sub Class_Terminate() Set fsObj = Nothing End Sub 'Methods' Public Sub regetData(Optional ByVal targetFullName As String) Const ERR_SOURCE As String = "TextFile Class, regetData Method" 'initメソッド未実行ならエラー。' If Not isInitialized Then _ Call raiseError(etNotInitialized, ERR_SOURCE) If targetFullName = "" Then GoTo MainProcess If Not fsObj.FileExists(targetFullName) Then _ Call raiseError(etFileNotFound, ERR_SOURCE) '新たにファイルフルパスが渡されたら、それを新しいファイルフルパスにする' fileFullName = targetFullName MainProcess: Erase line_ Call Me.init(fileFullName) End Sub Private Sub raiseError(ByVal typeOfError As ErrorTypes, _ Optional ByVal errorSource As String) Dim msg As String msg = getErrorMessage(typeOfError) Call Err.Raise(Number:=10000 + typeOfError, _ Source:=errorSource, _ Description:=msg) End Sub Private Function getErrorMessage( _ ByVal typeOfError As ErrorTypes) As String Dim ret As String Select Case typeOfError Case etFileNotFound: ret = "The file you specified isn't found." Case etLineNotExists: ret = "This file doesn't have so many lines." Case etNotInitialized: ret = "You must run ""init"" method!" Case etErrorOccurred: ret = "Some Error has occurred" End Select getErrorMessage = ret End Function
すまん。すっげえタテ長になってしまった。
テキストファイル読み込み部分だけ取り上げる。
リスト２ クラスモジュール
Private Function getLines( _
ByVal targetFullName As String) As String()
Dim ret() As String
Dim n As Long
n = 0
ReDim ret(n)
Dim txtStream As Scripting.TextStream '……(1)'
Set txtStream = fsObj.OpenTextFile( _
FileName:=targetFullName, _
IOMode:=ForReading, _
Create:=False)
Do '……(2)'
ret(n) = txtStream.ReadLine
'最終行まで読み込んだらExit'
If txtStream.AtEndOfLine Then Exit Do
n = n + 1
ReDim Preserve ret(n)
Loop
Call txtStream.Close
Set txtStream = Nothing
line_ = ret
getLines = line_
End Function
目玉は二つ。
まずは、(1)からの５行（実質２行）
Dim txtStream As Scripting.TextStream
Set txtStream = fsObj.OpenTextFile( _
FileName:=targetFullName, _
IOMode:=ForReading, _
Create:=False)
FileSystemObjectクラスのOpenTextFileメソッドは、TextStreamオブジェクトを返す。
最初、
Dim txtStream As
と入力してもTextStreamが入力候補に出なかったので焦ったが、
Dim txtStream As Scripting.
まで入力したら、ちゃんとTextStreamが出た。
あとは、(2)からの７行（正味６行）
Do '……(2)' ret(n) = txtStream.ReadLine '最終行まで読み込んだらExit' If txtStream.AtEndOfLine Then Exit Do n = n + 1 ReDim Preserve ret(n) Loop
最初、ReadLineメソッドに引数がないので、
おい小池、行数指定できねえのかよ！
と思ったのだが、Doループで回すだけで順番に取り出してくれているっぽい。
任意の行を指定したいときにはどうすれば良いのかわからないが、全ての行を取り出すには実に好都合だ。
終了判定は、
If txtStream.AtEndOfLine Then Exit Do
のように、AtEndOfLineプロパティで行うことが可能。
実にわかりやすい。
実行
次のコードで使用実験。
リスト３ 標準モジュール
Private Sub testTextFileClass()
Dim targetPath As String
targetPath = ThisDocument.Path & "\" & "test.txt" '"
Dim txtFile As TextFile
Set txtFile = New TextFile
Call txtFile.init(targetPath)
Dim ar() As String
Dim i As Long
For i = 1 To txtFile.LineCount
Debug.Print txtFile.Line(i)
Next
End Sub
このプロジェクトと同じフォルダ内に「test.txt」というテキストファイルを置いておく。
テキストファイルの内容は、
これｗ
実行すると、
意図どおり。
おわりに
同じ処理をさせるのでも、FileSystemObjectを利用すると、非常にreadableになる。
オブジェクト指向の強みだと思う。
『BLOG「芦田の毎日」』（シラバスとは何か ― コマシラバスはなぜ必要なのか）の本文を読みやすく加工するマクロ(Word)
『BLOG「芦田の毎日」』（シラバスとは何か ― コマシラバスはなぜ必要なのか）の本文を読みやすく加工するマクロ(Word)
我ながら超ニッチなマクロであるｗ
過去記事
このときにも紹介したが、標題の記事は、
※本文中、（●）などの表記が見られる場合は、その前に来る言葉の傍点ルビや読みがなルビを意味している。●が一個だと前の文字一つのルビ、●●と2個だと前の文字二つのルビなどを意味する。
という表記ルールで書かれているため、そのままだと異様に読みづらい。
そこで、本文中の必要な箇所に傍点を施し、邪魔なハナクソ（「「●」などの表記」のこと）を除去するマクロを作った。
誰のために？
自分のために決まっているじゃありませんか！
コード
とりあえず、コードを全て掲載する。
我ながら非常にreadableなので、何も説明は要らないと思う。
うそです。ほとんどコード中にコメントで書きましたｗ
リスト１ 標準モジュール
Option Explicit Private Sub main() Dim orgRange As Range Set orgRange = Selection.Range Call putEmphasisMarkToDocument Call orgRange.Select End Sub Private Sub putEmphasisMarkToDocument() Dim doc As Document Set doc = ThisDocument Call doc.Range(0, 0).Select '……(1)' Do '「(●」を探す' With Selection.Find .MatchWildcards = False .MatchFuzzy = False .Text = "(●" Call .Execute '……(2)' 'ヒットしなければ終了' If Not .Found Then Exit Do End With '開始位置を変数にセットする' Dim baseRange As Range Call Selection.Collapse(wdCollapseStart) '……(3)' Set baseRange = Selection.Range '選択範囲を「)」まで延ばす' Dim refRange As Range Call Selection.Extend(")") '……(4)' Set refRange = Selection.Range '文字数を取得する' Dim charCount As Long charCount = refRange.Characters.Count - 2 'カッコの分は引く' '変数にセットした開始位置から逆方向に文字数分選択範囲を延ばす' Call baseRange.Select Call Selection.MoveLeft(Unit:=wdCharacter, _ Count:=charCount, _ Extend:=wdExtend) '……(5)' 'Selection.CharactersのEmphasisMarkプロパティをセットする' Call putEmphasisMark(Selection, charCount) '……(6a)' 'ハナクソを削除する' Call refRange.Delete '……(7)' '削除後、charCount字数分だけ選択された状態なので、終端に向けて潰す' '潰しておかないと、次に選択範囲内だけを検索することになる' Call Selection.Collapse(wdCollapseEnd) Loop End Sub Private Sub putEmphasisMark(ByVal targetSelection As Selection, _ ByVal charCount As Long) '……(6b)' '指定された文字に傍点を施す' Dim i As Long For i = 1 To charCount targetSelection.Characters(i).EmphasisMark = wdEmphasisMarkOverComma Next End Sub
処理の手順は、コード中のコメントのとおり。
実行
とりあえず、13,169文字分のテキストをWordに貼り付けて実験してみる。
(1)の
Call doc.Range(0, 0).Select
で、
こうなる。
With Selection.Find .MatchWildcards = False .MatchFuzzy = False .Text = "(●" Call .Execute '……(2)' 'ヒットしなければ終了' If Not .Found Then Exit Do End With
この(2)を実行したところで、
こうなる。
(3)の
Call Selection.Collapse(wdCollapseStart)
を実行すると、
こうなる。
(4)の
Call Selection.Extend(")")
を実行すると
こうなる。
(5)の
Call Selection.MoveLeft(Unit:=wdCharacter, _
Count:=charCount, _
Extend:=wdExtend)
を実行すると、
こうなる。
そして、(6a)の
Call putEmphasisMark(Selection, charCount)
で(6b)に飛び、
Private Sub putEmphasisMark(ByVal targetSelection As Selection, _
ByVal charCount As Long) '……(6b)'
Dim i As Long
For i = 1 To charCount
targetSelection.Characters(i).EmphasisMark = _
wdEmphasisMarkOverComma
Next
End Sub
を実行すると、
こうなる。
(4)の後、ハナクソ（「(●●●)」）は、変数refRangeぶち込んであるので、(7)の
Call refRange.Delete
を実行して除去する。
ただし、除去した後は
このように除去したハナクソの数（画像の場合は三つ）分だけ選択された状態になるので、選択範囲を終端に向かって潰しておく必要がある。
ちなみに、一気にこのコードを完走させると、
こうなる。激速！
おわりに
非常にニッチなニーズ（そもそも存在するのか？）にお応えしました。
ドラッグで文字列を選択したかのような操作(Word)
文字列をドラッグして選択する操作(Word)
このとき、
選択範囲を文字数単位で拡張するメソッドとか、ないものか。（←調べろ。）
などと、テキトーなことをぶっこいていたが、
あった。
やはり、ものごとというものは、ちゃんと調べてみるものである。
Selection.MoveLeftメソッド
ちょこっと調べてみると、Selection.MoveLeftメソッドというものが見つかった。
コチラによると、
Moves the selection to the left and returns the number of units it has been moved.
Syntax
expression.expression Required. A variable that represents a Selection object.
Parameters
Name Required/Optional Data type Description Unit Optional WdUnits The unit by which the selection is to be moved.The default value is wdCharacter. Count Optional Variant The number of units the selection is to be moved. The default value is 1. Extend Optional Variant Can be either wdMove or wdExtend. If wdMove is used, the selection is collapsed to the endpoint and moved to the left. If wdExtend is used, the selection is extended to the left. The default value is wdMove.
とある。
つまり、たとえば、
Call Selection.MoveLeft(wdCharacter, 5, wdExtend)
と書けば、
現在のカーソル位置から〈文字単位で〉、〈5だけ〉、左方向へ〈選択範囲を延ばす〉という操作を行うことができるということだ。
実験
このように、「キーワード」と「(●●●●●)」の嵌張にカーソルを置いて、イミディエイト・ウインドウに
Call Selection.MoveLeft(wdCharacter, 5, wdExtend)
と打ち込んで[Enter]を押す。
この通り。
おわりに
これでかなり処理速度を上げることができるぞ！
うおおおおおおおおおおおお！
面白くなってきたぜええええ！
ちなみに、右方向に選択範囲を延ばすには、Selection.MoveRightメソッドをどうぞ。
