Worksheetクラスを継承したクラスを作る(1)

Worksheetクラスを継承したクラスを作る

超絶アホ企画。

少しオブジェクト指向をかじったVBAerなら、VBAのクラスモジュールに「継承」がないことは当然知っているだろう。

だから、あくまでも「擬似継承」である。

っていうか、ほとんど嘘である。

擬似継承の方法

とにかく、

全てのメソッド・プロパティをラップする

のである。

だから、

超絶アホ企画

なんである。

PoweredSheetクラス

PoweredSheetというクラスを作り、その中にWorksheetクラスのプロパティ・メソッドを片っ端から置いていく。

とりあえずの基本形は以下の通り。

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

'Module Level Variable'
Private realSh As Worksheet

Private isAvailable As Boolean

'Constructor'
Public Sub init(ByVal targetSheet As Worksheet)
  Set realSh = targetSheet
  isAvailable = True
End Sub

Private Sub Class_Initialize()
  isAvailable = False
End Sub

擬似コンストラクinitメソッドで、モジュールレベル変数realShWorksheetオブジェクトを突っ込む。プロパティとかメソッドは、realShを経由して取り出すことにする。

Rangeプロパティをラップする

いきなり難問。

Rangeプロパティは、通常、次のように使う。

[Worksheet].Range("A1")    '……(1)'
With ThisWorksheet
  Range(.Range("A1"), .Range("D2"))    '……(2)'
End With

(1)は、Rangeプロパティの引数に文字列(セルのアドレス)を渡している。

(2)は、Rangeプロパティの引数にRangeオブジェクト(単独のセル)を二つ渡している。

こういうわけのわからない引数を実現しなければならない。

ParamArrayを使う

そこで、ParamArrayの出番である。

ParamArrayとは、

www.tipsfound.com

によると、

可変長な引数を作成するにはParamArray 引数名() As Variantのように入力します。必ず配列の Variant 型にします。ParamArray を付けると、任意の数の引数を配列に変換して受け取れます。

とのこと。

これを使うことにした。

スト2 クラスモジュール PoweredSheet

Property Get Range部分のみ。

Public Property Get Range( _
           ParamArray args() As Variant) As Range
  Dim ret As Range
  Select Case UBound(args)
    Case 0
      Set ret = realSh.Range(args(0))
    Case 1
      Set ret = realSh.Range(args(0), args(1))
  End Select
  Set Range = ret
End Property

引数は、インデックス指定の場合一つ、セル範囲の左上端、右下端指定の場合で二つなので、Select Caseで二通りに場合分けした。不適切な引数を与えた場合は、本家Rangeプロパティでも実行時エラーになるので、エラー対応とか別に要らんやろ、という投げやり対応。

使ってみる

f:id:akashi_keirin:20190916215800j:plain

このようなシートを用意して、次のコードで実験。

リスト3 標準モジュール
Private Sub testPoweredSheet()
  Dim ps As PoweredSheet
  Set ps = New PoweredSheet
  Call ps.init(Sheet1)
  Debug.Print ps.Range("A1").Value    '……(1)'
  With ThisWorkbook.Worksheets("Original")    '……(2)'
    Debug.Print ps.Range(.Range("A1"), _
                         .Range("D4")).Address
  End With
End Sub

PoweredSheetクラスのインスタンスpsSheet1を渡してから、(1)と(2)の二通りのやり方でRangeプロパティを参照。

実行結果

イミディエイト・ウインドウの表示は

f:id:akashi_keirin:20190916215803j:plain

このとおり。

おわりに

この調子で、全てのプロパティ・メソッドを実装していけば、晴れてWorksheetクラスを継承したPoweredSheetクラスが出来上がる。

がんばるぞ!(←マジで?!)

フォルダ構成だけをコピーするけどアルバムアート画像はやっぱりコピーする

楽曲データフォルダのフォルダ構成だけをコピーする(アルバムアートだけはコピーする)

このとき

akashi-keirin.hatenablog.com

の続き。

フォルダ構成だけをコピーするんだけど、アルバムアートファイルだけはコピーする。

私の場合、アルバムアートは、全部folder.jpgというファイル名で統一しているので、その前提で。

コード

Public Sub copyFolderStructure(ByVal sourceDir As String, _
                               ByVal destinationDir As String)
  
  Const ALBUM_ART_FILE As String = "\folder.jpg"
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject
  Dim parentFolder As Folder
  Set parentFolder = fsObj.GetFolder(sourceDir)
  Dim subFolder As Folder
  For Each subFolder In parentFolder.SubFolders
    'コピー先に同名のフォルダを作る'
    Dim newDir As String
    newDir = destinationDir & "\" & subFolder.Name   '"
    If Not fsObj.FolderExists(newDir) Then _
      Call fsObj.CreateFolder(newDir)
    'アルバムアートファイルがあったらコピーする'
    Dim albumArtFullPath As String
    albumArtFullPath = subFolder.Path & ALBUM_ART_FILE
    'フォルダ内に既にアルバムアートファイルがあったらコピーしない'
    If fsObj.FileExists(albumArtFullPath) Then _
      If Not fsObj.FileExists(newDir & ALBUM_ART_FILE) Then _
        Call fsObj.CopyFile(albumArtFullPath, newDir & ALBUM_ART_FILE)
    'サブフォルダにさらにサブフォルダがあったらそれもコピー'
    If subFolder.SubFolders.count > 0 Then
      Call copyFolderStructure( _
             subFolder.Path, destinationDir & "\" & subFolder.Name)  '"
    End If
  Next
End Sub

このメソッドに、コピー元のフォルダパスとコピー先のパスを渡して実行すると、フォルダ構成をコピーするだけでなく、コピー元のフォルダ内にfolder.jpgという名前のファイルがあったら、そいつをコピー。コピー先にすでにフォルダがあって、その中にfolder.jpgがあったら、それはそっとしておく、ということになる。

使ってみる

たとえば、

f:id:akashi_keirin:20190916142816g:plain

このTest1フォルダから、

f:id:akashi_keirin:20190916143715g:plain

このTest2フォルダにフォルダ構成をコピーする。

実行結果

Test2は、

f:id:akashi_keirin:20190916144110g:plain

こんな風になる。

おわりに

foobar2000使いの人はぜひどうぞ。

Worksheet.Copyメソッドの改良?

[Worksheet].Copyメソッドの改良?

[Worksheet].Copyメソッドについて、「オブジェクト ブラウザー」で調べてみると、

f:id:akashi_keirin:20190916105038j:plain

Sub、つまりvoidメソッドであることがわかる。

たぶん、プロがやったことなので、あえてvoidメソッドにしたことには意味があるのだとは思うが、なぜAddメソッドだとWorksheetオブジェクトを返すのに、Copyメソッドはそうしなかったのだろうか。

Copyメソッドで新たに生まれたシートをそのまま変数にぶち込めたら便利なのではなかろうか。

neoCopyメソッドの実装

……というわけで、neoCopyメソッドというものを考えた。

いや、単にシートをコピーした後、新しくできたシートを返す、というだけなんですけど。

難問

問題はどのように実装するか、である。

Worksheetクラスを継承してメソッドを付け足すだけ、とかだったらめっちゃ楽なんだが、残念ながらそういうことはできない。

一瞬、「Worksheetクラスを全部ラップしたクラス作ったらええやんけ」とも思ったのだが、Worksheetクラスのプロパティ、メソッド(その上イベントまである)の数のあまりの多さに早々に断念。

クラスモジュールを使うことも考えたが、シート自身を指し示す方法(*)が思い浮かばなかったので、やはり断念。

ここで言う「自分自身を指し示す方法」というのは、次のようなことです。

たとえば、PoweredSheetというクラスを作ったとして、次のような形でインスタンスを生成したとする。

Dim ps1 as PoweredSheet
Set ps1 = New PoweredSheet

このようなとき、PoweredSheetクラスがWorksheetクラスを継承していれば、通常のCopyメソッドを使用するとき、たとえば

Call ps1.Copy(After:=Worksheets(1))

のように書ける。っていうか、そうでないと意味がない。

しかしながら、継承が使えない以上、クラスモジュールでやろうとすると、(本家Worksheetクラスの全てのプロパティ・メソッドをラップしない限り)たとえば、シート自身を指し示すSelfみたいなプロパティを装着しておいて、

call ps1.Self.Copy

とでも書くしかない。

これでは、PoweredSheetをシートを表現するオブジェクトのように使うことはできない。

そこで、地道にシートモジュールにメソッドを追加することにした。

neoCopyメソッド

デフォルトのSheet1モジュールに次のコードを書いた。

リスト1 シートモジュール Sheet1
Public Function neoCopy( _
   Optional ByVal Before As Worksheet, _
   Optional ByVal After As Worksheet) As Worksheet  '……(1)'
  Dim ret As Worksheet
  Set ret = Nothing
  On Error GoTo Finalizer  '……(2)'
  If Before Is Nothing And _
     After Is Nothing Then Set Before = Me  '……(3)'
  Dim baseIndex As Long    '……(4)'
  With ThisWorkbook
    If Not Before Is Nothing Then
      Call Me.Copy(Before:=Before)
      baseIndex = getSheetIndex(Me)  '……(5)'
      Set ret = .Worksheets(baseIndex - 1)  '……(7)'
    Else
      Call Me.Copy(After:=After)
      baseIndex = getSheetIndex(Me)
      Set ret = .Worksheets(baseIndex + 1)
    End If
  End With
Finalizer:
  If Err.Number > 0 Then Call Err.Clear  '……(8)'
  Set neoCopy = ret  '……(9)'
End Function

Private Function getSheetIndex( _
             ByVal targetSheet As Worksheet) As Long  '……(6)'
  Dim ret As Long
  Dim i As Long
  With ThisWorkbook
  For i = 1 To .Worksheets.Count
    If .Worksheets(i).Name = targetSheet.Name Then
      ret = i: Exit For
    End If
  Next
  End With
  getSheetIndex = ret
End Function

まず、(1)の

Public Function neoCopy( _
   Optional ByVal Before As Worksheet, _
   Optional ByVal After As Worksheet) As Worksheet

で引数と返り値の設定。

引数は本家Copyメソッドと同じ。返り値をWorksheet型にしたのが今回のポイント。

引数に矛盾があるときのチェック用メソッドも書こうかなあとは思ったが、めんどくさいので、(2)の

On Error GoTo Finalizer

で、エラーが出たらNothingを返すようにした。

(3)の

If Before Is Nothing And _
     After Is Nothing Then Set Before = Me

は、引数が両方省略されていた場合の対応。

とりあえずBeforeに自分自身を渡すようにした。

(4)の

Dim baseIndex As Long
With ThisWorkbook
  If Not Before Is Nothing Then
    Call Me.Copy(Before:=Before)
    baseIndex = getSheetIndex(Me)  '……(5)'
    Set ret = .Worksheets(baseIndex - 1)  '……(7)'
  Else
    Call Me.Copy(After:=After)
    baseIndex = getSheetIndex(Me)
    Set ret = .Worksheets(baseIndex + 1)
  End If
End With

でコピーしてできた新しいシートを変数にぶち込むところまでやる。

引数Beforeがあるときは、それに従う。

本家Copyメソッドを実行した後、(5)の

baseIndex = getSheetIndex(Me)

でコピー元のシートのインデックス番号を取得する。

インデックス番号の取得には、外出しした(6)の

Private Function getSheetIndex( _
             ByVal targetSheet As Worksheet) As Long
  Dim ret As Long
  Dim i As Long
  With ThisWorkbook
  For i = 1 To .Worksheets.Count
    If .Worksheets(i).Name = targetSheet.Name Then
      ret = i: Exit For
    End If
  Next
  End With
  getSheetIndex = ret
End Function

を使う。

シートの名前を比較して、同じだったときのインデックス番号を返すだけ。

これで、コピー元シートのインデックスがわかるので、たとえば引数Beforeを指定して実行した場合ならば、一つ少ないインデックス番号がコピーしてできた新しいシートのインデックス番号、ということになる。

だから、(7)の

Set ret = .Worksheets(baseIndex - 1)

で、新しくできたシートを変数retにぶち込むことができる。

引数Afterを指定した場合も、処理の考えかたは同じなので説明は割愛。

あとは、もしエラーが出て飛んできているのなら、一応(8)の

If Err.Number > 0 Then Call Err.Clear

でエラーをクリアし、(9)の

Set neoCopy = ret

retの内容を返しておしまい。

使ってみる

まずは、

f:id:akashi_keirin:20190916105041j:plain

このようなブックを用意。

「Original」という名のシートが一つだけあり、A1セルに「ち~んw」というデータ(笑)が入力されている。

この状態で、次のコードで実行する。

スト2 標準モジュール
Private Sub testNeoCopy()
  Dim Sh As Worksheet
  Set Sh = Sheet1.neoCopy(After:=Sheet1)  '……(1)'
  If Sh Is Nothing Then _
    Call Provoke.makeUserSick("失敗www", mbiCritical): Exit Sub  '……(2)'
  With Sh    '……(3)'
    .Name = "Copied"
    .Range("A2").Value = "ち~んw"
  End With
End Sub

(1)の

Set Sh = Sheet1.neoCopy(After:=Sheet1)

neoCopyメソッドを使用。

Sheet1シートをコピーして、Sheet1シートの後ろに新しいシートを生み出す。

そして、生み出された新しいシートは変数Shにぶち込まれている。

(2)の

If Sh Is Nothing Then _
  Call Provoke.makeUserSick("失敗www", mbiCritical): Exit Sub

は気にしないでほしい。私は、ユーザーを煽るためのメソッドをProvokeと名づけた標準モジュールに集めており、インポートして使っている。

今回はそのProvokeモジュールのmakeUserSickを、neoCopyメソッドが失敗したとき(変数ShNothingが返ったとき)の対応に使っているだけだ。

Provokeモジュールについては、いつか紹介するときも来るだろう。

閑話休題

ここまでで、変数Shに新しく生み出されたシートがぶち込まれているので、(3)の

With Sh
  .Name = "Copied"
  .Range("A2").Value = "ち~んw"
End With

で新しいシートに手を加える。

シート名を「Copied」とし、A2セルに「ち~んw」というデータ(笑)を書き込む。

実行結果

スト2を実行すると、

f:id:akashi_keirin:20190916105045j:plain

こうなる。意図したとおり。

おわりに

問題は、全てのシートモジュールにいちいちneoCopyメソッドを搭載せねばならんことだ。

あまり役に立ちそうにない。

再帰処理に初挑戦

再帰処理に初挑戦

前回

akashi-keirin.hatenablog.com

の続き。

Foobar2000用の音楽フォルダ管理の話。

とりあえず、フォルダの中身はコピーせずに、フォルダ構成だけを別フォルダにコピーしたい。

任意のフォルダ内の子フォルダだけを別のフォルダにコピーするマクロ

FileSystemObjectSubFoldersコレクションとCreateFolderメソッドを使えば楽勝。

リスト1 標準モジュール
'### Microsoft Scripting Runtime参照設定 ###'
Option Explicit

Private fsObj As FileSystemObject

Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)  '……(1)'
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject  '……(2)'
  Dim tgtFolder As Folder    '……(3)'
  Set tgtFolder = fsObj.GetFolder(srcDir)
  Dim subFolder As Folder    '……(4)'
  For Each subFolder In tgtFolder.SubFolders
    fsObj.CreateFolder(destDir & "\" & subFolder.Name)    '"
  Next
End Function

(1)の

Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)

で引数設定。

第1引数srcDirでコピー元のフォルダパスを受け取り、第2引数destDirでコピー先のフォルダパスを受け取る。

(2)の

If fsObj Is Nothing Then _ Set fsObj = New FileSystemObject

FileSystemObjectインスタンスを生成。

変数fsObjはモジュールレベル変数なので、インスタンス化していないときだけSetする。

(3)の

Dim tgtFolder As Folder
Set tgtFolder = fsObj.GetFolder(srcDir)

では、FileSystemObjectオブジェクトのGetFolderメソッドを用いて、コピー元のフォルダをFolderオブジェクトとして取得。変数tgtFolderにぶち込んでいる。

そして、(4)の

Dim subFolder As Folder
For Each subFolder In tgtFolder.SubFolders
  Call fsObj.CreateFolder(destDir & "\" & subFolder.Name)    '"
Next

では、tgtFolderオブジェクトのSubFoldersコレクションから子フォルダを一つづつ取り出してsubFolderにぶち込み、そのNameプロパティを利用してコピー先のフォルダパスを作成。そうしてできたフォルダパスをCreateFolderメソッドに渡してコピー先に新しいフォルダを作成する。

めちゃくちゃ簡単である。

リスト1の問題点

しかし、リスト1のやり方には問題点がある。

子フォルダの中にある孫フォルダ、曾孫フォルダ、……まではコピーできないのだ。

そこでどうするか。リスト1の(4)のところで、取り出した子フォルダ(subFolderにぶち込まれたフォルダ)にさらに孫フォルダがあるときには、子フォルダをcopyFolderStructureに渡すようにすればいいのである。

copyFolderStructure内からcopyFolderStructureメソッドを呼ぶ

リスト1を次のように書き換える。

スト2 標準モジュール
Public sub copyFolderStructure( _
             ByVal srcDir As String, _
             ByVal destDir As String)
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject
  Dim tgtFolder As Folder
  Set tgtFolder = fsObj.GetFolder(srcDir)
  Dim subFolder As Folder    '……(5)'
  For Each subFolder In tgtFolder.SubFolders
    Dim newFolder As Folder
    Set newFolder = fsObj.CreateFolder( _
                            destDir & "\" & subFolder.Name)        '"
    If subFolder.SubFolders.Count > 0 Then _
      call copyFolderStructure( _
                            subFolder.Path, newFolder.Path)
  Next
End Sub

変えたのは(5)のForループのところ。

コピー先に新たに作ったフォルダを変数newFolderにぶち込むようにしている。

そして、subFolderにぶち込まれているフォルダについて、SubFoldersプロパティの値を調べ、0よりも大きいとき、すなわちさらに孫フォルダがあるときには、subFolder自身のフルパスと、先ほど作ったコピー先のnewFolderのフルパスをcopyFolderStructureに渡す。

これで、中にフォルダがある限り掘り進めて行ってくれる。

使ってみる

今回のマクロを書いたブックのあるフォルダ内に次のようなフォルダ群を準備。

f:id:akashi_keirin:20190914105737j:plain

Test1Test2というフォルダが同じ階層にあり、そのうちTest1フォルダの方には、ご覧のように子、孫フォルダが入っている。

f:id:akashi_keirin:20190914105741j:plain

ちなみに、当然Test2フォルダの中は空っぽ。

この状態で、次のコードを実行する。

リスト3 標準モジュール
Private Sub testCopyFolderStructure()
  Dim srcDir As String
  srcDir = ThisWorkbook.Path & "\Test1"
  Dim destDir As String
  destDir = ThisWorkbook.Path & "\Test2"
  Call copyFolderStructure(srcDir, destDir)
End Sub

copyFolderStructureメソッドにTest1フォルダのパスとTest2フォルダのパスを渡しているだけ。

こいつを実行すると、Test2フォルダの中は

f:id:akashi_keirin:20190914105746g:plain

こうなる。意図どおり。

おわりに

何となく今まで避けてきた「再帰処理」ですが、やってみたら意外と簡単でした。

ただ、積極的に使いどころを見いだしていくのはなかなかむつかしいかも知れません。

あと、Foobar2000の音楽フォルダ用に使うには、folder.jpgがあるときはそれもコピーする、という処理を追加する必要があります。

FileSystemObjectでフォルダをコピーするときの注意

FileSystemObjectでフォルダを作る

当方、10年以上前から音楽ファイルの再生にはfoobar2000を使っています。

f:id:akashi_keirin:20190912074539j:plain

CDから楽曲データをリッピングしてエンコードするときに、勝手にフォルダを作っていくタイプのソフトウエアにどうしてもなじめなくて、面倒だけれど自力でフォルダ構築してきたのです。

長年使っていると、やはりフォルダの数がえらいことに。

普段づかいのHDDにはflacでため込んでいるのですが、Walkmanなんかに入れるときは、容量の問題もあってなるべくmp3にしたい。でもそうなると、〈フォルダごとコピー〉という技が使えない。使ったとしても、flacファイルごとコピーされるので、一旦flacファイルを消す手間が生じる。

VBAを始める前は、仕方なく手作業でこうした作業をしていましたが、今は違う。

〈フォルダ構成まるごとコピー〉ぐらいなら(やり方がエレガントかどうかは別として)苦も無く出来るようになりました。

そこで、上には書かなかった〈もう一つの問題〉に取り組むことにしました。

もう一つの問題

「もう一つの問題」。それは、〈アルバムアートの画像ファイルはどうすんの?〉問題である。

音楽フォルダ内では、

f:id:akashi_keirin:20190912074544j:plain

こんなふうにフォルダを作っている。何のことはない、アルバムごとにフォルダを作っているだけ。

で、各アルバムフォルダには、flacファイルと、アルバムアート用のfolder.jpgというファイルが入っている。

f:id:akashi_keirin:20190912074549j:plain

マクロを作ってフォルダ構成を丸ごとWalkmanの音楽フォルダにコピーしたとて、アルバムごとのfolder.jpgは別途手作業でコピーせねばならんかったのだ。

対応

しかし、今の私はかつての私とはちがう。I'm not the man who I was used to be. である(英語はこれでいいのだろうか?)。

フォルダをコピーするときに、コピー元フォルダの中にfolder.jpgがあれば、それをコピーするという一手間加えるだけでよい。

それはすでにできている。

しかし、今回の本題はそこではない。もっと初歩的なことだ。

本題

ようやくここで本題だ。たぶん、前置きの方が長い。許せ。

本題は、〈FileSystemObjectでフォルダを作るときの注意〉だ。

準備

テキトーなフォルダ上に、次のようなフォルダを準備する。

f:id:akashi_keirin:20190912074553j:plain

Test1というフォルダの中に、ahobokekasusuttokodokkoiというフォルダがある。

さらに、ahoフォルダの中にはAnthraxMegadethMetallicaSlayerフォルダがあるのだ。実はさらにMetallicaフォルダの中にはさらにフォルダが作ってあるのだが、今回は関係ないので省略する。

では、このTest1フォルダ内にahoフォルダを作ろうとするとどうなるのか。

次のコードで実験。

リスト1 標準モジュール
Option Explicit

Private fsObj As FileSystemObject

Private Sub test01()
  If fsObj Is Nothing Then _
    Set fsObj = New FileSystemObject
  Dim targetDir As String
  targetDir = ThisWorkbook.Path & "\Test1\aho"
  Call fsObj.CreateFolder(targetDir)
End Sub

このマクロを書いたブックと同じフォルダにあるTest1フォルダの中にahoフォルダを作ろうというのだから、ahoフォルダのフルパスはThisWorkbook.Path & "\Test1\aho"

こいつをFileSystemObject.CreateFolderメソッドに渡してやるだけ。何て簡単!

ただし、上でも書いたように、Test1\ahoフォルダは既に存在している。さて、どうなることか。

f:id:akashi_keirin:20190912074558j:plain

ちゃんとエラーを吐いてくれた。

何も言わずに上書きされてしまうのではたまらんが、これは親切設計。

おわりに

フォルダの存在確認をして、なかったらフォルダ作成、というようにしたければ、最後の1行を

If Not fsObj.FolderExists(targetDir) then _
  Call fsObj.CreateFolder(targetDir)

とすればよろしかろう。FolderExistsというのもメチャメチャわかりやすくて好きです。

私もこんな命名ができるようになりたい……。

フォルダコピー関連の具体的な話はまたこんど……w

TextFileクラスは今……

TextFileクラスは今……

f:id:akashi_keirin:20190910075348j:plain

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

テキストファイルを扱うことがあって、久しぶりに引っ張り出してみたら、いろいろと不具合が見えてきたので、修正した。

TextFileクラスの現在の姿

かつてのTextFileクラスは、空のテキストファイルを渡すとエラーが出る、という初歩的過ぎるバグがあったので、修正するとともに、末尾に新たな行を追加するappendLineメソッドと、末尾にテキストを追加するappendTextメソッドを追加した。

また、それに伴って実装済みのメソッドについても名称を見直した。

コードを全掲載する。

クラスモジュール 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
'///引数numberOf行目の文字列を返す'
  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
  'line_()が空またはline_(0)が空ならば、0を返す。'
  If IsEmpty(line_) Or _
     line_(0) = "" 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 While Not txtStream.AtEndOfLine
    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 regetLines(Optional ByVal targetFullName As String)
  Const ERR_SOURCE As String = _
          "TextFile Class, regetLines 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 replaceLine(ByVal targetLine As Long, _
                       ByVal targetData As String)
  Const ERR_SOURCE As String = _
          "TextFile Class, replaceLine 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

Public Sub appendLine(ByVal targetText As String)
  Dim n As Long
  If IsEmpty(line_) Or _
     line_(0) = "" Then
    n = 0
  Else
    n = UBound(line_) + 1
  End If
  ReDim Preserve line_(n)
  line_(n) = targetText
  'テキストファイル書き込み'
  Dim txtStream As Scripting.TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          Filename:=fileFullName, _
                          IOMode:=ForWriting)
  Dim i As Long
  For i = LBound(line_) To UBound(line_)
    With txtStream
      Call .WriteLine(line_(i))
    End With
  Next
  Call txtStream.Close
  Set txtStream = Nothing
End Sub

Public Sub appendText(ByVal targetText As String)
  Dim txtStream As TextStream
  Set txtStream = fsObj.OpenTextFile( _
                          Filename:=fileFullName, _
                          IOMode:=ForAppending)
  Call txtStream.Write(targetText)
  Call txtStream.Close
  Dim n As Long
  n = 0
  ReDim line_(n)
  Set txtStream = fsObj.OpenTextFile( _
                          Filename:=fileFullName, _
                          IOMode:=ForReading)
  Do While Not txtStream.AtEndOfLine
    line_(n) = txtStream.ReadLine
    If txtStream.AtEndOfLine Then Exit Do
    n = n + 1
    ReDim Preserve line_(n)
  Loop
  Call txtStream.Close
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

相変わらずのタテ長ですまぬ。

おわりに

動作確認が不十分でまだまだ意図どおりに動かないところがあると思う。

なんか、泥沼になってきたような予感……。

文字列のソート

文字列をバブルソートする

ちょっとやってみた。

String型配列をソートして返すFunction

とりあえず、ひととおりコードを晒す。

リスト1 標準モジュール
Public Function getSortedArray( _
            ByRef tgtArr() As String, _
   Optional ByVal isAscending = True) As String()
  Dim ret() As String
  ret = tgtArr
  Dim i As Long
  Dim j As Long
  For i = LBound(ret) To UBound(ret) - 1
    'ソート完了していたらループを抜ける……(3)'
    If hasDone(ret, isAscending) Then Exit For
    For j = LBound(ret) To UBound(ret) - i - 1
      '隣の要素の方が小さい(大きい)なら要素を交換する……(1)'
      If isAscending Then
        If isLittle(ret(j), ret(j + 1)) Then _
          ret = swap(ret, j, j + 1)
      Else
        If isGreater(ret(j), ret(j + 1)) Then _
          ret = swap(ret, j, j + 1)
      End If
    Next
  Next
  getSortedArray = ret
End Function

Private Function isLittle( _
             ByVal str1 As String, _
             ByVal str2 As String) As Boolean
'str2の方がstr1よりも小さかったらTrue'
  If str2 < str1 Then _
    isLittle = True Else isLittle = False
End Function

Private Function isGreater( _
             ByVal str1 As String, _
             ByVal str2 As String) As Boolean
'str2の方がstr1よりも大木凡人だったらTrue'
  If str2 > str1 Then _
    isGreater = True Else isGreater = False
End Function

'配列の要素を交換する……(2)'
Private Function swap( _
             ByRef tgtArr() As String, _
             ByVal index1 As Long, index2 As Long) As String()
  Dim ret() As String
  ret = tgtArr
  Dim tmp As String
  tmp = ret(index1)
  ret(index1) = ret(index2)
  ret(index2) = tmp
  swap = ret
End Function

'ソート完了かどうか調べる……(4)'
Private Function hasDone( _
             ByRef tgtArr() As String, _
    Optional ByVal isAscending As Boolean = True) As Boolean
  hasDone = False
  Dim i As Long
  For i = LBound(tgtArr) To UBound(tgtArr) - 1
    If isAscending Then
      If tgtArr(i) > tgtArr(i + 1) Then Exit Function
    Else
      If tgtArr(i) < tgtArr(i + 1) Then Exit Function
    End If
  Next
  hasDone = True
End Function

比較演算子<」、「>」で文字列の比較ができるので、その機能を利用。

(1)の

If isAscending Then
  If isLittle(ret(j), ret(j + 1)) Then _
    ret = swap(ret, j, j + 1)
Else
  If isGreater(ret(j), ret(j + 1)) Then _
    ret = swap(ret, j, j + 1)
End If

では、配列の隣同士の要素を比較している。引数isAscendingTrueのときは、昇順ソート。

したがって、

If isLittle(ret(j), ret(j + 1))

Trueのとき、すなわち右側にある要素の方が小さいときは、(2)のswapメソッドで順序を入れ換える。

(2)の

Private Function swap( _
             ByRef tgtArr() As String, _
             ByVal index1 As Long, index2 As Long) As String()
  Dim ret() As String
  ret = tgtArr
  Dim tmp As String
  tmp = ret(index1)
  ret(index1) = ret(index2)
  ret(index2) = tmp
  swap = ret
End Function

では、一時的な変数tmpを用いた三角トレード方式で、配列の要素を交換している。

単純なバブルソートだと、ソートが完了している状態でもバカ正直に比較作業を繰り返してしまうので、Forループの先頭に(3)の

If hasDone(ret, isAscending) Then Exit For

を入れて、ソート完了状態ならループを抜けるようにした。

このhasDoneメソッドは、(4)の

Private Function hasDone( _
             ByRef tgtArr() As String, _
    Optional ByVal isAscending As Boolean = True) As Boolean
  hasDone = False
  Dim i As Long
  For i = LBound(tgtArr) To UBound(tgtArr) - 1
    If isAscending Then
      If tgtArr(i) > tgtArr(i + 1) Then Exit Function
    Else
      If tgtArr(i) < tgtArr(i + 1) Then Exit Function
    End If
  Next
  hasDone = True
End Function

こいつ。

単純に、左の要素が右の要素よりも大きい(小さい)とわかった瞬間にFalseを返すようにした。

実験

シート上に

f:id:akashi_keirin:20190909074221j:plain

このように文字を入力しておき、選択状態にしておく。

そうしておいて、次のコードで実験。

スト2 標準モジュール
Private Sub testSortedArray()
  Dim i As Long
  Dim ar1() As String
  ar1 = Split(getJoinedString(Selection), ",")  '……(5)'
  Dim ar2() As String
  ar2 = getSortedArray(ar1, True)  '……(6)'
  For i = LBound(ar2) To UBound(ar2)
    Debug.Print ar2(i)
  Next
End Sub

Private Function getJoinedString( _
             ByVal targetRange As Range) As String
  Dim ret As String
  Dim targetCell As Range
  For Each targetCell In targetRange
    ret = ret & targetCell.Value & ","
  Next
  ret = Left(ret, Len(ret) - 1)
  getJoinedString = ret
End Function

(5)の

ar1 = Split(getJoinedString(Selection), ",")

は、getJoinedStringを呼び出して、セルに入力されている文字列を配列にしただけ。

(6)の

ar2 = getSortedArray(ar1, True)

で、ar2には昇順に並べ替えた文字列がぶち込まれているはずだ。

実行結果

f:id:akashi_keirin:20190909074225j:plain

このとおり。

おわりに

f:id:akashi_keirin:20190909074229j:plain

NTFS上のフォルダからFileSystemObjectを使って取り出したときと同じ並び順になっている。

比較するときに、「str1」と「str2」を「StrConv(str1, vbHiragana)」と「StrConv(str2, vbHiragana)」にしたら、エクスプローラーと同じ並び順にできるのかな?