Name: Обработка писем | MailDocProccess
Options: Shared
Runtime: Trigger On event; Action menu selection; Target: All selected documents
(Options)
Option Public
%INCLUDE "lsconst.lss"
(Declarations)
Dim session As NotesSession
Dim ws As NotesUIWorkspace
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim collection As NotesDocumentCollection
Dim item As NotesItem
Dim rtitem As NotesRichTextItem
Dim dateTime As NotesDateTime
Dim obj As NotesEmbeddedObject
'____________________________________
Dim attach_dir As String
Dim subject_file As String
Sub Initialize
Set session = New NotesSession
Set ws = New NotesUIWorkspace
Set db = session.CurrentDatabase
Call MailDocProccess()
End Sub
Sub MailDocProccess()
Dim maildoc As NotesDocument
Dim msg As String
Dim file_name As String
Dim dir_name As String
Dim file_num As Integer
Set dateTime = New NotesDateTime( "00/00/00" )
Set collection = db.UnprocessedSearch("!@IsUnavailable(Form)", dateTime, 0)
If collection.Count = 0 Then
msg = "Выберите документы."
Messagebox msg, MB_OK + MB_ICONINFORMATION, db.Title
Exit Sub
End If
attach_dir = Inputbox$("Укажите директорию расположения вложенных файлов писем:" ,db.Title, "C:\EMailFiles")
subject_file = Inputbox$("Укажите файл, содержащий темы сообщений писем :" ,db.Title, "C:\EMailSubjects\EMailSubjects.txt")
attach_dir = FileDir(attach_dir)
If attach_dir = "" Then Exit Sub
file_name = Strrightback(subject_file, "\")
dir_name = Strleft(subject_file, "\" + file_name, 1)
If FileDir(dir_name) = "" Then Exit Sub
For i = 1 To collection.Count
Set doc = collection.GetNthDocument(i)
' формирование подтверждения о доставке письма
Set maildoc = New NotesDocument(db)
maildoc.Form = "Memo"
maildoc.Subject = "ДОСТАВЛЕНО: " + doc.Subject(0)
maildoc.SendTo = doc.From(0)
maildoc.Principal = "Mail Router"
Set rtitem = New NotesRichTextItem(maildoc, "Body")
msg = "Ваш документ " + doc.Subject(0) + " был доставлен " + doc.SendTo(0) + ", дата доставки " + Cstr(doc.DeliveredDate(0)) + "."
Call rtitem.AppendText(msg)
Call maildoc.Send(False)
' извлечение вложенных файлов письма в указанную директорию
If doc.HasEmbedded Then
Forall item In doc.Items
If item.Name = "$FILE" Then
Set item = doc.GetFirstItem(item.Name)
Set obj = doc.GetAttachment(item.Values(0))
If obj.Type = EMBED_ATTACHMENT Then Call obj.ExtractFile(attach_dir + "\" + obj.Name)
Call item.Remove ' (если документ не сохранять, то поле не удалится)
End If
End Forall
End If
' запись темы письма в указанный файл
file_num = Freefile()
Open subject_file For Append As file_num
Write #file_num, doc.Subject(0)
Close file_num
Next
End Sub
Function FileDir(dir_name As String) As String
' Проверка наличия указанной директории; если директория отсутсвует, то она создается.
Dim drive As String
Dim dir_path As String
Dim folder_name As String
Dim msg As String
' проверка драйвера
drive = Strleft(dir_name, "\", 1)
If Instr(1, drive, ":", 5) = 0 Then
msg = "Неверно задан путь." + Chr(10) + Chr(10) + "Действие отменено."
Messagebox msg, MB_OK + MB_ICONEXCLAMATION, db.Title
FileDir = ""
Exit Function
End If
' проверка директории
dir_path = drive
Do
dir_name = Strright(dir_name, "\", 1)
If Instr(1, dir_name, "\", 5) <> 0 Then
folder_name = Strleft(dir_name, "\", 1)
Else
folder_name = dir_name
End If
dir_path = dir_path + "\" + folder_name
If Dir$(dir_path, 16) = "" Then Mkdir dir_path
dir_name = Strright(dir_name, folder_name, 1)
Loop While dir_name <> ""
FileDir = dir_path
End Function
