Макрос RSS – лента à MS Office Outlook à Access

Пример макроса чтения сообщений RSS – ленты и запись в БД Access . Макрос написан на Visual Basic for Application под MS Office Outlook .

 

>>>>>>>>>>>>>>>>>>>>>>>> 

Public rst As Variant

 

Sub GetRSS()

Dim aOl As Outlook.Application

Dim oNS As Outlook.NameSpace

Dim oFlCn As MAPIFolder

Dim iM As MailItem

Dim cCn As Items

Dim iCn As ContactItem

Dim LT As String

Dim Acc As Account

Dim ret_ID As Integer

 

strDBName = "g:\DT\MacroDB.mdb" ' путь к базе

Set dbe = CreateObject("DAO.DBEngine.36")

Set wks = dbe.Workspaces(0)

Set dbs = wks.opendatabase(strDBName)

Set rst = dbs.OpenRecordset("News") ‘ открываем таблицу News в базе

 

 

Set aOl = New Outlook.Application

Set oNS = aOl.GetNamespace("MAPI")

Set oFlCn = aOl.GetNamespace("MAPI").Folders("Почтовый ящик - Иван И. Иванович").Folders("RSS-каналы").Folders("BFM.RU - Макроэкономика") ‘ указываем из какой подключенной ленты вытаскивать сообщения

Set cCn = oFlCn.Items

ii = cCn.GetFirst

 

 

For Each ii In cCn ‘ цикл по сообщениям

   If ii.UnRead = True Then ‘если сообщение не прочтенное

      rst.AddNew

      rst.News_text = Trim(ii.Subject)

      rst.News_text2 = Left(CStr(ii.Body), 252)

      ret_ID = GetCountry(Trim(ii.Subject)) ' находим страну

      If ret_ID <> 0 Then

        rst.Country = ret_ID

      End If

      rst.Data = ii.ReceivedTime

      rst.Time = ii.ReceivedTime

      rst.Update

      ii.UnRead = False

   End If

Next

 

rst.Close

dbs.Close

End Sub

 

Function GetCountry(str As String) As Integer

    Dim R, L, Z As String ' R-правая часть L-левая часть Z-запрос

    num = InStr(str, " ")

    R = str

    While num > 0

        L = Trim(Left(R, num))

        R = Trim(Right(R, Len(R) - num))

        ' делаем Select к БД по стране или персоналии

        If Len(L) > 2 Then

            Z = "SELECT ID FROM Countries WHERE Country_name LIKE '" + Left(L, Len(L) - 1) + "*'" ' по стране

            Set r2 = dbs.OpenRecordset(Z)

            If Not r2.EOF And Not r2.BOF Then

                r2.MoveFirst

                GetCountry = r2.Fields("ID")

                Exit Function

            End If

            Z = "SELECT ID FROM Countries WHERE Persons LIKE '*" + Left(L, Len(L) - 1) + "*'" ' по персоналиям

            Set r2 = dbs.OpenRecordset(Z)

            If Not r2.EOF And Not r2.BOF Then

                r2.MoveFirst

                GetCountry = r2.Fields("ID")

                Exit Function

            End If

        End If

        num = InStr(R, " ")

    Wend

   

    GetCountry = 0 ' Bad return

End Function

>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>