Option Public
Option Declare
' Основная процедура агента
Sub Initialize
On Error Goto ErrorHandler
Dim session As New NotesSession
Dim db As NotesDatabase
Dim collection As NotesDocumentCollection
Dim doc As NotesDocument
Dim richTextItem As NotesRichTextItem
Dim attachment As NotesEmbeddedObject
Dim savePath As String
Dim regNumber As String
Dim folderPath As String
' Получаем текущую базу данных
Set db = session.CurrentDatabase
' Получаем все документы в базе
Set collection = db.AllDocuments
Print "Начало обработки " & CStr(collection.Count) & " документов..."
' Обрабатываем каждый документ
Set doc = collection.GetFirstDocument
While Not doc Is Nothing
' Получаем регномер документа (замените "RegNumber" на имя вашего поля)
regNumber = doc.GetItemValue("RegNumber")(0)
' Если регномер пустой, пропускаем документ
If regNumber = "" Then
Print "Документ без регномера, пропускаем..."
GoTo NextDocument
End If
' Создаем путь для сохранения (измените базовый путь по необходимости)
savePath = "C:\Attachments\" & regNumber & "\"
folderPath = savePath
' Создаем папку, если она не существует
If CreateFolder(folderPath) Then
Print "Создана папка: " & folderPath
Else
Print "Ошибка создания папки: " & folderPath
GoTo NextDocument
End If
' Ищем вложения в документе
Set richTextItem = doc.GetFirstItem("Body")
If Not richTextItem Is Nothing Then
If richTextItem.Type = RICHTEXT Then
Set attachment = richTextItem.GetFirstEmbeddedObject
' Обрабатываем все вложения
While Not attachment Is Nothing
If attachment.Type = EMBED_ATTACHMENT Then
' Сохраняем вложение
Call attachment.ExtractFile(savePath & attachment.Source)
Print "Сохранено вложение: " & attachment.Source & " в " & savePath
End If
Set attachment = richTextItem.GetNextEmbeddedObject(attachment)
Wend
End If
End If
NextDocument:
Set doc = collection.GetNextDocument(doc)
Wend
Print "Обработка завершена успешно!"
Exit Sub
ErrorHandler:
Print "Ошибка: " & Error$ & " в строке " & Erl
Exit Sub
End Sub
' Функция для создания папки
Function CreateFolder(path As String) As Boolean
On Error Goto ErrorHandler
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(path) Then
fs.CreateFolder path
End If
CreateFolder = True
Exit Function
ErrorHandler:
CreateFolder = False
Exit Function
End Function