пятница, 17 июня 2016 г.

Выгрузка на диск вложений из документа

'Исправил ошибку в функции getbodyImagefilename, где ей присваивается значение

Dim filenames() 'Глобальная переменная

'Процедура из которой будет вызываться функция выгрузки файлов на диск
'doc- документ карточка
Sub main(doc as NotesDocument)
   Dim res as  string
   Redim filenames(0) As String
   res = getbodyImagefilename(doc, "имя rtf поля в котором хранятся вложения")
   'Если res не пустая, то хоть один файл да выгрузился на диск. Тогда выполняем с выгруженными файлами какие-нибудь действия
   If res<>"" Then
      'Здесь перечисляем файлы из глобальной переменной массива  filenames с которыми можно уже что-то делать
      ForAll fn in filenames
         'Делаем что-нибудь с файлом и удаляем его с диска
         Kill fn
      End Forall
   End If
End Sub

Function getbodyImagefilename(bodydoc As NotesDocument, rtname As String)
Dim TempDir As String
Dim body As NotesRichTextItem
Dim rtnav As NotesRichTextNavigator
Dim att As NotesEmbeddedObject
Dim filepath As String
Dim i As Integer

getbodyImagefilename=""
        'Если нет поля с вложениями, то выходим из функции
        If bodydoc.HasItem(rtname)=False Then Exit Function
        'Если в rtf поле нет вложений, то выходим из функции
If Not bodydoc.HasEmbedded Then Exit Function

Set body = bodydoc.GetFirstItem(rtname)
Set rtnav = body.CreateNavigator

TempDir$ = Environ("Temp")
If rtnav.FindFirstElement(RTELEM_TYPE_FILEATTACHMENT) Then
i=0
Do
Set att = rtnav.GetElement()
filepath$ = TempDir$ + "\" & att.Source
Redim Preserve filenames(i)
filenames(i)=filepath$
Call att.ExtractFile(filepath$)
i=i+1
Loop While rtnav.FindNextElement()
End If
getbodyImagefilename=filepath$
End Function