Dim doc As NotesDocument
Dim rtitem As Variant
Dim fileCount As Integer
Const MAX =  100000 
fileCount =  0  
'...set value of doc...
Set rtitem = doc.GetFirstItem( "Body" )
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) _
And ( o.FileSize > MAX ) Then
fileCount = fileCount +  1 
Call o.ExtractFile ( "c:\reports\newfile" & Cstr(fileCount) )
Call o.Remove
Call doc.Save( True, True )
End If
End Forall
End If

Sub tblTmp()

Dim EmailBCCTo
Dim objNotesSession As Object
Dim objNotesMailFile As Object
Dim ObjNotesDocument As Object
Dim objNotesField As Object
Dim RichTextAttachment As Object
Dim NotesAttach As Object
Dim SendMail As Boolean
Dim dbs As Database
Dim tdf As TableDef
Dim rec As Recordset
Dim qdfTemp As QueryDef
Dim dt1 As Date
Dim osh As String


Dim cs As Integer
Dim css As String

DoCmd.SetWarnings False
dt1 = Time

Set dbs = CurrentDb
Set tdf = dbs.TableDefs("Tmp")
Set rec = dbs.OpenRecordset("Tmp")

Const EMBED_ATTACHMENT As Long =  1454 
 
On Error GoTo SendMailError
 
EmailBCCTo = "" ''Optional
Set objNotesSession = CreateObject("Notes.NotesSession")


DoCmd.RunSQL ("DELETE Tmp.* FROM Tmp")


For cs =  1  To  2 
Select Case cs
    Case  1 
        Set objNotesMailFile = objNotesSession.GetDatabase("Mail/alfa-bank", "mail\*****.nsf")
        If objNotesMailFile.IsOpen = False Then objNotesMailFile.OPENMAIL
        css = "Рабочая почта"
    Case  2 
        Set objNotesMailFile = objNotesSession.GetDatabase("", "archive\a_*****")
        If objNotesMailFile.IsOpen = False Then objNotesMailFile.OPENMAIL
        css = "Архивная почта"
End Select
Debug.Print objNotesMailFile.AllDocuments.Count


For i =  4  To objNotesMailFile.AllDocuments.Count
'For i = 1 To objNotesMailFile.AllDocuments.Count
    'Debug.Print i
    Set ObjNotesDocument = objNotesMailFile.AllDocuments.GetNthDocument(i)
Debug.Print ObjNotesDocument.GetItemValue("$File")( 0 )
    rec.AddNew
    osh = "URL"
    rec.Fields("URL").Value = ObjNotesDocument.NotesURL
    
    osh = "PostedDate"
    rec.Fields("Data").Value = ObjNotesDocument.GetItemValue("PostedDate")( 0 )
    osh = "Subject"
    'Debug.Print ObjNotesDocument.GetItemValue("Subject")(0)
    rec.Fields("Subject").Value = ObjNotesDocument.GetItemValue("Subject")(0)
    osh = "body"
    rec.Fields("Body").Value = ObjNotesDocument.GetItemValue("body")(0)
    osh = "From"
    rec.Fields("From").Value = ObjNotesDocument.GetItemValue("From")(0)
    osh = "ID"
    rec.Fields("$MessageID").Value = ObjNotesDocument.GetItemValue("$MessageID")(0)
    osh = "SaveOptions"
    rec.Fields("SaveOptions").Value = ObjNotesDocument.GetItemValue("SaveOptions")(0)
    rec.Fields("Mesto").Value = css
    osh = "SendTo"
    rec.Fields("SendTo").Value = ObjNotesDocument.GetItemValue("SendTo")(0)
    rec.Update
Next i
    Set objNotesMailFile = Nothing
    Set ObjNotesDocument = Nothing
Next cs

DoCmd.RunSQL ("UPDATE Tmp INNER JOIN Data ON Tmp.[$MessageID] = Data.[$MessageID] SET Data.URL = [Tmp]., Data.Mesto = [Tmp].[Mesto], Data.SendTo = [Tmp].[SendTo]")
DoCmd.RunSQL ("INSERT INTO Data ( Data, Subject, Body, [From], URL, [$MessageID], SaveOptions, Mesto, status, [SendTo] ) SELECT Tmp.Data, Tmp.Subject, Tmp.Body, Tmp.From, Tmp.URL, Tmp.[$MessageID], Tmp.SaveOptions, Tmp.Mesto, ""НОВЫЕ"" AS status ,Tmp.SendTo FROM Data RIGHT JOIN Tmp ON Data.[$MessageID] = Tmp.[$MessageID] WHERE (((Data.[$MessageID]) Is Null))")

DoCmd.RunSQL ("DELETE Tmp.* FROM Tmp")
 
 ''Release storage
 Set objNotesSession = Nothing
 Set objNotesMailFile = Nothing
 Set ObjNotesDocument = Nothing
 Set objNotesField = Nothing
 
 Forms("Data").Refresh
 
MsgBox "Синхронизация ссылок закончена! за " & FormatDateTime((Time - dt1), vbLongTime)
 
 DoCmd.SetWarnings True
Exit Sub
 
SendMailError:

If osh = "PostedDate" Then Resume Next
Dim Msg
Msg = "Error # " & Str(Err.Number) & " was generated by " _
            & Err.Source & Chr(13) & Err.Description

MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
MsgBox "  позиция " & i & " база " & css & " поле " & osh
' открыть ошибочную запись
Application.FollowHyperlink "" & ObjNotesDocument.NotesURL & ""

Resume Next
SendMail = False

rec.Close
dbs.Close
Set r = Nothing
Set dbs = Nothing
Set objNotesSession = Nothing
 Set objNotesMailFile = Nothing
 Set ObjNotesDocument = Nothing
 Set objNotesField = Nothing

 DoCmd.SetWarnings True
 
End Sub

Sub ListItemofBody()
    Dim aNotes
    Dim aDataBase
    Dim aDocument
    Dim aView
    Dim aItem
    Dim oEmb
 
    Set aNotes = CreateObject("Notes.NotesSession")
    Set aDataBase = aNotes.CURRENTDATABASE
    Set aView = aDataBase.getview("($Inbox)")
    If (aView Is Nothing) Then
        MsgBox "Inbox view dont exist!"
    Else
        Set aDocument = aView.GETFIRSTDOCUMENT
        Set rtItem = aDocument.GETFIRSTITEM("Body")
        Debug.Print rtItem.text
        If (rtItem.Type =  1 ) Then
            For Each oEmb In rtItem.EmbeddedObjects
                'добавляю экспорт файла
                oEmb.ExtractFile ("c:\reports\" & oEmb.Name) 
                Debug.Print oEmb.Type & " " & oEmb.Name
            Next
        End If
    End If
    Set aNotes = Nothing
    Set aDataBase = Nothing
    Set aView = Nothing
    Set aDocument = Nothing
    Set aItem = Nothing
End Sub

EMBED_ATTACHMENT ( 1454 )
EMBED_OBJECT ( 1453 )
EMBED_OBJECTLINK ( 1452 )