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

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


( VBA)
VBA Excel Access
VBA RSS- Access
VBA Access
Visio Access
Power Point
()



@Mail.ru

 
 
:
VBA -2014
, E-mail: apsheronka@mail.ru
,


http://apsheronsk.bozo.ru - !

: . .
`