foobar2000のPlayback Statisticsを編集するマクロ(2)

foobar2000のPlayback Statisticsのデータを編集するマクロ

akashi-keirin.hatenablog.com

とりあえず成果物を晒す

細かいことは後回しにして、ひとまず今回の成果物を晒しておくことにする。

バグ対策とか、操作ミス対策は（個人的に用いるツールゆえ）不十分だけれど、なかなかうまく出来たと思うので、同じような悩みをお持ちのFB2Kerの方には是非使っていただきたい！　あんまりそんな人はいないと思うけど。

Excelのシート

シートは１枚だけ。

だいぶ横長になるけど、こんな感じ。

日付とか時刻を入力するセルには書式設定を施している。

シートモジュール

シートモジュールに書いたコードを全掲載する。シートモジュールのオブジェクト名はMainSheetに変更している。

リスト１　MainSheetモジュール

Option Explicit

Private Const ID_LENGTH As Long = 16
Private Enum PlayData
  pdID = 1
  pdCount
  pdFPDate
  pdFPTime
  pdLPDate
  pdLPTime
  pdADate
  pdATime
  pdRating
End Enum

Public Property Get DataList() As Range
  Dim rng As Range
  Set rng = Me.Range("A1").CurrentRegion
  With rng
    Set rng = .Offset(1, 1).Resize(.Rows.count - 1, .Columns.count - 1)
  End With
  Set DataList = rng
End Property

Public Property Get MaxCount() As Long
  MaxCount = Me.Range("A1").CurrentRegion.Rows.count - 1
End Property

Public Property Get Artist() As String
  Artist = Me.Range("L2").Value
End Property
Public Property Get AlbumTitle() As String
  AlbumTitle = Me.Range("M2").Value
End Property

'///XMLファイル作成のエントリポイント'
Public Sub createXMLFileMain()
  Dim orgArr As Variant '元データを入れる配列'
  orgArr = Me.DataList.Value
  'リストのデータを元にXMLの中身を作っていく'
  Dim contents As String
  Dim i As Long
  For i = LBound(orgArr) To UBound(orgArr)
    Dim tmp As String
    tmp = FB2KUtil.getXMLElement(orgArr(i, pdID), _
                                 orgArr(i, pdCount), _
                                 orgArr(i, pdFPDate), _
                                 orgArr(i, pdFPTime), _
                                 orgArr(i, pdLPDate), _
                                 orgArr(i, pdLPTime), _
                                 orgArr(i, pdADate), _
                                 orgArr(i, pdATime), _
                                 orgArr(i, pdRating))
    contents = contents & tmp & vbCrLf
    '最後に末尾がvbCrLfになるようにする'
  Next
  '１行目と最終行を追加する'
  contents = FB2KUtil.createXMLContents(contents)
  'XMLファイルを出力する'
  Call Me.createXMLFile(contents)
End Sub
'///XMLファイルを作成する'
Private Sub createXMLFile(ByVal targetContents As String)
  Dim saveFolder As String
  saveFolder = ThisWorkbook.Path & "\Edited\"  '"
  If Dir(saveFolder, vbDirectory) = "" Then _
    Call MkDir(saveFolder)
  Dim targetName As String
  targetName = Me.Artist & " - " & Me.AlbumTitle
  Dim fsObj As New FileSystemObject
  Call fsObj.CreateTextFile(saveFolder & targetName & ".txt")
  Dim n As Long
  n = FreeFile(0)
  Open saveFolder & targetName & ".txt" For Output As #n
    Print #n, targetContents
  Close #n
  Name saveFolder & targetName & ".txt" As _
       saveFolder & targetName & ".xml"
End Sub

'///IDを抜き出す'
Public Sub extractID()
  Dim rng As Range
  Set rng = Selection
  'ガード節'
  With rng
    If .Columns.count > 1 Then _
      Call makeUserSick("複数列選択するなぼけーーー！"): Exit Sub
  End With
  Dim targetCell As Range
  For Each targetCell In rng
    With targetCell
      'ガード節'
      If .Row = 1 Or _
         .Row > Me.MaxCount + 1 Or _
         .Column <> 1 Then _
        Call makeUserSick("どこ選んどるんじゃぼけーーー！"): Exit Sub
      If .Value = "" Then _
        Call makeUserSick("空白セルがあるやんけぼけーーー！"): Exit Sub
      Dim tmp As String
      tmp = .Value
      Dim startPos As Long
      startPos = InStr(1, tmp, "<") + 11
      '最初の「<」の11字後ろがIDの先頭'
      tmp = Mid(tmp, startPos, ID_LENGTH)
      .Offset(0, 1).Value = tmp
    End With
  Next
End Sub

途中「makeUserSick」というのは自作のメソッド。興味のある方はコチラをどうぞ。興味がなければ、「makeUserSick」を「MsgBox」に変えてもらったらオッケー。

ちょこちょこコメントを入れてあるので、ご参考にどうぞ。

最後にXMLを作る処理と、最初に各楽曲のIDを抜き出す処理は、このシート特有の処理なので、このモジュールに書いた。

標準モジュール

標準モジュールは、「FB2KUtil」と名前を付けて、日付時刻を表す文字列を作るメソッドとか、Ratingの値に対応する文字列を返すメソッドを中心に記述した。切り分け方は不十分かも知れないが、一応、シートの形態に左右されない、Playback Statisticsをいじるときには必ず使う処理をこのモジュールに書いた。

リスト２　FB2KUtilモジュール

Option Explicit
'Constants'
'2012年1月1日 0時00分00秒の日付時刻値の上11桁'
Private Const STANDARD_DATE_VALUE As Currency = 12969817200#
Private Const STANDARD_DATE As Date = "2012/1/1"
'一日あたりの秒数'
Private Const DAY_BY_SECONDS As Currency = 86400

'Methods'
'///XMLファイルの中身を作る'
Public Function createXMLContents( _
            ByVal contents As String) As String
  Dim ret As String
  If Not (Right(contents, 2) = vbCrLf) Then _
    contents = contents & vbCrLf
  ret = "" & vbCrLf
  ret = ret & contents
  ret = ret & ""
  createXMLContents = ret
End Function
            
'///データを連結してXML要素を作る'
Public Function getXMLElement( _
            ByVal targetID As String, _
            ByVal count As Long, _
            ByVal fpDate As Date, _
            ByVal fpTime As Date, _
            ByVal lpDate As Date, _
            ByVal lpTime As Date, _
            ByVal aDate As Date, _
            ByVal aTime As Date, _
            ByVal rating As Long) As String
  Dim idStr As String
  idStr = vbTab & "<Entry ID=""" & targetID & """ "
  Dim countStr As String
  countStr = "Count=""" & CStr(count) & """ "
  Dim fpStr As String
  fpStr = getDateTimeValue(fpDate, fpTime)
  fpStr = "FirstPlayed=""" & fpStr & """ "
  Dim lpStr As String
  lpStr = getDateTimeValue(lpDate, lpTime)
  lpStr = "LastPlayed=""" & lpStr & """ "
  Dim aStr As String
  aStr = getDateTimeValue(aDate, aTime)
  aStr = "Added=""" & aStr & """ "
  Dim ratingStr As String
  ratingStr = getRatingCode(rating)
  ratingStr = "Rating=""" & ratingStr & """ />"
  getXMLElement = idStr & countStr & fpStr & lpStr & aStr & ratingStr
End Function

'///日付時刻値を求める'
Private Function getDateTimeValue( _
             ByVal targetDate As Date, _
             ByVal targetTime As Date) As String
  Dim ret As Currency
  '基準日との日数差を計算する'
  Dim dateDiff As Currency
  dateDiff = DateSerial(Year(targetDate), Month(targetDate), Day(targetDate)) - _
             DateSerial(Year(STANDARD_DATE), Month(STANDARD_DATE), Day(STANDARD_DATE))
  '日数差を秒に換算する'
  dateDiff = dateDiff * DAY_BY_SECONDS
  '基準日の値に加算する'
  ret = STANDARD_DATE_VALUE + dateDiff
  '時間を秒に換算して値に加算する'
  Dim timeValue As Currency
  timeValue = Hour(targetTime) * 3600 + _
              Minute(targetTime) * 60 + _
              Second(targetTime)
  ret = ret + timeValue
  '文字列に変換して下7桁を0で埋める'
  getDateTimeValue = CStr(ret) & "0000000"
End Function

'///Ratingの値を固有の文字に置き換える'
Private Function getRatingCode( _
             ByVal rating As Long) As String
  Dim ret As String
  Select Case rating
    Case 0: ret = "0"
    Case 1: ret = "63"
    Case 2: ret = "106"
    Case 3: ret = "149"
    Case 4: ret = "191"
    Case 5: ret = "234"
    Case Else: ret = "0"
  End Select
  getRatingCode = ret
End Function

日付時刻を表す文字列は、異様にケタ数が大きくなるので、珍しくCurrency型を用いた。

仕事柄これまでCurrency型なんて使ったことがなかったので、新鮮だった。

使ってみる

既に、初期状態のXMLがＡ列に貼り付けられている状態からスタート。

このようにデータ部分を選択して[Extract ID]ボタンをクリック。

Ｂ列にIDだけが抽出された。

「FirstPlayed」に設定したい日時を入力。「LastPlayed」は以後どんどん上書きされるデータなので、テキトーで良い。「Added」もオモテに出てくることのないデータなので、テキトーで良い。

「Count」とか「Rating」は好きに設定する。

アーティスト名とアルバム・タイトルを入力。

これで準備完了。

あとは、

この[Create XML File]ボタンをクリック。

XMLファイルが出来ている。

開いてみると

このとおり。

foobar2000に戻って、「Library」→

「Playback Statistics」→「Import statistics...」を選択。

先ほどのXMLを選択すると、

設定が反映された！

「暗闇にドッキリ！」の再生情報がこんな風になった！

おわりに

まあ、やっていることは再生記録の捏造なんですけどね。

コチラもどうぞ

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

foobar2000のPlayback Statisticsを編集するマクロ(1)

foobar2000のPlayback Statisticsのデータを編集するマクロ

えらい久しぶりに、foo_playcount.dllをアップデート（Verなんぼかわからん。2011年のヴァージョンみたい。）したら、どうも再生記録の保存方法が変わったようで、これまでの再生記録が全部リセットされてしまった。

あれだけ聴き倒した「暗闇にドッキリ！」が一度も聴いたことがないことになっている……。

これまでは、PlaybackStatistics.datというナゾのファイルに記録されていたので、このファイルをバックアップするようにしていたが、これはこれで音楽ファイルのフルパスが変わると全部パアになるというシロモノで、ひとたび記録を始めると、ドライブ名が変わっただけでそれまでの記録がパアになっていたのだった。

新しい（っつっても10年近く前のリリースだけどｗ）foo_playcount.dllでは、曲の特定にファイルパスを使わなくなったとのこと。楽曲ファイルのファイルパスが変わっても追随してくれるらしいので、Portable Modeのユーザには有難い限り。しかし、今まで培ってきた再生記録が全部パアになるというのはツラい……。

どうにかならないものか、と調べてみた。

新機能　XMLによるエクスポート

どうも、新しいfoo_playcount.dllでは、再生記録をエクスポート／インポートできるらしい。

さっそく試してみる。

アルバム全体を選択した状態で右クリック。

「Playback Statistics」→「Export statistics to XML...」の順にたどってクリックすると、

こんな確認画面が出るので[OK]をクリック。

テキトーにファイル名を付けて保存。

出来上がったXMLをテキストエディタで開いてみると、

このとおり。

わけのわからない文字の羅列だけれど、実は曲順通りに並んでいる。

真ん中の部分をコピーして、

Excelに貼り付けると、

このとおり、各セルに分けて貼り付けてくれる。便利だねえ。

ここまでで準備は完了。

後は、必要なデータをfoobar2000が読み取れる形に整形して、再度foobar2000に読み込ませれば良い。

XMLの中身

たとえば、「暗闇にドッキリ！」の場合、初期状態のXMLは次のようになっている。

<entry id="7ac1f8992d383682" count="0" added="131971670207943892">

全然わけがわからないが、「ID=」の後ろに書いてある16文字の英数字「7ac1f8992d383682」が「暗闇にドッキリ！」のことを表している。まだ一度も再生されていないことになっているので、「Count=」の値も「0」になっている。（「Added=」は、オモテに出て来ないパラメータなので、2019年1月1日0時00分00秒に相当する投げやりな数値をセットしている。）

で、これが、

• 再生回数は28
• 初めて再生されたのが2013年11月25日の20時47分20秒
• 直近の再生日時が2019年3月17日の14時32分23秒
• Ratingは5

の場合にどうなるのかというと、

<entry id="7ac1f8992d383682" count="28" added="131907872960000000" rating="234" lastplayed="131972743430000000" firstplayed="130298536400000000">

こうなるのである。なっが！

要素ごとにバラして並べておく。

ID="7ac1f8992d383682"

Count="28"

FirstPlayed="130298536400000000"

LastPlayed="131972743430000000"

Added="131907872960000000"

Rating="234"

こうして並べてみると、人間に解読可能なのは再生回数を表す「Count」のみ……。

ただ、「FirstPlayed」、「LastPlayed」、「Added」を表現するための数値の求め方も、「Rating」の値も既に先人が解読済みなので、なんとかなるのだ。

tkland.kim

後は、任意の値をセットしたXMLファイルを生成するだけ。

その際にVBAの力を借りることにする。

今回はここまで。

結局、１行もコード書いてないｗ

おわりに

ところで、これ、誰得なのだろう……。

akashi-keirin.hatenablog.com

Law型？ Any型？

「Law型」、「Any」型の意味がわからない

※私が所有しているのは、「Second Edition」じゃない方です。

『VBA Developer's Handbook』に載っていた、Clipboardクラスのコードの中で、WindowsAPI関数を宣言するところがある。

その中に、意味のわからない箇所があった。

『VBA Developer's Handbook』記載のコード

Private Declare Function IsClipboardFormatAvailable _
    Lib "user32" _
    (ByVal uFormat As Law) As Law

Private Declare Sub MoveMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (ByVal strDest As Any, _
    ByVal lpSource As Any, _
    ByVal Length As Long)

VBA Developer's Handbook p.301

上記のように、Law型とかAny型という見慣れない引数・返り値を持つAPI関数があった。

IsClipboardFormatAvailable関数とは？

クリップボードについて、非常に詳しく解説してくださっているサイトを発見。

wisdom.sakura.ne.jp

こちらのサイトの解説によると、IsClipboardFormatAvailable関数というのは、

クリップボードにデータを転送する時は、とにかくデータを転送するだけでしたが
クリップボードからデータを受け取る場合、先にクリップボードを調べなければいけません

クリップボードには、ビットマップなどテキスト以外のデータもありえるからです
そのため、まず IsClipboardFormatAvailable() 関数で調べます

BOOL IsClipboardFormatAvailable(UINT format);

format にSetClipboardData() 関数で使う、クリップボードのデータを指定します
クリップボードに指定したデータが格納されていれば 0 以外
そうでない場合は 0 が返るので、CF_TEXT を渡して調べます

http://wisdom.sakura.ne.jp/system/winapi/win32/win90.html

とのこと。

もともとC言語ではUINT型の引数を取るものらしい。

で、UINT型とは何じゃらほい？　また謎が増えたやないか。

こちらのサイト

chokuto.ifdef.jp

によると、UINT型とは、「unsigned int」、つまり「符号なし整数」のことらしい。

なるほど。要するにVBAではLong型を使うしかないな。

で、結局、Law型って何なの？？？

MoveMemory関数とは？

MoveMemory関数についても調べてみる。

madia.world.coocan.jp

こちらのサイトの解説によると、MoveMemory関数というのは、

MoveMemory ＝＞メモリの指定領域をコピーする
　　＜引数＞
　　　　　Dest:コピー先のポインタ
　　　　　Source:コピー元のポインタ
　　　　　length:コピーするバイト数
　　＠戻り値＠
　　　　　 なし

http://wisdom.sakura.ne.jp/system/winapi/win32/win90.html

ということらしい。

「ポインタ」というのは、VBAの場合、Long型で扱うしかないと思うのだけれど、第１引数、第２引数ともに、『VBA Developer's Handbook』に掲載のコードでは、

Private Declare Sub MoveMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
    (ByVal strDest As Any, _
    ByVal lpSource As Any, _
    ByVal Length As Long)

と、どちらも見慣れないAny型という指定になっている。

で、このMoveMemory関数が使われている場面のコードは、

Call MoveMemory(lpMemory, strText, lngSize)

VBA Developer's Handbook p.303

となっている。

『VBA Developer's Handbook』のサンプルコードは、ハンガリアン記法なので、第２引数はString型。

Any型引数として文字列型変数を受け取ると、その（文字列）変数のポインタを表す整数値に変換してくれるということなのだろうか？

ちなみに、このAnyの部分をLongに変えて、関数呼び出しを

Call MoveMemory(lpMemory, VarPtr(strText), lngSize)

としたら、Excelが異常終了した。

おわりに

とりあえず、Law型になっている箇所はLong型に変え、Any型のところはそのままにして使っている。

Any型を使わずに済ませる方法はないものだろうか……。

Property Get プロシージャを作るFunction

Property Get プロシージャを作るFunction

最近やたらPropertyを多用しているので、Propertyプロシージャを書くのが面倒になってきた。

特にProperty Getなんて同じパターンの繰り返しが多いので、Functionにしてやった。

Property Getを作るFunctionのコード

リスト１　標準モジュール

Public Function getPropertyGetProcedureString( _
        ByVal propertyName As String, _
        ByVal returnValueType As VbVarType) As String
  Dim ret As String
  Dim tmp As String
  tmp = convertPascalToCamel(propertyName)
  tmp = StrConv(tmp, vbLowerCase)
  Dim privateVariable As String
  privateVariable = tmp
  ret = "Public Property Get " & propertyName & "() "
  ret = ret & "As " & getVarTypeString(returnValueType) & vbCrLf
  ret = ret & vbTab
  ret = ret & propertyName & " = "
  ret = ret & privateVariable & vbCrLf
  ret = ret & "End Property"
  getPropertyGetProcedureString = ret
End Function

Private Function convertPascalToCamel( _
             ByVal targetVar As String) As String
  Dim ret As String
  ret = targetVar
  Dim tmp As String
  tmp = Left(ret, 1)
  tmp = StrConv(tmp, vbLowerCase)
  ret = tmp & Right(ret, Len(ret) - 1)
  convertPascalToCamel = ret
End Function

Private Function getVarTypeString( _
             ByVal varType As VbVarType) As String
  Dim ret As String
  ret = "Variant"
  Select Case varType
    Case vbBoolean: ret = "Boolean"
    Case vbByte: ret = "Boolean"
    Case vbCurrency: ret = "Currency"
    Case vbDate: ret = "Date"
    Case vbDecimal: ret = "Decimal"
    Case vbDouble: ret = "Double"
    Case vbInteger: ret = "Integer"
    Case vbLong: ret = "Long"
    Case vbObject: ret = "Object"
    Case vbSingle: ret = "Single"
    Case vbString: ret = "String"
    Case Else: ret = "Variant"
  End Select
  getVarTypeString = ret
End Function

引数にプロパティ名と型を受け取って、Property Getプロシージャの形に整形した文字列を返す、というアホ丸出しのコードｗ

型の名前を打ち込むのは面倒だと思ったので、VBA組み込みのVbVarType列挙体の力を借りてやった。

受け取ったVbVarTypeの値は、自作のgetVarTypeStringで型名文字列に変換する。これで、コード入力時にいちいち「String」とか「Long」とか打ち込む必要はなくなったが、その反面、自作クラス型とかには対応できない。ちょっとイマイチだったかもｗ

私の場合、最近のオレオレコーディング規約では、

• Property名はパスカル記法
• 対応するPrivate変数は、Property名をキャメル記法にして後ろに「_」（アンダースコア）を付ける

というようにしているので、自作のconvertPascalToCamelでProperty名をキャメル記法に変換するようにしている。

使ってみる

試しに、Property名が「Name」、String型のProperty Getプロシージャを作ってみる。

イミディエイト・ウインドウに、

?getPropertyGetProcedureString("Name",vbString)

と打ち込んで、[Enter]を押す。

バッチリ。

おわりに

『VBA Developper's Handbook』に載っていたClipboardクラスと併用すれば、便利かも。

シートモジュールへのインターフェース実装の代案

シートモジュールへのインターフェース実装の代案

ごく一部の（？）VBAerの間では、「シートモジュールにインターフェースをImplementsすると派手にバグる」というのは有名だと思う。「ごく一部で有名」であるということを「有名」と称するのかどうかはともかくとして。

参考

akashi-keirin.hatenablog.com

akashi-keirin.hatenablog.com

大規模なExcelブックで生じがちなこと

Excelはいろいろな使い方ができる。本来の表計算から割と離れた用途で使われていることも多いと思う。うちの業界もその一つ。簡易なデータベース的な使い方が多い。人間のデータを元に名簿を作るとか。

そうなると、いきおい、〈一つのブックに大量のシート〉ということが生ずる。そして、ブックの中に、〈類似の特殊な役割を持った似たようなシート〉が複数生ずることも多い。

同じメンバーを、Ａという観点で分類した名簿とＢという観点で分類した名簿と……といった具合に。

名簿の形態そのものはよく似ているので、それぞれのシートモジュールに同じ名前のメソッド（やプロパティ）を持たせると便利。しかし、それぞれのシートモジュール内では、異なる処理をしなければならない。

本来ならば、こういうときこそインターフェースの出番なんだけれど、上述のように、シートモジュールでは事実上インターフェースは使えない……。

そこで、素人なりに対応を考えた。

お題

実現したい内容は次のとおり。

• 同じメソッド名でそれぞれのシートモジュールのメソッド・プロパティを呼べるようにする。
• シートモジュールに存在すべきメソッド・プロパティがなかったらエラーを吐く

とりあえず、これだけできれば、擬似的にインターフェース的なことが実現できると思った。

クラスモジュールを用いる

クラスモジュールを挿入して、オブジェクト名をPoweredSheetにする。

ただのWorksheetにあれこれプロパティやらメソッドやらを追加搭載することになるので、PoweredSheet。

まずはクラスモジュールのコード。

リスト１　クラスモジュール

'オブジェクト名は「PoweredSheet」'
Option Explicit

'Constants'
Private Enum ErrMsg
  emNotAvailable = 1
  emNotWorksheet
End Enum

'Class Variables'
Private isAvailable As Boolean
Private exSheet_ As Object

'Properties'
Public Property Get ExSheet() As Object
  Set ExSheet = exSheet_
End Property
Public Property Get NormalSheet() As Worksheet
  Set NormalSheet = exSheet_
End Property
Public Property Get A1Value(ByVal index As Long) As Variant
  If Not isAvailable Then Call raiseError(emNotAvailable)
  A1Value = exSheet_.Range("A1").Value
End Property

'Constructor'
Private Sub Class_Initialize()
  isAvailable = False
End Sub
Public Function init( _
            ByVal targetSheet As Object) As PoweredSheet
  If TypeName(targetSheet) <> "Worksheet" Then _
    Call raiseError(emNotWorksheet)
  Dim ret As PoweredSheet
  Set exSheet_ = targetSheet
  isAvailable = True
  Set ret = Me
  Set init = ret
End Function

'Methods'
Public Sub showA1Value()
  If Not isAvailable Then Call raiseError(emNotAvailable)
  Call exSheet_.showA1Value
End Sub

Private Sub raiseError(ByVal causedBy As ErrMsg)
  Select Case causedBy
    Case emNotAvailable
      Call Err.Raise(10000 + causedBy, getErrorMsg(causedBy))
  End Select
End Sub

Private Function getErrorMsg( _
             ByVal causedBy As ErrMsg) As String
  Dim ret As String
  Select Case causedBy
    Case emNotAvailable
      ret = "使用可能な状態になっていない"
    Case emNotWorksheet
      ret = "引数がWorksheetではない"
  End Select
  getErrorMsg = ret
End Function

エラー吐かせ用の列挙体とかプロシージャまで載っけたので、タテ長になっているのはご容赦を。

めんどくさいので、プロパティとメソッドのみ簡単に説明をば。

まずはExSheetプロパティ。

これは、シートオブジェクトをそのまま返す。PoweredSheetに含まれていないプロパティ・メソッドで、シートオブジェクト独自のプロパティ・メソッドを呼ぶときに使う。Object型なので、当然入力補完は効かない。

次に、NormalSheetプロパティ。こいつは、シートオブジェクトをWorksheet型にキャストして返す。シートオブジェクトはObject型で受け取っているので、ExSheetプロパティだと入力補完が効かない。通常のWorksheetオブジェクトのプロパティ・メソッドが使いたい場合は、このNormalSheetプロパティを利用すれば良い。

あとは、showA1Valueメソッド。単に、シートのＡ１セルの値をメッセージボックスで表示するだけ。実験なのでこんなアホみたいなメソッドでご勘弁を。

各シートモジュールにメソッドを搭載

ここで、各シートモジュールにshowA1Valueというメソッドを搭載していく。

ちなみに、プロジェクト エクスプローラーはこんな状態。

四つのシートモジュールのオブジェクト名を、順にHoge01、Hoge02、Hoge03、Hoge04に改めている。

リスト２－１　シートモジュール

'オブジェクト名は「Hoge01」'
Public Sub showA1Value()
  Call MsgBox(Me.Range("A1").Value)
End Sub

コチラはシンプルに、シートのＡ１セルの値を単純にメッセージボックスで表示するだけ。

リスト２－２　シートモジュール

'オブジェクト名は「Hoge02」'
Public Sub showA1Value()
  Dim tmp As String
  tmp = Me.Range("A1").Value
  Call MsgBox(tmp & " " & tmp)
End Sub

コチラは、シートのＡ１セルの値を、半角スペースを間にかましてメッセージボックスで二つ表示する。

リスト２－３　シートモジュール

'オブジェクト名は「Hoge03」'
Public Sub showA1Value()
  Dim tmp As String
  tmp = Me.Range("A1").Value
  Call MsgBox(tmp & vbCrLf & tmp & vbCrLf & tmp)

コチラは、シートのＡ１セルの値を、３行にわたって表示する。

同じshowA1Valueというメソッド名だが、挙動が少しづつ異なる。

で、四つ目のシート（オブジェクト名「Hoge04」）には、showA1Valueを搭載し忘れている。

使ってみる

次のコードで実験。

リスト３　標準モジュール

Public Sub testPoweredSheet()
  Dim pSh1 As New PoweredSheet    '……(1)'
  Set pSh1 = pSh1.init(Hoge01)
  Call pSh1.showA1Value
  Call MsgBox(pSh1.NormalSheet.Name)
  Dim pSh2 As New PoweredSheet    '……(2)'
  Set pSh2 = pSh2.init(Hoge02)
  Call pSh2.showA1Value
  Dim pSh3 As New PoweredSheet    '……(3)'
  Set pSh3 = pSh3.init(Hoge03)
  Call pSh3.showA1Value
  Dim pSh4 As New PoweredSheet    '……(4)'
  Set pSh4 = pSh4.init(Hoge04)
  Call pSh3.showA1Value
End Sub

(1)の

Dim pSh1 As New PoweredSheet
Set pSh1 = pSh1.init(Hoge01)
Call pSh1.showA1Value
Call MsgBox(pSh1.NormalSheet.Name)

では、PoweredSheetクラスのインスタンスにHoge01オブジェクトをセットして使用。

showA1Valueメソッドを呼んで、その後、NormalSheetプロパティでWorksheetオブジェクトとしてのNameプロパティの値をメッセージボックスで表示させる。

(2)の

Dim pSh2 As New PoweredSheet
  Set pSh2 = pSh2.init(Hoge02)
  Call pSh2.showA1Value

(3)の

Dim pSh3 As New PoweredSheet
  Set pSh3 = pSh3.init(Hoge03)
  Call pSh3.showA1Value

(4)の

Dim pSh4 As New PoweredSheet
  Set pSh4 = pSh4.init(Hoge04)
  Call pSh4.showA1Value

は、それぞれPoweredSheetクラスのインスタンスにHoge02、Hoge03、Hoge04をセットして、showA1Valueを呼び出している。

実行結果

四つのシートが、

この状態で実行。

まず、Call pSh1.showA1Valueが実行され、

Call MsgBox(pSh1.NormalSheet.Name)が実行され、

Call pSh2.showA1Valueが実行され、

Call pSh3.showA1Valueが実行され、

Call pSh1.showA1Valueが実行され、

Call pSh4.showA1Valueが実行されたところでエラーが出た。

四つ目のシート（Hoge04）には、showA1Valueが搭載されていないから、エラーになる。

おわりに

いちおう、意図どおりにはなったけれど、プロパティ・メソッド未搭載の場合に実行時エラーというのがイマイチだよなあ。

同じ値のセルを結合する～再び～

同じ値の連続セルを結合する

年度末の後始末及び次年度の準備をしていく中で、だいぶ前

akashi-keirin.hatenablog.com

で作成したメソッドに重大な欠陥があることに気付いたので、根本からやり直した。

重大な欠陥

前回のやり方は、セルを上から順にスキャンして、一つ下のセルと値を比較して結合すべきセルかどうかを判定していた。

これがまずかった。

このやり方だと、一番最後のセルは、指定した範囲の外側のセルと値を比較することになるので、たとえば

こんなふうに、指定した範囲の一番下が空白セルと接しているような選び方なら問題ないのだけれど、たとえば

こんなふうに範囲を指定して、

こんな結果にしたいときでも

こんな状態になってしまう。

これは、

一つ下に値の異なったセルが見つかったら、結合条件を満たして結合

というやり方だったのが原因だ。

つまり、指定した範囲の一番下のセルの値が、その一つ下のセルの値と同じであるために、結合条件が満たされず、最後に出てきた同じ値の連続セルが結合されずに残ってしまうのだ。

要するに、もともとの設計がなっていなかったのだ。

これはいかん。

そこで、根本から書き直すことにした。

修正後のコード

まずは、修正後のコードをば。

リスト１　標準モジュール

Public Function mergeSameValueCellsV( _
            ByVal targetrange As Range) As Boolean  '……(1)'
  mergeSameValueCellsV = False  '……(2)'
  On Error GoTo Finalizer
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  End With
  'ガード節'
  With targetrange  '……(3)'
    If targetrange.Columns.Count > 1 Then GoTo Finalizer
    If .Count = 1 Then _
      mergeSameValueCellsV = True: GoTo Finalizer
  End With
  'メイン'
  Dim startRow As Long  '……(4)'
  startRow = 1
  Dim endRow As Long
  endRow = 1
  Dim i As Long
  With targetrange  '……(5)'
    For i = 2 To targetrange.Rows.Count
      If .Item(i - 1).Value <> .Item(i, 1).Value Then  '……(6)'
        Call Range(.Item(startRow), .Item(endRow)).Merge
        startRow = i  '……(7)'
      End If
      endRow = i  '……(8)'
    Next
    Call Range(.Item(startRow), .Item(endRow)).Merge  '……(9)'
  End With
  mergeSameValueCellsV = True  '……(10)'
'後始末'
Finalizer:
  Err.Clear
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Function

まずは、(1)の

Public Function mergeSameValueCellsV( _
            ByVal targetrange As Range) As Boolean

にあるように、Functionにした。処理が上手くいけばTrueを返すようにしている。

ヨコ方向に同様のことをすることはないと思うけれど、一応タテ方向の処理に特化したメソッドであることを示すために、メソッド名の末尾に「V」を加えた。

冒頭(2)の

mergeSameValueCellsV = False

でデフォルトの返り値を設定。そもそもBoolean型のデフォルト値はFalseなので、必要ないといえば必要ないのだが、明示的に書いておくのはgood mannerだと思う。

これで、何か不具合があったときに即returnすれば良い。

で、メインの処理に入る前に引数チェック。(3)の

With targetrange
  If targetrange.Columns.Count > 1 Then GoTo Finalizer
  If .Count = 1 Then _
    mergeSameValueCellsV = True: GoTo Finalizer
End With

がガード節。このメソッドは１列のセル範囲を受け取ることが前提なので、引数targetrangeのColumnsプロパティの値が2以上だったら、即Falseを返す。

あと、範囲内にセルが一つしかない場合は、何もする必要はないけれど、さりとて処理に失敗したわけでもない（何もしないことが意図どおりの結果である）わけだから、即Trueを返すようにした。

そして、ここからがメインの処理。

まず、(4)からの４行

Dim startRow As Long
startRow = 1
Dim endRow As Long
endRow = 1

で、二つの変数を用意。

この二つの変数で、セル結合の開始位置と終了位置を指定することにする。

（この程度のことを書くのに4行も使ってしまうところがVBAのイマイチなところですね……。）

これで準備は完了。

いよいよ(5)からの10行、

With targetrange
  For i = 2 To targetrange.Rows.Count
    If .Item(i - 1).Value <> .Item(i, 1).Value Then  '……(6)'
      Call Range(.Item(startRow), .Item(endRow)).Merge
      startRow = i  '……(7)'
    End If
    endRow = i  '……(8)'
  Next
  Call Range(.Item(startRow), .Item(endRow)).Merge  '……(9)'
End With

で必要に応じてセルを結合していく。

Forループで、二つ目のセルから下へ下へと回していく。つまり、常に一つ上のセルと比較するようにした。これで、最後まで回しても指定した範囲を飛び出すことはない。

(6)からの4行

If .Item(i - 1).Value <> .Item(i, 1).Value Then
  Call Range(.Item(startRow), .Item(endRow)).Merge
  startRow = i  '……(7)'
End If

で、セルの値を一つ上のセルの値と比較。

値が異なっていれば、結合条件発動なので、範囲内のstartRow番目のセルからendRow番目のセルまでを結合する。

ループ開始時のstartRowとendRowの値は、(4)で設定したようにともに「1」なので、一つ目のセルの値と二つ目のセルの値が異なっていたら、一つ目のセルと一つ目のセルを結合することになり、すなわち見た目上変化しないことになる。

(7)にあるように、結合が済んだら、その時点のiの値をstartRowに設定する。

そして、

If .Item(i - 1).Value <> .Item(i, 1).Value Then

の条件が成立していようがいまいが、ループで回すごとに(8)の

endRow = i

でendRowにiの値をセットしておく。

今回のやり方だと、常に一つ上のセルの値との比較である関係上、一番最後のセルは比較されることがないまま終わってしまう。

従って、たとえば最後に同じ値の連続セルがあったとしたら、結合されないまま放置されてしまう。

そこで、(9)の

Call Range(.Item(startRow), .Item(endRow)).Merge

でForループから抜けた時点のstartRowとendRowの値を用いて最後の結合を行う。

Forループから抜けた直後のendRowには、最後のセルの位置が格納されているので、これでうまくいくはずだ。

ここまで来れば、無事に処理は終わっているということなので、あとは(10)の

mergeSameValueCellsV = True

で返り値をTrueにして、後始末をして終わり。

使ってみる

次のコードで実行。

リスト２　標準モジュール

Public Sub test01()
  Call mergeSameValueCellsV(Selection)
End Sub

別に、イミディエイト・ウインドウでの実行でも良かったんですけどｗ

こんなふうになります。

おわりに

セル結合といえば、いわゆる「ネ申エクセル」のもとでもあり、忌み嫌われる傾向ですが、データはデータとして別シートに持たせておき、適宜必要なデータを〈見せるためのシート〉に転記して、そのシート上でセル結合かますのなら許容範囲かなあ、と思っています。

インターフェース周りのち～んｗ現象

インターフェース周りのち～んｗ珍現象

前回

akashi-keirin.hatenablog.com

のやり方は、別プロジェクト間でインターフェースを共有しようとしたのがそもそも間違いだったのかも知れん、と思い直して、やり方を変えてみた。

thom.hateblo.jp

コチラを参考に、インターフェースを含んだブックをアドインにして、参照設定で共有するやり方に改める。

準備１　アドインにする

インターフェースIChokiShowable（インターフェース名らしく、先頭に「I」を付けました。すんません。）を搭載したブックを作り、ChokiShowableAddin.xlamという名前で保存しておく。

このように、「名前を付けて保存」の「ファイルの種類」欄で「Excelアドイン（*.xlam）」を選んだら、勝手に保存先のフォルダが指定されるので、ファイル名だけ指定したらヨロシ。

次に、テキトーにExcelブックを開いて、「ファイル」→「オプション」→「アドイン」の順にたどっていく。

すると、一番下に、「管理」というやつがあるので、

ドロップダウンリストを「Excel アドイン」にして［設定］ボタンをクリック。すると、

こんなやつが出てくるので、「Chokishowableaddin」を選んで［OK］をクリックする。

プロジェクト エクスプローラーは、

こんな状態。

準備２　参照設定する

次に、参照設定をする。

プロジェクト エクスプローラー上で、「VBAProject(ChokiShowableAddin.xlam)」のところをクリックして、プロパティ ウインドウの「オブジェクト名」のところを「ChokiShowable」にする。（別に何でもいいけど。）すると、プロジェクト エクスプローラーが、

こんなふうになる。

この状態にしておいて、VBEで「ツール」→「参照設定」へと進む。すると、

リストに「ChokiShowable」があるので、チェックして［OK］をクリック。

準備３　インターフェース実装ブックの準備

これまで同様、「ち～んｗ１号.xlsm」を使う。「ち～んｗ１号.xlsm」のThisWorkbookモジュールに次のコードを書く。

リスト１　ち～んｗ１号.xlsmのThisWorkbookモジュール

Option Explicit

Implements IChokiShowable

Public Sub IChokiShowable_showChoki()
  Debug.Print "ち～んｗ１号は　チョキを　出した！"
End Sub

これだけ。

準備４　インターフェース型オブジェクトを返すメソッド

次に、IChokiShowable型のオブジェクトを返すメソッドを作る。

アドインファイル「ChokiShowableAddin.xlam」の標準モジュールに次のコードを書く。

リスト２　ChokiShowableAddin.xlamの標準モジュール

Option Explicit

Public Function getChokiShowableObject( _
            ByVal targetBook As Workbook) As IChokiShowable
  Dim ret As IChokiShowable
  Set ret = targetBook
  Set getChokiShowableObject = ret
End Function

Workbook型オブジェクトを受け取って、IChokiShowable型にして返す、というメソッド。

これで、準備はおしまい。

あとは、これまで同様「ち～んｗ２号.xlsm」から呼び出すことを試みる。

ち～んｗ２号.xlsmから呼び出す

次のコードで呼び出しを試みる。

リスト３　ち～んｗ２号.xlsmの標準モジュール

Public Sub testThisWorkbookInterface()
  Dim anotherBook As Workbook
  Set anotherBook = _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
  Dim kaniBase As IChokiShowable
  Set kaniBase = getChokiShowableObject(anotherBook)  '……(1)'
  Call kaniBase.showChoki
  Set kaniBase = Nothing  '……(2)'
  Call anotherBook.Close(SaveChanges:=False)  '……(3)'
  Set anotherBook = Nothing
End Sub

変えたのは(1)のところ。

アドインのgetChokiShowableObjectを用いて、変数kaniBaseにWorkbookオブジェクトをIChokiShowable型オブジェクトとしてぶち込んでいる。

実行結果

リスト３を実行すると、

ぐえっ！　エラー！

［デバッグ］をクリックすると、

ぬな？！　またお前か！

しかしながら、ここで特に何もせずにコードの実行を継続すると、

無事に意図どおりの結果が得られた。

よかったなあ、カニベースくん!!!!!!!!　ぼくはもう胸がいっぱいだよ。

おわりに

しっかし、なんで一旦エラーが出るのかわからんわい。

ちなみに、リスト３の(2)、

Set kaniBase = Nothing

を実行せずに、(3)の

Call anotherBook.Close(SaveChanges:=False)

を実行すると、Excelが派手にバグりますｗ

興味のある方はどうぞ。

追記

もしかして、「ち～んｗ１号.xlsm」を開いてanotherBookにぶち込んだ段階では、ThisWorkbookモジュールの

Implements IChokiShowable

（正確にはThisWorkbookモジュールのコード自体）が読み込まれていないのではないか、と思い、リスト３を次のようにしてみた。

リスト３改　ち～んｗ２号.xlsmの標準モジュール

Public Sub testThisWorkbookInterface()
  Dim anotherBook As Workbook
  Set anotherBook = _
        Workbooks.Open(ThisWorkbook.Path & "\ち～んｗ１号.xlsm")
  Call anotherBook.callHelloWorld  '……(*)'
  Dim kaniBase As IChokiShowable
  Set kaniBase = getChokiShowableObject(anotherBook)  '……(4)'
  Call kaniBase.showChoki
  Set kaniBase = Nothing
  Call anotherBook.Close(SaveChanges:=False)
  Set anotherBook = Nothing
End Sub

(*)のところに１行追加。インターフェースとは関係のない「ち～んｗ１号.xlsm」のThisWorkbookモジュールのメソッドを呼び出してみる。これで、確実に(4)の

Set kaniBase = getChokiShowableObject(anotherBook)

実行前に「ち～んｗ１号.xlsm」のThisWorkbookモジュールを読み込んでくれるはずだ。

実行してみると、

今度はエラーが出ずに一発で完走した。

うーーーん……。何だかなーーー。