はてなダイアリーのページを書き換え(置換)

かなり久しぶりのプログラム(笑)
過去のエントリーで、指定文字列を置換したいことがあったので、VBAで作りました。
作っておいて今更なんですが、はてなダイアリーは記事のテキスト出力、インポートが出来るので、それで対応出来そうな気がするし、可能であるならそちらの方が早いと思う。

追記：インポートが上書きではなく追記処理のため、一度記事を削除しないと上記は無理でした。
http://d.hatena.ne.jp/Shinez/20120911/p1

自分のプログラムは、自分が行うであろう動作をほぼそのまま自動化しただけです。
エントリーを検索 → 「編集」リンク分ループ → 「<前の◯日分」のリンクが無くなるまでループ
といった感じです。
このブログに合わせて作ったので、もしかしたらはてなダイアリーの設定によっては動作しないかもしれません。
でも多分、ブログの編集設定が詳細編集モードになってれば大丈夫な気がします。

プログラム

Option Explicit

Sub ReplaceEntry()

    Const SEND_MSG_BOOK_FNAME As String = "WaitDispDlgSendMsg.xls"
    Dim ieCls As New IEClass, strCls As New StrClass
    Dim ie1 As Object, ie2 As Object
    Dim objLink As Object, objItem As Object
    Dim fs As Object
    Dim id As String, pwd As String, find_str_entry As String, find_str As String, rep_str As String
    Dim logout As Long, Cnt As Long
    Dim body_str As String, body_str_after As String
    Dim bodyChk As Boolean, pgChk As Boolean
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not fs.FileExists(ThisWorkbook.Path & "\" & SEND_MSG_BOOK_FNAME) Then
        MsgBox "アラート対策用のブックがありません。" & vbCrLf & "このブックと同じフォルダに設置して下さい。", vbExclamation + vbOKOnly
        Exit Sub
    End If
    Set fs = Nothing
    
    With ThisWorkbook.Worksheets("設定")
        id = .Cells(1, 2).Text
        pwd = .Cells(2, 2).Text
        find_str_entry = .Cells(3, 2).Text
        find_str = .Cells(4, 2).Text
        rep_str = .Cells(5, 2).Text
        logout = .Cells(6, 2).Value
    End With

    Set ie1 = CreateObject("InternetExplorer.Application")
    ie1.Visible = True
    
    ie1.Navigate "https://www.hatena.ne.jp/login"
    ieCls.WaitType1 ie1

    With ie1.document.forms(0)
        .Item("name").Value = id
        .Item("password").Value = pwd
        .submit
    End With
    ieCls.WaitType1 ie1

    ie1.Navigate "http://d.hatena.ne.jp/" & id & "/searchdiary?word=" & strCls.UrlEncodeEUC(find_str_entry)
    ieCls.WaitType1 ie1
    
    Do
        pgChk = False
        For Each objLink In ie1.document.Links
            If objLink.innerText = "編集" Then
                bodyChk = False
                Set ie2 = CreateObject("InternetExplorer.Application")
                ie2.Visible = True
                ie2.Navigate objLink.href
                ieCls.WaitType1 ie2
                '上で読み込み完了するまで待ってるのに、何故かエラーになることがあるので、ちゃんとItem("body")が出るまで待つ
                Do Until bodyChk
                    For Each objItem In ie2.document.forms(2)
                         If objItem.Name = "body" Then bodyChk = True
                    Next objItem
                Loop
                With ie2.document.forms(2)
                    body_str = .Item("body").Value
                    body_str_after = Replace(body_str, find_str, rep_str)
                    .Item("body").Value = body_str_after
                    If body_str <> body_str_after Then
                        Cnt = Cnt + 1
                        '力技のアラート対策(フォーム送信前に専用のブックを起動 → フォーム送信 → ダイアログを押してもらう → ブック終了)
                        Shell "excel """ & ThisWorkbook.Path & "\" & SEND_MSG_BOOK_FNAME & """"
                        .submit
                        ieCls.WaitType1 ie2
                        ie2.Quit
                        Set ie2 = Nothing
                    End If
                End With
            End If
        Next objLink
        For Each objLink In ie1.document.Links
            If Left(objLink.innerText, 3) = "<前の" Then
                pgChk = True
                objLink.Click
                ieCls.WaitType1 ie1
                Exit For
            End If
        Next objLink
        If pgChk = False Then Exit Do
    Loop
    
    If logout Then
        ie1.Navigate "http://d.hatena.ne.jp/" & id & "/logout"
        ieCls.WaitType1 ie1
    End If
    
    ie1.Quit
    Set ie1 = Nothing

    MsgBox CStr(Cnt) & " エントリーの置換が完了しました。", vbInformation + vbOKOnly

End Sub

自分はよく使う自作関数をxlaファイルに纏めて、参照設定で指定してるので「Dim ieCls As New IEClass」といった記述があります。
そのままでは動かないので以下の関数をクラスモジュールに作るなりする必要があります。
URLエンコードの関数は、流石に自分では作れない難しそうなものですので、過去にどこかから拾ってきたものです(笑)
因みに、xlaファイルではWindowsAPIの関数や定義も記述してます。

自作関数

'---------------------------------------------------------------
'関数名：WaitType1
'内容：IEのBusy状態が解除されるまで待機
'引数：IEオブジェクト
'戻り値：無し
'---------------------------------------------------------------
Sub WaitType1(ByVal ie As Object)
    Do While ie.Busy = True
        DoEvents
    Loop
    Do While ie.document.ReadyState <> "complete"
        DoEvents
    Loop
End Sub

'---------------------------------------------------------------
'関数名：UrlEncodeEUC(ベータ版)
'内容：EUCとしてエンコード
'引数1：エンコードする文字列
'戻り値：エンコード後の文字列
'---------------------------------------------------------------
Function UrlEncodeEUC(strSource As String) As String

 Dim bytArray() As Byte      'Shift-JIS 文字列を格納するバイト型配列
 Dim lngSize As Long         'Shift-JIS 文字列の要素数
 Dim strRet As String        'URL エンコード文字列を格納する変数
 Dim lngArrayCnt As Long     '配列読み出し位置カウンタ
 Dim lngArrayNextCnt As Long '配列読み出し位置カウンタ + 1
 Dim lngStrCnt As Long       '文字列書き込み位置カウンタ
 Dim intC1 As Integer        '文字コード左 1 バイト
 Dim intC2 As Integer        '文字コード右 1 バイト
 
    If Not CBool(Len(strSource)) Then Exit Function
    'Shift-JIS 文字列のバイト数を取得
    lngSize = LenB(StrConv(strSource, vbFromUnicode)) - 1
    ReDim bytArray(lngSize)
    '引数として渡された文字列を Shift-JIS に変換しバイト型配列に格納
    bytArray = StrConv(strSource, vbFromUnicode)
    strRet = Space$(Len(strSource) * 6) '文字列サイズを予約
    lngStrCnt = 1
    
    Do
        lngArrayNextCnt = lngArrayCnt + 1
        If bytArray(lngArrayCnt) = &H20 Then
            '半角スペースは "+" に変換
            Mid(strRet, lngStrCnt, 1) = "+"
            lngArrayCnt = lngArrayCnt + 1
            lngStrCnt = lngStrCnt + 1
        ElseIf _
        (bytArray(lngArrayCnt) >= &H40 And bytArray(lngArrayCnt) <= &H5A) Or _
        (bytArray(lngArrayCnt) >= &H61 And bytArray(lngArrayCnt) <= &H7A) Or _
        (bytArray(lngArrayCnt) >= &H30 And bytArray(lngArrayCnt) <= &H39) Or _
         bytArray(lngArrayCnt) = &H2A Or _
         bytArray(lngArrayCnt) = &H2D Or _
         bytArray(lngArrayCnt) = &H2E Or _
         bytArray(lngArrayCnt) = &H5F Then
            '[A-Za-z0-9*-.@_]は無変換文字
            Mid(strRet, lngStrCnt, 1) = Chr$(bytArray(lngArrayCnt))
            lngArrayCnt = lngArrayCnt + 1
            lngStrCnt = lngStrCnt + 1
        ElseIf (bytArray(lngArrayCnt) >= &HA1 And bytArray(lngArrayCnt) <= &HDF) Then
            'Shift-JIS 1 バイト半角カナを EUC に変換
            Mid(strRet, lngStrCnt, 3) = "%8E"
            Mid(strRet, lngStrCnt + 3, 1) = "%"
            Mid(strRet, lngStrCnt + 4, 2) = Hex$(bytArray(lngArrayCnt))
            lngStrCnt = lngStrCnt + 6
            lngArrayCnt = lngArrayCnt + 1
        ElseIf lngArrayCnt < lngSize Then
            If _
            ((bytArray(lngArrayCnt) >= &H81 And bytArray(lngArrayCnt) <= &H9F) Or _
             (bytArray(lngArrayCnt) >= &HE0 And bytArray(lngArrayCnt) <= &HFC)) And _
            ((bytArray(lngArrayNextCnt) >= &H40 And bytArray(lngArrayNextCnt) <= &H7E) Or _
             (bytArray(lngArrayNextCnt) >= &H80 And bytArray(lngArrayNextCnt) <= &HFC)) Then
                '左右 1 バイトをそれぞれ変数に代入
                'Integer 型に変換しているのは、計算時のオーバーフロー対策
                intC1 = CInt(bytArray(lngArrayCnt))
                intC2 = CInt(bytArray(lngArrayNextCnt))
                'Shift-JIS 2 バイト文字コードを EUC に変換
                If intC2 >= &H9F Then
                    If intC1 >= &HE0 Then
                        intC1 = intC1 * 2 - &HE0
                    Else
                        intC1 = intC1 * 2 - &H60
                    End If
                    intC2 = intC2 + 2
                Else
                    If intC1 >= &HE0 Then
                        intC1 = intC1 * 2 - &HE1
                    Else
                        intC1 = intC1 * 2 - &H61
                    End If
                    If intC2 < &H7F Then
                        intC2 = intC2 + &H60 + 1
                    Else
                        intC2 = intC2 + &H60
                    End If
                End If
                Mid(strRet, lngStrCnt, 1) = "%"
                Mid(strRet, lngStrCnt + 1, 2) = Hex$(intC1)
                Mid(strRet, lngStrCnt + 3, 1) = "%"
                Mid(strRet, lngStrCnt + 4, 2) = Hex$(intC2)
                lngStrCnt = lngStrCnt + 6
                lngArrayCnt = lngArrayCnt + 2
            Else
                Mid(strRet, lngStrCnt, 1) = "%"
                If bytArray(lngArrayCnt) < &H10 Then
                    Mid(strRet, lngStrCnt + 1, 1) = "0"
                    Mid(strRet, lngStrCnt + 2, 1) = Hex$(bytArray(lngArrayCnt))
                Else
                    Mid(strRet, lngStrCnt + 1, 2) = Hex$(bytArray(lngArrayCnt))
                End If
                lngStrCnt = lngStrCnt + 3
                lngArrayCnt = lngArrayCnt + 1
            End If
        Else
            Mid(strRet, lngStrCnt, 1) = "%"
            If bytArray(lngArrayCnt) < &H10 Then
                Mid(strRet, lngStrCnt + 1, 1) = "0"
                Mid(strRet, lngStrCnt + 2, 1) = Hex$(bytArray(lngArrayCnt))
            Else
                Mid(strRet, lngStrCnt + 1, 2) = Hex$(bytArray(lngArrayCnt))
            End If
            lngStrCnt = lngStrCnt + 3
            lngArrayCnt = lngArrayCnt + 1
        End If
    Loop Until lngArrayCnt > lngSize
    
    UrlEncodeEUC = Left$(strRet, lngStrCnt - 1)

End Function

ダイアログ対策用ファイル

IE9の仕様だと思いますが、スクリプトでテキストエリアの編集をして内容が変わると、「このページから移動しますか？」といったアラートが表示されます。
手動編集だと表示されないのですが…。。

IE9の「このページから移動しますか？」

これを何とかしたくて結構苦労した(笑)
IE9の設定では無効化出来なさそうだったので、プログラムでメッセージを送ろうと思ったものの、このダイアログが表示された時点で処理が一時停止してしまうので、別スレッドからメッセージを送らなければならないと判明。
VBSファイルを使おうと思ったものの、Windows 7ではXPの時によく使ってたSFC miniが使えないことが判明。
しょうがないので、エクセルを別インスタンスで立ち上げ、起動と同時にダイアログに答える処理が走るようにしました。
かなり強引というか、力技です(笑)
別インスタンスでエクセルを立ち上げるにも、最初は「CreateObject("Excel.Application")」でプログラムを書いていたのですが、これだとファイルを開いた時に同期するようでそこで処理が止まってしまい(ダイアログが表示されるまでループという処理なので)だめだったので、コマンドラインから立ち上げるようにしました。
この「WaitDispDlgSendMsg.xls」ファイルを同じフォルダに置く必要があります。
また、起動と同時にループが始まるので、その辺は念頭に置き、注意が必要です。

補足として、マクロのセキュリティを「低」にしておかないと、ダイアログを消すためにこのプログラムが走る度にエクセルのセキュリティのダイアログが開くことになって、何のためのプログラムか本末転倒になってしまうので、予めセキュリティを「低」にしておく必要があると思います。

'ThisWorkbookに記述
Option Explicit

Private Sub Workbook_Open()
    Const WM_COMMAND = &H111
    Dim hWnd As Long
    Do Until hWnd <> 0
        hWnd = FindWindow("#32770", "Windows Internet Explorer")
        DoEvents
    Loop
    Sleep 100
    SendMessage hWnd, WM_COMMAND, vbOK, 0
    Application.Quit
End Sub

'標準モジュールに記述
Option Explicit

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

ダウンロード

VBSと違ってコピペですぐ使えるという訳でもないので、ファイルをアップロードしました。
ただ前述の通り、自分は参照設定でxlaファイルを読み込んで関数を使ってるので、その辺はクラスモジュールを作るなりして改変の必要があると思います。
ファイルはExcel 2003で作りました。
また、当ブログでは問題なく動きましたが、使用については自己責任で宜しくお願い致します。

http://d.hatena.ne.jp/Shinez/files/hatena_replace.xls?d=download
http://d.hatena.ne.jp/Shinez/files/WaitDispDlgSendMsg.xls?d=download

Excel VBA 逆引き辞典パーフェクト 2010/2007/2003対応

作者: 田中亨
出版社/メーカー: 翔泳社
発売日: 2010/11/16
メディア: 単行本（ソフトカバー）
購入: 6人クリック: 47回
この商品を含むブログ (10件) を見る