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