Option Public
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim rtitem As Variant
Dim titem As Variant
Dim attachname As String
Dim filename As String
Dim body As NotesRichTextItem
Dim emphasize As NotesRichTextStyle
Dim tem As Variant
Dim baza$(500)
Dim fname$(500)
Dim dsst
Dim pokaz
Dim pdate As NotesItem
'Dim doc As NotesDocument
Sub Initialize
Dim session As New NotesSession
Set db = session.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Set stream = session.CreateStream
While Not(doc Is Nothing)
Set rtitem = doc.GetFirstItem( "Body" )
If Not rtitem Is Nothing Then
If ( rtitem.Type = RICHTEXT ) Then
If Not Isempty(rtitem) Then
Set tem=doc.GetFirstItem( "Subject" )
If Right$(tem.text,2)<>" ~" Then
Set pdate = doc.GetFirstItem( "deliveredDate" )
If Not ( pdate Is Nothing ) Then
tema=tem.text
subja = Trim(Mid$(tem.text, 1, 40))
subj = ""
For cd = 1 To Len(subja)
sim = Mid$(subja, cd, 1)
'вместо закарючек ставим пробелы
qw = 0
If sim = "\" Then qw = 1
If sim = "/" Then qw = 1
If sim = ":" Then qw = 1
If sim = "*" Then qw = 1
If sim = "?" Then qw = 1
If sim = "<" Then qw = 1
If sim = ">" Then qw = 1
If sim = "|" Then qw = 1
If sim = Chr(34) Then qw = 1
If qw = 1 Then subj = subj & "_" Else subj = subj & sim
Next cd
'Msgbox subj
curdat = Format(Date, "YYYYMMDD")
desten="d:\#rusmail\"
szdata desten & curdat 'создание папки с датой
sztema desten & curdat & "\", subj 'сздание папки с темой
'Msgbox dsst & "\" & attachname
a=stream.Open(dsst & "\_konvert.txt")
b=stream.WriteText(tema & Chr(13) & Chr(10) & Chr(13) & Chr(10))
b=stream.WriteText(doc.GetItemValue("Body")(0), EOL_CRLF)
Call stream.Close
If Not Isempty(rtitem.EmbeddedObjects) Then
Forall obj In rtitem.EmbeddedObjects
If ( obj.Type = EMBED_ATTACHMENT ) Then
' Set emphasize = session.CreateRichTextStyle
'emphasize.Bold = True
'emphasize.NotesColor = COLOR_RED
'Set body = doc.GetFirstItem("Body")
'Call rtitem.AddNewLine( 2 )
'Call body.AppendStyle(emphasize)
attachname = obj.source
Call obj.ExtractFile( dsst & "\" & attachname )
'Call rtitem.AddNewLine( 2 )
'Call rtitem.AppendText(( "Your file was downloaded to\\QDSWJDE1AMstarUnProcessed as filename: " ) & attachname)
'Call doc.Save( False, True )
End If
End Forall
End If
Call doc.replaceItemValue("Subject",tem.text & " ~" )
Call doc.Save( False, True )
Else
Set pdate=Nothing
End If
End If
End If
End If
End If
Call session.UpdateProcessedDoc( doc )
Set doc = dc.GetNextDocument (doc)
Wend
End Sub
Sub szdata(puti)
Doevents
On Error Goto er
Mkdir puti
Exit Sub
er:
If Err = 75 Then Resume Next
End Sub
Sub sztema(puti, ppp)
On Error Goto er
Mkdir puti & Trim(ppp)
dsst = puti & Trim(ppp)
If era = 0 Then Exit Sub
For n = 1 To 1000
Doevents
If direxist(puti & Trim(ppp) & Trim(n)) = False Then
dsst = puti & Trim(ppp) & Trim(Str(n))
eraa = 11
Exit For
End If
Next n
'если спецсимволы
If eraa <> 11 Then
For n = 50 To 1500
Doevents
If direxist(puti & Trim(Str(n))) = False Then
dsst = puti & Trim(Str(n))
Exit For
End If
Next n
End If
Exit Sub
er:
era = 1
Resume Next
End Sub
Function direxist(papka)
Doevents
On Error Goto er
direxist = False
result = False
Mkdir papka
Exit Function
er:
If Err = 75 Or Err = 76 Then
result = True
direxist = True
Resume Next
End If
End Function
