- Private Const CP_UTF8 = 65001
- 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
-
- Sub Application_ItemContextMenuDisplay( _
- ByVal CommandBar As Office.CommandBar, _
- ByVal Selection As Selection)
-
- Dim objButton As Office.CommandBarButton
-
- On Error GoTo ErrRoutine
-
- ' Available only if first selected item is RSS
- If (Selection.Item(1).MessageClass = "IPM.Post.Rss") Then
- ' Add a new button to the bottom of the CommandBar
- ' (which represents the item context menu.)
- Set objButton = CommandBar.Controls.Add( _
- msoControlButton)
-
- ' Configure the button to call the
- ' ReadRSSLater routine when
- ' clicked. The Parameter property of the
- ' button is set to the value of the
- ' EntryID property for the selected
- ' item, if possible.
- With objButton
- .BeginGroup = True
- .Caption = "Read RSS &Later"
- .FaceId = 1000
- .Tag = "ReadRSSLater"
- If Not IsNull(Selection.Item(1)) Then
- On Error GoTo 0
- ' Just in case the item selected
- ' doesn't have a valid EntryID.
- ' .Parameter = Selection.Item(1).EntryID
- On Error GoTo ErrRoutine
- End If
- .OnAction = _
- "Project1.ThisOutlookSession.ReadRSSLater"
- End With
- End If
-
- EndRoutine:
- Exit Sub
-
- ErrRoutine:
- MsgBox Err.Number & " - " & Err.Description, _
- vbOKOnly Or vbCritical, _
- "Application_ItemContextMenuDisplay"
- GoTo EndRoutine
- End Sub
-
- Private Sub ReadRSSLater()
- Const RIL_USERNAME = "YOUR_RIL_USERNAME"
- Const RIL_PASSWORD = "YOUR_RIL_PASSWORD"
-
- Const RIL_APPKEY = "377p2o2aA7c0Zw76d1g17a9ca9d6nx3f"
- Const RIL_ADDURL = "https://readitlaterlist.com/v2/add"
-
-
- Dim objNamespace As NameSpace
- Dim objItem As Object
- Dim strResult As String
- Dim iCountOK As Integer
- Dim iCountError As Integer
-
- On Error GoTo ErrRoutine
-
- iCountOK = 0
- iCountError = 0
-
- For Each objItem In Application.ActiveExplorer.Selection
-
- If (objItem.MessageClass = "IPM.Post.Rss") Then
-
- If objItem Is Nothing Then
- MsgBox "A reference for the Outlook item " & _
- "could not be retrieved."
- Else
- Dim RssURL As String
- RssURL = objItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/id/{00062041-0000-0000-C000-000000000046}/8901001F")
- ' https://readitlaterlist.com/v2/add?username=name&password=123&apikey=yourapikey&url=http://google.com&title=Google
- Dim AddURL As String
- AddURL = RIL_ADDURL + _
- "?username=" + RIL_USERNAME + _
- "&password=" + RIL_PASSWORD + _
- "&apikey=" + RIL_APPKEY + _
- "&url=" + URLEncode(RssURL) + _
- "&title=" + URLEncode(objItem.Subject)
- ' Debug.Print AddURL
-
- Dim WinHttpReq As Object
- Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
- WinHttpReq.Open "GET", AddURL, False
- WinHttpReq.Send
- If WinHttpReq.Status = 200 Then
- iCountOK = iCountOK + 1
- Else
- iCountError = iCountError + 1
- strResult = strResult & objItem.Subject & ": " & WinHttpReq.ResponseText & _
- vbCrLf & vbCrLf
- End If
- ' Debug.Print objItem.Subject & ": " & WinHttpReq.ResponseText & "; " & WinHttpReq.ResponseText
- End If
- End If
- Next objItem
- strResult = "Errors: " & iCountError & ", OK: " & iCountOK & vbCrLf & vbCrLf & strResult
- MsgBox strResult, vbOKOnly, "Read RSS Later"
-
- EndRoutine:
- Set objItem = Nothing
- Set objNamespace = Nothing
- Exit Sub
-
- ErrRoutine:
- MsgBox Err.Number & " - " & Err.Description, _
- vbOKOnly Or vbCritical, _
- "Read RSS Later"
- GoTo EndRoutine
- End Sub
-
-
- Public Function UTF16To8(ByVal UTF16 As String) As String
- Dim sBuffer As String
- Dim lLength As Long
- If UTF16 <> "" Then
- lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
- sBuffer = Space$(lLength)
- lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
- sBuffer = StrConv(sBuffer, vbUnicode)
- UTF16To8 = Left$(sBuffer, lLength - 1)
- Else
- UTF16To8 = ""
- End If
- End Function
-
- Public Function URLEncode( _
- StringVal As String, _
- Optional SpaceAsPlus As Boolean = False, _
- Optional UTF8Encode As Boolean = True _
- ) As String
-
- Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
- Dim StringLen As Long: StringLen = Len(StringValCopy)
-
- If StringLen > 0 Then
- ReDim Result(StringLen) As String
- Dim I As Long, CharCode As Integer
- Dim Char As String, Space As String
-
- If SpaceAsPlus Then Space = "+" Else Space = "%20"
-
- For I = 1 To StringLen
- Char = Mid$(StringValCopy, I, 1)
- CharCode = Asc(Char)
- Select Case CharCode
- Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
- Result(I) = Char
- Case 32
- Result(I) = Space
- Case 0 To 15
- Result(I) = "%0" & Hex(CharCode)
- Case Else
- Result(I) = "%" & Hex(CharCode)
- End Select
- Next I
- URLEncode = Join(Result, "")
-
- End If
- End Function
-
* This source code was highlighted with Source Code Highlighter.
