понедельник, 27 июня 2011 г.

Read RSS Later - Microsoft Outlook 2007 macro

Read RSS Later is Microsoft Outlook 2007 macro which allows to add articles from Outlook's RSS feeds to Read It Later service. Full article is added (what you see if click on View article... link in the RSS message). Addition of multiple articles at the same time is possible.

Do the following to add macro to your Outlook 2007:
  1. Start MS Outlook 2007;
  2. Open Visual Basic Editor - press Alt+F11, when Outlook is active OR choose menu Tools - Macro - Visual Basic Editor;
  3. Choose ThisOutlookSession on the left:
  4. Copy and paste the code below to the right window:

    1. Private Const CP_UTF8 = 65001
    2. Private Declare Function WideCharToMultiByte Lib "Kernel32" (ByVal CodePage As Long, ByVal dwflags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
    3.  
    4. Sub Application_ItemContextMenuDisplay( _
    5.   ByVal CommandBar As Office.CommandBar, _
    6.   ByVal Selection As Selection)
    7.   
    8.   Dim objButton As Office.CommandBarButton
    9.   
    10.   On Error GoTo ErrRoutine
    11.   
    12.   ' Available only if first selected item is RSS
    13.   If (Selection.Item(1).MessageClass = "IPM.Post.Rss") Then
    14.     ' Add a new button to the bottom of the CommandBar
    15.     ' (which represents the item context menu.)
    16.     Set objButton = CommandBar.Controls.Add( _
    17.       msoControlButton)
    18.     
    19.     ' Configure the button to call the
    20.     ' ReadRSSLater routine when
    21.     ' clicked. The Parameter property of the
    22.     ' button is set to the value of the
    23.     ' EntryID property for the selected
    24.     ' item, if possible.
    25.     With objButton
    26.       .BeginGroup = True
    27.       .Caption = "Read RSS &Later"
    28.       .FaceId = 1000
    29.       .Tag = "ReadRSSLater"
    30.       If Not IsNull(Selection.Item(1)) Then
    31.         On Error GoTo 0
    32.         ' Just in case the item selected
    33.         ' doesn't have a valid EntryID.
    34.         ' .Parameter = Selection.Item(1).EntryID
    35.         On Error GoTo ErrRoutine
    36.       End If
    37.       .OnAction = _
    38.         "Project1.ThisOutlookSession.ReadRSSLater"
    39.     End With
    40.   End If
    41.   
    42. EndRoutine:
    43.   Exit Sub
    44.   
    45. ErrRoutine:
    46.   MsgBox Err.Number & " - " & Err.Description, _
    47.     vbOKOnly Or vbCritical, _
    48.     "Application_ItemContextMenuDisplay"
    49.   GoTo EndRoutine
    50. End Sub
    51.  
    52. Private Sub ReadRSSLater()
    53.   Const RIL_USERNAME = "YOUR_RIL_USERNAME"
    54.   Const RIL_PASSWORD = "YOUR_RIL_PASSWORD"
    55.     
    56.   Const RIL_APPKEY = "377p2o2aA7c0Zw76d1g17a9ca9d6nx3f"
    57.   Const RIL_ADDURL = "https://readitlaterlist.com/v2/add"
    58.   
    59.  
    60.   Dim objNamespace As NameSpace
    61.   Dim objItem As Object
    62.   Dim strResult As String
    63.   Dim iCountOK As Integer
    64.   Dim iCountError As Integer
    65.   
    66.   On Error GoTo ErrRoutine
    67.   
    68.   iCountOK = 0
    69.   iCountError = 0
    70.   
    71.   For Each objItem In Application.ActiveExplorer.Selection
    72.      
    73.     If (objItem.MessageClass = "IPM.Post.Rss") Then
    74.     
    75.       If objItem Is Nothing Then
    76.         MsgBox "A reference for the Outlook item " & _
    77.           "could not be retrieved."
    78.       Else
    79.         Dim RssURL As String
    80.         RssURL = objItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062041-0000-0000-C000-000000000046}/8901001F")
    81.         ' https://readitlaterlist.com/v2/add?username=name&password=123&apikey=yourapikey&url=http://google.com&title=Google
    82.         Dim AddURL As String
    83.         AddURL = RIL_ADDURL + _
    84.              "?username=" + RIL_USERNAME + _
    85.              "&password=" + RIL_PASSWORD + _
    86.              "&apikey=" + RIL_APPKEY + _
    87.              "&url=" + URLEncode(RssURL) + _
    88.              "&title=" + URLEncode(objItem.Subject)
    89.         ' Debug.Print AddURL
    90.         
    91.         Dim WinHttpReq As Object
    92.         Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    93.         WinHttpReq.Open "GET", AddURL, False
    94.         WinHttpReq.Send
    95.         If WinHttpReq.Status = 200 Then
    96.           iCountOK = iCountOK + 1
    97.         Else
    98.           iCountError = iCountError + 1
    99.           strResult = strResult & objItem.Subject & ": " & WinHttpReq.ResponseText & _
    100.                 vbCrLf & vbCrLf
    101.         End If
    102.         ' Debug.Print objItem.Subject & ": " & WinHttpReq.ResponseText & "; " & WinHttpReq.ResponseText
    103.       End If
    104.     End If
    105.   Next objItem
    106.   strResult = "Errors: " & iCountError & ", OK: " & iCountOK & vbCrLf & vbCrLf & strResult
    107.   MsgBox strResult, vbOKOnly, "Read RSS Later"
    108.  
    109. EndRoutine:
    110.   Set objItem = Nothing
    111.   Set objNamespace = Nothing
    112.   Exit Sub
    113.  
    114. ErrRoutine:
    115.   MsgBox Err.Number & " - " & Err.Description, _
    116.     vbOKOnly Or vbCritical, _
    117.     "Read RSS Later"
    118.   GoTo EndRoutine
    119. End Sub
    120.  
    121.  
    122. Public Function UTF16To8(ByVal UTF16 As String) As String
    123. Dim sBuffer As String
    124. Dim lLength As Long
    125. If UTF16 <> "" Then
    126.   lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
    127.   sBuffer = Space$(lLength)
    128.   lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
    129.   sBuffer = StrConv(sBuffer, vbUnicode)
    130.   UTF16To8 = Left$(sBuffer, lLength - 1)
    131. Else
    132.   UTF16To8 = ""
    133. End If
    134. End Function
    135.  
    136. Public Function URLEncode( _
    137.   StringVal As String, _
    138.   Optional SpaceAsPlus As Boolean = False, _
    139.   Optional UTF8Encode As Boolean = True _
    140. ) As String
    141.  
    142. Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
    143. Dim StringLen As Long: StringLen = Len(StringValCopy)
    144.  
    145. If StringLen > 0 Then
    146.   ReDim Result(StringLen) As String
    147.   Dim I As Long, CharCode As Integer
    148.   Dim Char As String, Space As String
    149.  
    150.  If SpaceAsPlus Then Space = "+" Else Space = "%20"
    151.  
    152.  For I = 1 To StringLen
    153.   Char = Mid$(StringValCopy, I, 1)
    154.   CharCode = Asc(Char)
    155.   Select Case CharCode
    156.    Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
    157.     Result(I) = Char
    158.    Case 32
    159.     Result(I) = Space
    160.    Case 0 To 15
    161.     Result(I) = "%0" & Hex(CharCode)
    162.    Case Else
    163.     Result(I) = "%" & Hex(CharCode)
    164.   End Select
    165.  Next I
    166.  URLEncode = Join(Result, "")
    167.  
    168. End If
    169. End Function
    170.  
    * This source code was highlighted with Source Code Highlighter.
  5. Replace in the code YOUR_RIL_USERNAME and YOUR_RIL_PASSWORD (lines 53 and 54) with your Read It Later username and password accordingly; 
  6. Save the change (Ctrl+S). 
New context menu item (Read RSS Later) will be added to RSS articles in your Outlook 2007: