ログインしてさらにmixiを楽しもう

コメントを投稿して情報交換!
更新通知を受け取って、最新情報をゲット!

EXCEL VBAコミュのMIxi日記のセーブマクロ

  • mixiチェック
  • このエントリーをはてなブックマークに追加
Excel VBA は、開発環境等面倒でないので、便利に使わせてもらっています。ちょっとした自動化とか、ツールを作るのには非常に便利です。
ああ、コミュニティがきっとある筈とさっき気づいて見つけて早速、メンバーにさせてもらいました。新参者ですが、どうぞよろしく。
で、いきなりトピックスを立てさせてもらうという無茶をしているんですが、ローカルルール等ありましたら、ご指導ください。
さて、Mixiにおいて、Mixiの経営状態云々のニュース等に接したりすると、いつか突然に閉鎖、なんてことがないとも・・・
限らないと思いましてね、mixi日記のセーブツール(勿論、フリーの)があったら欲しいなと、探してみても見当たらない。
で、ちょっと自作してみたんですが、中々、うまく行かない。
まあ、とてもお見せ出来るシロモノでもないのですが、

全然なってないな
とか、
ここを替えるとうまくいくよ
とか、
ああ、それなら、過去にこういうのがあったよ
とか、
別のやり方だけど、こっちの方が簡単だよ
など
お知恵、お力を貸していただけるのではないかと・・・
思いまして、以下に、恥ずかしながら現状を提示させていただく次第です。
目的は、過去の日記を簡単にテキストベースにセーブしたい。
ということです。どうかご協力をお願いします。
-----------------------------------------------------
Option Explicit

Sub WebPageGet1()

Const cnsDTop As String = "<DIV class=listDiaryTitle>"
Const cnsCTop As String = "<DL class=comment>"

Dim OwnerId As String: OwnerId = "399831" 'My Mixi User ID
If OwnerId = "" Then
OwnerId = MsgBox("MIXI ID?")
If OwnerId = "" Then
Exit Sub
End If
End If
Dim DiaryId As String: DiaryId = "" 'Start(最新) Diary ID
If DiaryId = "" Then
DiaryId = MsgBox("日記ID?")
If DiaryId = "" Then
Exit Sub
End If
End If
Dim NextId As String: NextId = ""
Dim stURL As String:
Dim s As String, buf, i As Integer
Dim sE As String, bufE, k As Integer
Dim stGyo As String
Dim ie As Object
Dim j As Long

On Error Resume Next
Set ie = CreateObject("InternetExplorer.Application")

Do While DiaryId <> ""
stURL = "http://mixi.jp/edit_diary.pl?id=" & DiaryId
ie.Visible = True
ie.Navigate (stURL)

' ダウンロード待ち
Do While ie.Busy
Loop
' Sheets("Sheet1").Select
' Range("A1").Select
If MsgBox("この日記をセーブしますか?", vbOKCancel + vbMsgBoxSetForeground) = vbCancel Then
GoTo END_PROC
End If

' 日記本文退避(編集ページ)
sE = ie.document.body.innerHTML
bufE = Split(sE, vbCr)
ie.Visible = False

stURL = "http://mixi.jp/view_diary.pl?owner_id=" & OwnerId & "&id=" & DiaryId
ie.Visible = True
ie.Navigate (stURL)

' ダウンロード待ち
Do While ie.Busy
Loop

' 日記取得(閲覧ページ)
s = ie.document.body.innerHTML
buf = Split(s, vbCr)

Open "C:\Users\Public\Desktop\D" & DiaryId & ".txt" For Output As #1
For i = 0 To UBound(buf)
' 前の日記のid取得
If InStr(buf(i), "前の日記") > 0 Then
stGyo = Mid(buf(i), InStr(buf(i), "前の日記") - 15, 13)
NextId = ""
For j = 1 To 13
If IsNumeric(Mid(stGyo, j, 1)) Then
NextId = NextId & Mid(stGyo, j, 1)
End If
Next j
End If

' 日記本文出力
stGyo = Mid(buf(i), 2, Len(cnsDTop) + 1)
If UCase(stGyo) = UCase(cnsDTop) Then
i = i + 2
stGyo = Mid(buf(i), 6, InStr(buf(i), "<SPAN>") - 6) ' タイトル
stGyo = ImgEdit(stGyo)
Print #1, stGyo
i = i + 1
stGyo = Mid(buf(i), 6, InStr(buf(i), "</DD>") - 6) ' 投稿日時
Print #1, stGyo
i = i + 2

' 本文は編集ページ(退避)より取得
For k = 50 To UBound(bufE)
If InStr(bufE(k), "diaryBody") > 0 Then
stGyo = Mid(bufE(k), InStr(bufE(k), "diaryBody"))
stGyo = Mid(stGyo, InStr(stGyo, ">") + 1)
Print #1, stGyo
k = k + 1
Do While k < UBound(bufE)
stGyo = bufE(k)
If InStr(stGyo, "</TEXTAREA>") > 0 Then
stGyo = Left(stGyo, InStr(stGyo, "</TEXTAREA>") - 1)
k = UBound(bufE) 'FINAL
ElseIf InStr(stGyo, "</div>") > 0 Then
stGyo = Left(stGyo, InStr(stGyo, "</div>") - 1)
k = UBound(bufE) 'FINAL
Else
k = k + 1
End If
stGyo = Replace(stGyo, vbCr, "")
stGyo = Replace(stGyo, vbLf, "")
Print #1, stGyo
Loop
End If
Next k
End If

' コメント出力
stGyo = Mid(buf(i), 2, Len(cnsCTop) + 1)
If UCase(stGyo) = UCase(cnsCTop) Then
Print #1, "=========*=========*=========*=========*=========*=========*"
i = i + 1
stGyo = Mid(buf(i), InStr(buf(i), "id="), InStr(buf(i), "</SPAN>"))
stGyo = ImgEdit(stGyo)
Print #1, stGyo
i = i + 1
stGyo = Mid(buf(i), 5, InStr(buf(i), "</DD>"))
stGyo = ImgEdit(stGyo)
Print #1, stGyo
End If
Next i

Close #1
If NextId = "" Or DiaryId = NextId Then
stURL = "http://mixi.jp/neighbor_diary.pl?id=" & DiaryId & "&owner_id=" & OwnerId & "&direction=prev"
ie.Visible = True
ie.Navigate (stURL)
' ダウンロード待ち
Do While ie.Busy
Loop
edit_diary.pl
s = ie.document.body.innerHTML
buf = Split(s, vbCr)
NextId = ""
For i = 80 To UBound(buf)
' 前の日記のid取得
If InStr(buf(i), "編集する") > 0 Then
stGyo = Mid(buf(i), InStr(buf(i), "編集する") - 15, 13)
For j = 1 To 13
If IsNumeric(Mid(stGyo, j, 1)) Then
NextId = NextId & Mid(stGyo, j, 1)
End If
Next j
End If
Next i
End If
DiaryId = NextId
Loop

Set ie = Nothing

END_PROC:

MsgBox "ウェブページ取得処理終了"

End Sub

' タグ等除去
Private Function ImgEdit(inGyo As String) As String

Dim otGyo As String

inGyo = Replace(inGyo, "</A><SPAN class=date>", " DATE:")
inGyo = Replace(inGyo, "</SPAN> <SPAN class=operation>", "")
inGyo = Replace(inGyo, " ", " ")
inGyo = Replace(inGyo, "</DD>", "")
inGyo = Replace(inGyo, "</DL>", "")
inGyo = Replace(inGyo, "<br />", "")
inGyo = Replace(inGyo, "<BR>", vbCrLf)
inGyo = Replace(inGyo, ">", "")

If InStr(inGyo, "<IMG") > 0 Then
Dim i As Long: i = 1
Do While i <= Len(inGyo)
If Mid(inGyo, i, 4) = "<IMG" Then
i = i + 5
Do While i <= Len(inGyo) And Mid(inGyo, i, 1) <> ">"
i = i + 1
Loop
Else
otGyo = otGyo & Mid(inGyo, i, 1)
i = i + 1
End If
Loop
Else
otGyo = inGyo
End If

otGyo = Replace(otGyo, """>", " ")
ImgEdit = otGyo

End Function

コメント(120)

Windows7(64bit)にOffice2003ですか
OfficeのSPは3ですか?
SP3ならサポート対象になっているので、動作は問題なくするとは思いますが

とりあえずWindowsXp(SP3)互換モードでやってみるのも良いかもしれませんね
あとは参照設定とかでしょうか

自宅にWindow7(32bit)でOffice2010
別の場所では64bitマシンはあるのですが、Officeを2010、2013にしてしまっているので
同じ環境でという訳にはいきませんね・・・
因みにOffice2003には64bit版はなかったように思います
>>[95]
お疲れ様です

現在、トピック一覧のタイトル取得には
「<span class="titleSpan"><a href="http://mixi.jp/view_bbs.pl?comm_id=24524&id=76080533" class="title">MIxi日記のセーブマクロ</a>
</span>」
のような場所を使用しているのですよね?

「<a href="http://mixi.jp/view_bbs.pl?comm_id=24524&id=76080533" class="title">MIxi日記のセーブマクロ</a>」
から取得すれば、単純にタイトルのみが得られるかもしれません
ただ、取得したタイトルの右端に不要なスペースがあるかもしれません
もしあれば、RTrim関数で除去すれば良いかと思います

これで行ければ、「削除する」「編集する」を置換せずに行けるかと

因みに、現在の日記一覧タイトル取得では、これらを置換する必要はないのではないでしょうか?
>>[98]
>SPANタグでくくったのは、タイトル・IDと投稿日時の同期を取りたかったため
であれば、元のコードで、SPANタグのループ内にAタグのループがありますから
そこでタイトル,URLを取得するようにすれば良いのではありませんか?

というより、同期という点から考えると以下のようなコードのほうが良いのではないでしょうか

' トピック検索
  For Each TagDt In ie.Document.All.Tags("DT")
    If TagDt.GetAttribute("class") = "bbsTitle clearfix" Then
     Worksheets(1).Cells(i, 1).Value = i - 1           ' No.
     For Each TagA In TagDt.All.Tags("A")
       If TagA.GetAttribute("class") = "title" Then
         stTitle = TagA.InnerText               ' タイトル
         stURL = TagA.Href
         Exit For
       End If
     Next
     BbsId = Right(stURL, Len(stURL) - InStr(stURL, "&id=") - 3) ' BBS ID
     For Each TagSPAN In TagDt.All.Tags("SPAN")
       If TagSPAN.GetAttribute("class") = "date" Then
         stDateAndTime = TagSPAN.InnerText          ' 投稿日時
         Exit For
       End If
     Next
     Worksheets(1).Cells(i, 2).Select
     ActiveSheet.Hyperlinks.Add anchor:=Selection, _
                 Address:=stURL, TextToDisplay:=stTitle
     Worksheets(1).Cells(i, 3).Value = BbsId
     Worksheets(1).Cells(i, 5).Value = stDateAndTime
    ElseIf TagDt.GetAttribute("class") = "commentNumber" Then
     For Each TagA In TagDt.All.Tags("A")
       CommSu = TagA.InnerText                 ' コメント数
       Exit For
     Next
     Worksheets(1).Cells(i, 4).Value = CommSu
     i = i + 1
    End If
  Next


もっと単純化して

' トピック検索
  For Each TagDt In ie.Document.All.Tags("DT")
    If TagDt.GetAttribute("class") = "bbsTitle clearfix" Then
     Worksheets(1).Cells(i, 1).Value = i - 1           ' No.
     With TagDt.All.Tags("A")(0)
        stTitle = .InnerText                  ' タイトル
        stURL = .Href
     End With
     BbsId = Right(stURL, Len(stURL) - InStr(stURL, "&id=") - 3) ' BBS ID
     stDateAndTime = TagDt.All.Tags("SPAN")(1).InnerText     ' 投稿日時
     
     Worksheets(1).Cells(i, 2).Select
     ActiveSheet.Hyperlinks.Add anchor:=Selection, _
                 Address:=stURL, TextToDisplay:=stTitle
     Worksheets(1).Cells(i, 3).Value = BbsId
     Worksheets(1).Cells(i, 5).Value = stDateAndTime
    ElseIf TagDt.GetAttribute("class") = "commentNumber" Then
     CommSu = TagDt.All.Tags("A")(0).InnerText          ' コメント数
     Worksheets(1).Cells(i, 4).Value = CommSu
     i = i + 1
    End If
  Next
「TagDt.GetAttribute("class")」ではどうか分かりませんが
「TagDt.GetAttribute("classname")」は「TagDt.className」でも取得出来るみたいです
>>[103]
おっ、class名取得上手く行ったようですね
これで、classだのclassnameだのという違いはなくなりましたね、良かったです

ログインすると、残り113件のコメントが見れるよ

mixiユーザー
ログインしてコメントしよう!

EXCEL VBA 更新情報

EXCEL VBAのメンバーはこんなコミュニティにも参加しています

星印の数は、共通して参加しているメンバーが多いほど増えます。