読書メータのデータをエクセルに保存する

  • 概要

読書メータのデータをエクセルに保存するマクロです。具体的には以下の処理を自動化しています。

  • 読書メータのページへログイン
  • 読んだ本リストのページを巡回して、日付+読書ページ数+読書冊数を取得
  • アクティブシートへ読書情報を出力

趣味で作ったものなので、このプログラムによって発生した損害などは当方は一切責任を持ちませんです。転載も禁止ですが、このブログへのリンクはフリーです。

 

  • テスト環境

当方のテスト環境は以下の通りです。機種依存があるかどうかは不勉強なため、わかりません(^^)

 

  • 使用にあたって 

使用する場合は、読書メータのIDとパスワードを、strMailとstrPassに入力してください。

先にIE読書メーターでログインした状態(セッションを開始した状態)でマクロを実行すると、IDとパスワードの設定なしでも実行できます。神に誓って、パスワードを抜き取ったりしてませんが、気にされる方はそうしてください。

 

「ツール>参照設定」で以下のものを選択してから実行してください。

 

 

  • 出力形式 

出力はアクティブシートの二行目以降になされます。

  • A列:日付
  • B列:読書ページ数
  • C列:読書冊数
  • D列:累積読書ページ数
  • E列:累積読書冊数

 

  • コード

 

Private Sub dm2xls()

    

    '変数宣言

    Dim re As RegExp

    Dim objIE As InternetExplorer

    Dim intCount As Integer

    Dim dicReadPage As Scripting.Dictionary

    Dim dicReadCount As Scripting.Dictionary

    Dim strMail, strPass, strUrl As String

    

    '正規表現

    Set re = New RegExp

    

    'IDとパスワード

    strMail = ""

    strPass = ""

    strUrl = "http://book.akahoshitakuya.com/"

    

    'IE起動

    Set objIE = CreateObject("InternetExplorer.Application")

    

    'IEで読書メータに接続

    With objIE

        .Visible = True

        .navigate strUrl & "login"

    End With

    

    'IE待機

    Call IEWait(objIE)

    

    'ログイン処理

    If objIE.LocationURL = strUrl & "login" Then

        

        'セッションが開始されていなければ、IDとPasswordを送信

        With objIE.document.forms(1)

            .Item("mail").Value = strMail

            .Item("password").Value = strPass

            .submit

        End With

        

    End If

    

    'IE待機

    Call IEWait(objIE)

    

    '読んだ本リストのページを巡回する

    

    '初期設定

    Set dicReadPage = CreateObject("Scripting.Dictionary")

    Set dicReadCount = CreateObject("Scripting.Dictionary")

    intCount = 1

    

    objIE.navigate strUrl & "home?main=book&display=list&p=1"

    Call IEWait(objIE)

    

    '巡回

    Do While True

    'Do While intCount = 1

        

        'ページの末尾に到達

        If objIE.LocationURL = _

            strUrl & "home?main=book&display=list&p=" & (intCount - 1) Then

            Exit Do

        End If

        

        'ページから読書情報を取得する

        Call getReadInfoAtPage(dicReadCount, dicReadPage, objIE)

        

        '次のページへ移動する

        intCount = intCount + 1

        objIE.navigate strUrl & "home?main=book&display=list&p=" & intCount

        Call IEWait(objIE)

        

    Loop

    

    'IEを終了

    objIE.Quit

    

    'Worksheet 書き出し行

    intCount = 2

    

    'Worksheetへヘッダを記入

    Cells(intCount - 1, 1) = "日付"

    Cells(intCount - 1, 2) = "ページ数"

    Cells(intCount - 1, 3) = "冊数"

    Cells(intCount - 1, 4) = "累積ページ数"

    Cells(intCount - 1, 5) = "累積冊数"

    

    

    '読書開始日から最新更新日まで記帳

    Dim dateCount As Date

    For dateCount = dicReadPage.Keys(UBound(dicReadPage.Keys)) To dicReadPage.Keys(0)

        

        '日付入力

        Cells(intCount, 1) = dateCount

        

        '累積計算式の代入

        If intCount = 2 Then

            Cells(intCount, 4) = "=B" & intCount

            Cells(intCount, 5) = "=C" & intCount

        Else

            Cells(intCount, 4) = "=B" & intCount & "+D" & (intCount - 1)

            Cells(intCount, 5) = "=C" & intCount & "+E" & (intCount - 1)

        End If

        

        '読書記録のある時

        If dicReadPage.Exists(dateCount) Then

            '読書ページ数

            Cells(intCount, 2) = dicReadPage(dateCount)

            '読書冊数

            Cells(intCount, 3) = dicReadCount(dateCount)

        '読書記録のないとき

        Else

            '読書ページ数

            Cells(intCount, 2) = 0

            '読書冊数

            Cells(intCount, 3) = 0

        End If

        

        intCount = intCount + 1

    Next

 

End Sub

 

'読んだ本リストのページから読書情報を取得する

Private Sub getReadInfoAtPage( _

    ByRef dicReadCount As Scripting.Dictionary, _

    ByRef dicReadPage As Scripting.Dictionary, _

    ByRef objIE As InternetExplorer)

 

    Dim objTagDiv, objTagData As Object

    Dim dateRead As Date

    Dim intReadPage As Integer

    

    'divタグを検索

    For Each objTagDiv In objIE.document.getElementsByTagName("div")

        

        '各書籍の情報をClass名から判別

        If objTagDiv.getAttribute("class") = "book_list_simple_inner" Then

            

            '番兵

            dateRead = DateAdd("d", 100, Now)

                    

            'divタグの一階層下を検索

            For Each objTagData In objTagDiv.getElementsByTagName("div")

                    

                '読了日のデータをClass名から判別

                If objTagData.getAttribute("class") = _

                    "book_list_simple_td book_list_simple_td_date" Then

                        

                    'ヘッダでなければ情報を取得

                    If objTagData.innerText <> "読了日 " Then

                        If IsDate(objTagData.innerText) Then

                            dateRead = CDate(objTagData.innerText)

                        Else

                            MsgBox "読了日のフォーマットが不正"

                        End If

                    End If

                    

                'ペース数のデータをClass名から判別

                ElseIf objTagData.getAttribute("class") = _

                    "book_list_simple_td book_list_simple_td_page" Then

                                                

                    'ヘッダでなければ情報を取得

                    If objTagData.innerText <> "ページ数 " Then

                        intReadPage = objTagData.innerText

                        '読了日情報が取得できていることを確認

                        If dateRead > Now Then

                            MsgBox "読了日が取得できていません"

                            Exit Sub

                        Else

                            Call addDicData(dicReadPage, dateRead, intReadPage)

                            Call addDicData(dicReadCount, dateRead, 1)

                        End If

                    End If

                End If

            Next

        End If

    Next

End Sub

 

'連想配列のdateKeyに値があれば加え、なければ初期化

Private Sub addDicData( _

    ByRef dicData As Scripting.Dictionary, _

    ByVal dateKey As Date, _

    ByVal intVal As Integer)

    

    If dicData.Exists(dateKey) Then

        dicData(dateKey) = intVal + CInt(dicData(dateKey))

    Else

        dicData.Add dateKey, intVal

    End If

    

End Sub

 

'IE待機

Private Sub IEWait(ByRef objIE As InternetExplorer)

    

    Dim strUrlNew, strUrlOld As String

    

    Do

        strUrlOld = objIE.LocationURL

        

        Do While objIE.Busy = True Or objIE.readyState <> 4

            DoEvents

        Loop

        

        Call WaitFor(0.001)

        strUrlNew = objIE.LocationURL

        

    Loop While strUrlOld <> strUrlNew

    

End Sub

'指定した秒だけ停止する関数

Private Function WaitFor(ByVal second As Double)

    Dim futureTime As Date

 

    futureTime = DateAdd("s", second, Now)

 

    While Now < futureTime

        DoEvents

    Wend

End Function