Mixi のメッセージを Outlook でダウンロードするマクロ


私は時々 Mixi でもメッセージのやり取りをするのですが、そのようなメッセージでも Outlook で一元管理したかったので、Mixi のメッセージをローカルにダウンロードするマクロを作ってみました。

このマクロには大きく分けて 2 つの処理があります。

まず一つは InitializeMixiFolders というマクロです。このマクロは Mixi のメッセージをダウンロードするためのフォルダを受信トレイの下に作成し、ビューの初期化を行うものです。これは一度だけ実行すれば以降の実行は不要です。これを実行すると、受信トレイの下に以下の二つのフォルダが作成されます。

  • MIXI 受信箱 (MIXI の受信メッセージを保存するフォルダ)
  • MIXI 送信済み (MIXI の送信済みメッセージを保存するフォルダ)

そして、もう一つの DownloadMixiMessage というマクロがメッセージのダウンロードを実行するためのマクロです。これを実行するたびに Mixi にアクセスし、メッセージをダウンロードします。なお、このマクロの冒頭に MIXI_ADDR と MIXI_PASS という定数が定義されていますが、このマクロを実行する前に Mixi にログインする際のメールアドレスとパスワードを指定してください。たとえば、メールアドレスが “username@example.com” でパスワードが “P@ssword” だった場合、DownlaodMixiMessage の冒頭の 2 行を以下のように置き換えます。

    Const MIXI_ADDR = "username@example.com"
    Const MIXI_PASS = "P@ssword"

以下はマクロです。なお、インターネットに接続されていない環境や、HTML メッセージ中の外部リンクをダウンロードしない設定となっている場合は、絵文字やプロファイルの画像は表示されません。また、Outlook 2007 ではアニメーション GIF がサポートされていないため、動く絵文字は動きません。

' ここをトリプルクリックでマクロ全体を選択できます。
'
' Mixi のメッセージをダウンロードするマクロ
'
Public Sub DownloadMixiMessage()
    Const MIXI_ADDR = "メールアドレスを入力してください"
    Const MIXI_PASS = "パスワードを入力してください"
   MixiLogin MIXI_ADDR, MIXI_PASS
   DownloadMessages "inbox", "MIXI 受信箱"
    DownloadMessages "outbox", "MIXI 送信済み"
End Sub
'
' Mixi にログインするマクロ
'
Private Sub MixiLogin(strAddress, strPassword)
    Dim xmlHttp
    Dim strPostData
    Set xmlHttp = CreateObject("MSXML2.xmlHttp")
    strPostData = "next_url=/list_message.pl&email=" & strAddress & "&password=" & strPassword
    xmlHttp.Open "POST", "http://mixi.jp/login.pl", False
    xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlHttp.setRequestHeader "Referer", "http://mixi.jp/home.pl"
    xmlHttp.Send strPostData
End Sub
'
' メッセージ受信のメインループ
'
Private Sub DownloadMessages(strBox As String, strFolder As String)
    Const MAX_PAGE = 20 ' メッセージが 20 ページ以上ある場合は、これを増やしてください。
    Dim objFolder 'As Folder
    Dim iPage As Integer
    Dim strHtml As String
    Dim bFound As Boolean
    Dim ls As Long
    Dim le As Long
    Dim strUrl As String
    Dim objItem 'As PostItem
    Dim objUrlProp 'As UserProperty
    Set objFolder = Session.GetDefaultFolder(olFolderInbox).Folders.Item(strFolder)
'
    For iPage = 1 To MAX_PAGE
        strHtml = GetWebPage("http://mixi.jp/list_message.pl?page=" & iPage & "&box=" & strBox)
        ls = InStr(strHtml, "view_message.pl")
        If ls = 0 Then Exit Sub
        While ls > 0
            le = InStr(ls, strHtml, """")
            strUrl = Mid(strHtml, ls, le - ls)
            Set objItem = objFolder.Items.Find("[URL]='" & strUrl & "'")
            If objItem Is Nothing Then
                Set objItem = objFolder.Items.Add(olPostItem)
                Set objUrlProp = objItem.UserProperties.Add("URL", olText)
                objUrlProp.Value = strUrl
                DownloadOneMessage strUrl, objItem
            Else
                Exit Sub
            End If
            ls = InStr(le, strHtml, "view_message.pl")
        Wend
    Next
End Sub
'
' 1 通分のメッセージをダウンロード
'
Private Sub DownloadOneMessage(strUrl As String, objItem As PostItem)
    Dim strHtml As String
    Dim strLink As String
    Dim ls As Long
    Dim le As Long
    Dim objProp 'As UserProperty
    Dim strHeader As String
    strHtml = GetWebPage("http://mixi.jp/" & strUrl)
    strHeader = "<table><tr><td rowspan=2><a HREF=""http://mixi.jp/show_friend&quot; & GetFieldValue(strHtml, "<a href=", "show_friend", "</a>") & "</a></td><td>"
   
    strLink = "<a href=""http://mixi.jp/&quot; & GetFieldValue(strHtml, "<dt>差出人", "<a href=""", "<") & "</a>"
'   
    If strUrl Like "*outbox*" Then
        Set objProp = objItem.UserProperties.Add("宛先@MIXI", olText, True)
        strHeader = strHeader & "宛 先"
    Else
        Set objProp = objItem.UserProperties.Add("差出人@MIXI", olText, True)
        strHeader = strHeader & "差出人"
    End If
'       
    objProp.Value = GetFieldValue(strLink, "<", ">", "<")
    Set objProp = objItem.UserProperties.Add("日付", olDateTime, True)
    objProp.Value = GetFieldValue(strHtml, "<dt>日付</dt>", "<dd>", "</dd>")
    objItem.Subject = GetFieldValue(strHtml, "messageDetailHead", "<h3>", "</h3>")
    objItem.HTMLBody = strHeader & " : </td><td>" & strLink & "</td></tr><tr><td>日 付 : </td><td>" & _
        objProp.Value & "</td></tr></table>" & GetFieldValue(strHtml, "div id=""message_body""", ">", "</div>")
'
    objItem.Post
    objItem.UnRead = True
    objItem.Save
End Sub
'
' HTML ファイルから必要な情報を取得する関数
'
Private Function GetFieldValue(strHtml As String, strStart1 As String, strStart2 As String, strEnd As String)
    Dim ls As Long
    Dim le As Long
    ls = InStr(strHtml, strStart1)
    ls = InStr(ls, strHtml, strStart2) + Len(strStart2)
    le = InStr(ls, strHtml, strEnd)
    GetFieldValue = Mid(strHtml, ls, le - ls)
End Function
'
' 指定された Web ページをダウンロードする関数
'
Private Function GetWebPage(strUrl As String)
    Dim xmlHttp
    Set xmlHttp = CreateObject("MSXML2.xmlHttp")
    xmlHttp.Open "GET", strUrl, False
    xmlHttp.Send
    GetWebPage = xmlHttp.responseText
End Function
'
' Mixi のメッセージを受信するフォルダの初期化をするマクロ
'
Public Sub InitializeMixiFolders()
    Dim objInbox 'As Outlook.Folder
    Dim objFolder 'As Outlook.Folder
    Dim objItem 'As Outlook.PostItem
    Set objInbox = Session.GetDefaultFolder(olFolderInbox)
    Set objFolder = objInbox.Folders.Add("MIXI 受信箱")
    Set objItem = objFolder.Items.Add(olPostItem)
    objItem.UserProperties.Add "URL", olText, True
    objItem.UserProperties.Add "差出人@MIXI", olText, True
    objItem.UserProperties.Add "日付", olDateTime, True
    objItem.Close olDiscard
    CreateMixiView objFolder, "差出人"
    Set objFolder = objInbox.Folders.Add("MIXI 送信済み")
    Set objItem = objFolder.Items.Add(olPostItem)
    objItem.UserProperties.Add "URL", olText, True
    objItem.UserProperties.Add "宛先@MIXI", olText, True
    objItem.UserProperties.Add "日付", olDateTime, True
    objItem.Close olDiscard
    CreateMixiView objFolder, "宛先"
End Sub
'
' 受信フォルダのビュー設定
'
Private Sub CreateMixiView(objFolder, strField)
    Dim strViewXML As String
    Dim objView 'As Outlook.View
    strViewXML = "<?xml version=""1.0""?><view type=""table""><viewname>MIXI メッセージ
</viewname><viewstyle>table-layout:fixed;width:100%;</viewstyle>" & _
                 "<column><type>string</type><heading>%f@MIXI</heading>" & _
                 "<prop>http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/%f@MIXI</prop>&quot; & _
                 "<width>76</width></column><column><heading>件名
</heading><prop>urn:schemas:httpmail:subject</prop><type>string</type>" & _
                 "<width>402</width></column><column><type>string</type><heading>日付</heading>" & _
                 "<prop>http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/日付</prop>&quot; & _
                 "<width>80</width></column><orderby><order><heading>日付</heading>" & _
                 "<prop>http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/日付</prop>&quot; & _
                 "<type>datetime</type><sort>desc</sort></order></orderby></view>"
    Set objView = objFolder.Views.Add("MIXI メッセージ", olTableView, olViewSaveOptionThisFolderEveryone)
    objView.XML = Replace(strViewXML, "%f", strField)
    objView.Save
    objView.Apply
End Sub

マクロの登録方法やメニューへの追加について

広告

Mixi のメッセージを Outlook でダウンロードするマクロ」への4件のフィードバック

  1. 質問です。office 2003 で実行したのですが、

    Private Sub DownloadMessages(strBox As String, strFolder As String)
    Const MAX_PAGE = 5000 ‘ メッセージが 20 ページ以上ある場合は、これを増やしてください。
    Dim objFolder ‘As Folder

            |
            |
            |
    While ls > 0
    le = InStr(ls, strHtml, “”””)
    strUrl = Mid(strHtml, ls, le – ls)
    Set objItem = objFolder.Items.Find(“[URL]='” & strUrl & “‘”)
    If objItem Is Nothing Then
    Set objItem = objFolder.Items.Add(olPostItem)
    Set objUrlProp = objItem.UserProperties.Add(“URL”, olText)
    objUrlProp.Value = strUrl
    DownloadOneMessage strUrl, objItem ←でByRef 引数の型が一致しません。
    ~~~~~~
    Else
    Exit Sub
    End If
    ls = InStr(le, strHtml, “view_message.pl”)
    Wend
    Next
    End Sub

    ByRef 引数の型が一致しませんのERRORが発生します。
    対処出来るようであれば、ご教授お願いします。

  2. outlook2003 で今まで使用していたのですが(2013010まで)、メールの取得が出来なくなりました。調べてみたところ、下記部位でERRORが発生しています。色々と試しては見たのですが、解消できません。ご指導のほどお願いします。


    ‘ 1 通分のメッセージをダウンロード

    Private Sub DownloadOneMessage(strUrl As String, objItem As PostItem)
    Dim strHtml As String
    Dim strLink As String
    Dim ls As Long
    Dim le As Long
    Dim objProp ‘As UserProperty
    Dim strHeader As String
    strHtml = GetWebPage(“http://mixi.jp/” & strUrl) ←取得OK
    strHeader = “<a HREF=""http://mixi.jp/show_friend&quot; & GetFieldValue(strHtml, "<a href=", "show_friend", "“) & ““ ←取得OK

    strLink = “<a href=""http://mixi.jp/&quot; & GetFieldValue(strHtml, "差出人”, “<a href=""", "<") & "”
                   |
                   |
                   ∨
    ‘ HTML ファイルから必要な情報を取得する関数

    Private Function GetFieldValue(strHtml As String, strStart1 As String, strStart2 As String, strEnd As String)
    Dim ls As Long
    Dim le As Long
    ls = InStr(strHtml, strStart1) ← ISがゼロに
    ls = InStr(ls, strHtml, strStart2) + Len(strStart2) ← InStrプロシジャーERROR
    le = InStr(ls, strHtml, strEnd)
    GetFieldValue = Mid(strHtml, ls, le – ls)
    End Function

    • こちら、おそらく mixi のページの HTML が変わったためと思われます。
      ちょっと解析してみないと対応できるかどうかわかりませんが、やってみます。

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中