foobar2000の楽曲再生データを編集するためのモジュール

foobar2000の楽曲データをいじくるためのモジュール

作ったので公開。

コード

foobar2000のPlaybackStatisticsでエクスポートできるXMLをいじくるためのメソッド集的なモジュールを作成した。

一挙公開する。（2019/9/16更新）

リスト１　標準モジュール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 = #1/1/2012#
'一日あたりの秒数'
Private Const DAY_BY_SECONDS As Currency = 86400
Private Const HOUR_BY_SECONDS As Currency = 3600
Private Const MINUTE_BY_SECONDS As Currency = 60

'///XMLファイルの中身を作る'
Public Function createXMLContents( _
            ByVal contents As String) As String
  Const XML_DECLARATION As String = _
        "" & _
        vbCrLf
  Dim ret As String
  If Not (Right(contents, 2) = vbCrLf) Then _
    contents = contents & vbCrLf
  ret = XML_DECLARATION
  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 & ""
  getXMLElement = idStr & countStr & fpStr & lpStr & aStr & ratingStr
End Function

'///FB2Kの楽曲データからID値を取得する'
Public Function getID( _
            ByVal targetElement As String) As String
  Const ADD_COUNT As Long = 11  '最初の「<」の11字後ろがIDの先頭'
  Const ID_LENGTH As Long = 16  'ID値は16文字'
  Dim ret As String
  Dim startPos As Long
  startPos = InStr(1, targetElement, "<") + ADD_COUNT
  ret = Mid(targetElement, startPos, ID_LENGTH)
  getID = ret
End Function

'///FB2Kの楽曲データからFirstPlayedのDate型データを取得する'
Public Function getFirstPlayDateTime( _
            ByVal targetElement As String) As Date
  Dim ret As Date
  ret = 0
  Dim targetSerial As Currency
  targetSerial = getFirstPlayedSerial(targetElement)
  'FirstPlayedの値がないときは、0が返る'
  If targetSerial = 0 Then GoTo Finalizer
  ret = getDateTime(targetSerial)
Finalizer:
  getFirstPlayDateTime = ret
End Function

'///FB2Kの楽曲データからLastPlayedのDate型データを取得する'
Public Function getLastPlayDateTime( _
            ByVal targetElement As String) As Date
  Dim ret As Date
  ret = 0
  Dim targetSerial As Currency
  targetSerial = getLastPlayedSerial(targetElement)
  'LastPlayedの値がないときは、0が返る'
  If targetSerial = 0 Then GoTo Finalizer
  ret = getDateTime(targetSerial)
Finalizer:
  getLastPlayDateTime = ret
End Function

Public Function getAddedDateTime( _
            ByVal targetElement As String) As Date
  Dim ret As Date
  ret = 0
  Dim targetSerial As Currency
  targetSerial = getAddedSerial(targetElement)
  'Addedの値がないときは、0が返る'
  If targetSerial = 0 Then GoTo Finalizer
  ret = getDateTime(targetSerial)
Finalizer:
  getAddedDateTime = ret
End Function

'///日付時刻値を求める'
Private Function getDateTimeValue( _
             ByVal targetDate As Date, _
             ByVal targetTime As Date) As String
  Const HOUR_TO_SECONDS As Currency = 3600
  Const MINUTE_TO_SECONDS As Currency = 60
  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) * HOUR_TO_SECONDS + _
              Minute(targetTime) * MINUTE_TO_SECONDS + _
              Second(targetTime)
  ret = ret + timeValue
  '文字列に変換して下7桁を0で埋める'
  getDateTimeValue = CStr(ret) & "0000000"
End Function

'///FB2Kの楽曲データからFirstPlayedのシリアル値を取得する'
Private Function getFirstPlayedSerial( _
            ByVal targetElement As String) As Currency
  Dim ret As Currency
  ret = getDateTimeSerial(targetElement, "FirstPlayed=""")
  getFirstPlayedSerial = ret
End Function

'///FB2Kの楽曲データからLastPlayedのシリアル値を取得する'
Private Function getLastPlayedSerial( _
            ByVal targetElement As String) As Currency
  Dim ret As Currency
  ret = getDateTimeSerial(targetElement, "LastPlayed=""")
  getLastPlayedSerial = ret
End Function

'///FB2Kの楽曲データからAddedのシリアル値を取得する'
Private Function getAddedSerial( _
            ByVal targetElement As String) As Currency
  Dim ret As Currency
  ret = getDateTimeSerial(targetElement, "Added=""")
  getAddedSerial = ret
End Function

'///日付時刻を表すFB2K独自のシリアル値（の上11ケタ）を返す'
'   【例】FirstPlayedのシリアル値を取得したいときは、引数keyWordに'
'         "FirstPlayed="""を指定する。'
Private Function getDateTimeSerial( _
             ByVal targetElement As String, _
             ByVal keyWord As String) As Currency
  'シリアル値18文字中上11ケタを返す'
  Const NUMBER_OF_DIGITS As Long = 11
  Dim ret As Currency
  Dim pos As Long
  pos = InStr(1, targetElement, keyWord)
  If pos = 0 Then ret = 0: GoTo Finalizer
  'シリアル値開始位置を割り出す。LastPlayedなら、'
  '「LastPlayed="」の開始位置に「LastPlayed="」の文字数を足せばよい。'
  pos = pos + Len(keyWord)
  ret = CCur(Mid(targetElement, pos, NUMBER_OF_DIGITS))
Finalizer:
  getDateTimeSerial = ret
End Function

'///FB2Kの日付時刻コードを、Date型に変換する'
Private Function getDateTime( _
            ByVal datetimeSerial As Currency) As Date
  Dim ret As Date
  '日付時刻コードの上11ケタを取得'
  datetimeSerial = Left(datetimeSerial, 11)
  '基準日（2012/1/1）との差分(FB2K独自のシリアル値)を取得'
  Dim serialDiff As Currency
  serialDiff = datetimeSerial - STANDARD_DATE_VALUE
  '基準日に加算する日数を取得'
  Dim addDay As Currency
  addDay = serialDiff \ DAY_BY_SECONDS
  '加算日数を加算'
  ret = STANDARD_DATE + addDay
  '加算する時間を取得'
  Dim addHour As Long
  Dim tmp As Long
  tmp = serialDiff Mod DAY_BY_SECONDS
  addHour = tmp \ HOUR_BY_SECONDS
  '加算する分を取得'
  Dim addMinute As Long
  tmp = tmp Mod HOUR_BY_SECONDS
  addMinute = tmp \ MINUTE_BY_SECONDS
  '加算する秒を取得'
  Dim addSecond As Long
  addSecond = tmp Mod MINUTE_BY_SECONDS
  '時刻を追加'
  ret = ret + TimeSerial(addHour, addMinute, addSecond)
  getDateTime = ret
End Function

'///FB2Kの楽曲データからCountの値を取得する'
Public Function getCount( _
            ByVal targetElement As String) As Long
  Dim ret As Long
  ret = 0
  ret = CLng(getQuortedValue(targetElement, "Count="""))
  getCount = ret
End Function

'///FB2Kの楽曲データからRatingの値を取得する'
Public Function getRating( _
            ByVal targetElement As String) As Long
  Dim ret As Long
  'Rating文字列を取得'
  ret = CLng(getQuortedValue(targetElement, "Rating="""))
  '数値（0～5）に変換'
  ret = getRatingValue(CStr(ret))
  getRating = ret
End Function

'///ダブルクォーテーションで囲まれた値を文字列として取り出す'
'   【例】Count="12" から「12」を取り出したいときは、引数KeyWordに'
'         "Count="""を渡す。'
Private Function getQuortedValue( _
             ByVal targetElement As String, _
             ByVal keyWord As String) As String
  Dim ret As String
  ret = ""
  'keyWordがtargetElement内になければ「0」を返す'
  Dim n As Long
  n = InStr(1, targetElement, keyWord)
  If n = 0 Then ret = "0": GoTo Finalizer
  'keyWordの次の文字から１文字づつ、次の「"」にぶつかるまで連結'
  n = n + Len(keyWord)
  Do
    ret = ret & Mid(targetElement, n, 1)
    n = n + 1
  Loop Until Mid(targetElement, n, 1) = """"
Finalizer:
  getQuortedValue = ret
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
'///Ratingの固有文字を数値に置き換える'
Private Function getRatingValue( _
             ByVal ratingCode As String) As Long
  Dim ret As Long
  ret = 0
  Select Case ratingCode
    Case "0":   ret = 0
    Case "63":  ret = 1
    Case "106": ret = 2
    Case "149": ret = 3
    Case "191": ret = 4
    Case "234": ret = 5
  End Select
  getRatingValue = ret
End Function

とりあえず、めんどくさいので説明の類は省略。

上記メソッドをうまく使えば、foobar2000の再生データをほぼ自由自在に書き換えることができる。

使用例

現在のところ、私はExcelのワークシートで

このような表を作り、Ａ列の「XML Element」欄にPlayback StatisticsでエクスポートしたXMLの要素を貼り付けておき、マクロでＢ列以降に一旦データを出力。編集して再度XMLファイル化し、foobar2000にインポート、という手順で楽曲の再生データを編集している。

動作の様子は

こんな感じ。

ちなみに、foobar2000上では

こんな感じです。

おわりに

あまり需要はなさそうですね。寂しいなあ。