Программное прикрепление файла с иконкой в рич поле на LotusScript.

Sub Click(Source As Button)
    On Error Goto ErrH
    Dim uidoc As NotesUIDocument
    Dim ses As New NotesSession, ws As New NotesUIWorkspace
    Dim doc As NotesDocument
    Set uidoc =ws.CurrentDocument
    Set doc =uidoc.Document
    Dim html As Variant
    ses.convertmime=False
    Dim stream As NotesStream
    Set stream = ses.CreateStream
    Call stream.WriteText("ПРИМЕР <b>как можно</b> использовать <font color=red>HTML</font>")
    Dim mime As NotesMIMEEntity
    Set mime = doc.CreateMIMEEntity
    Dim header As NotesMIMEHeader
    Set header = mime.CreateHeader("headermime")
    Call header.SetHeaderVal("text Header")
    Call mime.SetContentFromText (stream, "text/plain;charset=UTF-8", ENC_BASE64)
    
    
    Call doc.Save(True, True)
    doc.body2= doc.body
    
    ses.ConvertMIME = True
    Call Stream.Close()
    
    Exit Sub
ErrH:
    Print "Ошибка " & Error(Err) & " в строке " & Erl    
    Exit Sub

vAttachList := @AttachmentNames;

vStop := @If(@Attachments=0;"1";"0");

@If(vStop="0";

@Do(vSourceName:=@If(@Attachments>1; @Prompt([OkCancelList];"Выбрать файл";"Выбор файла для переименования";"";vAttachList);vAttachList);

vNewName:=@Prompt([OkCancelEdit];"Новое имя";"Новое имя";vSourceName);
vNewName:="C:\\XML\\" + vNewName;

@Command([EditDetach];vSourceName; vNewName);



@Command([EditGotoField];"Body2");
@Command([EditInsertFileAttachment] ; vNewName ; "1")
);


@Prompt([Ok];"Action - File rename - cancelled!";"The document does not contain any attachments!"))

Sub Click(Source As Button)
    On Error Goto ErrH
    Dim uidoc As NotesUIDocument
    Dim session As New NotesSession, ws As New NotesUIWorkspace, CurDataBase As NotesDataBase
    Dim doc As NotesDocument
    Set uidoc =ws.CurrentDocument
    Set doc =uidoc.Document
    Set CurDataBase=session.CurrentDataBase
    
    Dim docR As NotesDocument'документ TMP'
    Set docR = New NotesDocument( CurDataBase ) ' создали новый док в базе роутер
    docR.Form="outgoing"
    docR.header ="TEST TMP"
    docR.adresed = "1"
    docR.isp = "1"
    
    session.ConvertMIME = False
    Dim streamIn As NotesStream
    Set streamIn =  session.CreateStream 
    Call streamIn.Open("C:\XML\excel.xlsx",  "UTF-8")
    Call streamIn.Truncate
    
    Dim body As NotesMIMEEntity, header As NotesMIMEHeader ,  child As NotesMIMEEntity
    Set body = docR.CreateMIMEEntity("Body")
    Set header = body.CreateHeader("Content-Type")
    Call header.SetHeaderValAndParams({multipart/alternative;charset="UTF-8"})
    Set child = body.createChildEntity() 'ChildEntities are containers
    
    Set header = child.CreateHeader("Content-Type")
    Call header.SetHeaderVal("vnd.openxmlformats-officedocument.spreadsheetml.sheet")
    
    Set header = child.CreateHeader("Content-Disposition")
    Call header.SetHeaderVal("attachment; filename=excel.xlsx")
    
    
    Set header = child.CreateHeader("Content-ID")
    Call header.SetHeaderVal("excel.xlsx")
    
    Call child.SetContentFromBytes(streamIn, "attachment; filename=excel.xlsx", ENC_BASE64)
    
    'Call child.setContentFromText(streamIn, {"application/octet-stream"}, ENC_IDENTITY_BINARY)     ENC_BASE64   ENC_EXTENSION    ENC_NONE
    
    
    Call docR.Save(True, True    )
    Call streamIn.Close()
    Call docR.Closemimeentities(True)
    
    
    Call ws.EditDocument(True, docR)  '  False - чтение
    Print "OK"
    
    'Dim ftuidoc As NotesUIDocument
    'Set ftuidoc = ws.EditDocument( True, docR , True ,  , True, False )
    'Call ftuidoc.GoToField( "Body" )
    'Call ftuidoc.SelectAll
    'Call ftuidoc.Copy
    'Call ftuidoc.Close(True)
    
    'Call uidoc.GoToField( "Body" )    
    'Call uidoc.Paste
    'Call uidoc.Refresh    
    
    'Call ftuidoc.Close
    
    Print "USE"
    
    Exit Sub
ErrH:
    Print "Ошибка " & Error(Err) & " в строке " & Erl    
    Exit Sub
End Sub

            Call session .SetEnvironmentVar( "OutFiles", datapatch$ & new_nameobj )
                '    Call ws.URLOpen( "javascript: document.forms[0].testkn.click();" )
                Dim agent As NotesAgent    
                Set agent = db.GetAgent("test2")
                If agent.Run = 0 Then
                    Print "agent  ОК"
                Else
                    Print "agent  ОШИБКА."
                End If

Files := @Text(@Environment("OutFiles"));
@Prompt([Ok];"OutFiles"; @Text( Files ) );
@Command([EditGotoField];"Body2");
@Command([EditInsertFileAttachment] ; Files );
@Command([Execute]; "cmd.exe"; "/C  del " + Files);

Sub Click(Source As Button)     '  Через МИМЕ 
    On Error Goto ErrH
    Dim session As New NotesSession, ws As New NotesUIWorkspace, db As NotesDatabase, sview As NotesView, dc As NotesDocumentCollection
    Dim uidoc As NotesUIDocument, doc As NotesDocument, templdoc As NotesDocument, DocTemp As NotesDocument
    Dim picklist As Variant, mes As String
    Dim rtitem As NotesRichTextItem
    Dim Name_Stncl_List()  ' все имена вложений
    
    Set doc = ws.CurrentDocument.Document
    Set uidoc=ws.CurrentDocument
    Call uidoc.save
    
    Set rtitem = doc.GetFirstItem("attach")
    
    Dim xxxx As  Integer
    i=0
    If ( rtitem.Type = RICHTEXT ) Then 
        If Not Isempty(rtitem.EmbeddedObjects) Then  
            Forall obj In rtitem.EmbeddedObjects
                If obj.Type = EMBED_ATTACHMENT Then   ' шаг 1 имена вложений в массив
                    If obj.FileSize=0 Then
                        xxxx =     Messagebox     ({"Приложение:  } & obj.Source & { имеет размер 0 байт.} & Chr(13) & Chr(13)   & {Удалить?"}, 1 , "Удаление нулевого вложения." ) 
                        If xxxx = 1 Then
                            doc.history= Cstr(Now)   + " "+ session.CommonUserName + " удалено приложение размером 0 байт ("  + obj.Source + ") "   &Chr(13) & " "&Chr(13) &  doc.history(0)
                            Call  obj.Remove
                            doc.ReplaceItemValue({SaveOptions},{0}).SaveToDisk=False
                            Call doc.save (True,False)
                            Call uidoc.Close
                            Call ws.EditDocument(True, doc)  '  False - чтение
                            Exit Sub
                        End If
                        
                    Else
                        Redim Preserve Name_Stncl_List(i)        
                        Name_Stncl_List(i)=    obj.Source    &  {|}&   obj.Name '    в Name_Stncl_List вносим имена вложений (Source) и   альясы (Name)
                        
                        i=i+1
                    End If
                End If                
            End Forall
        End If
    End If        
    
    If i>0 Then        'есть  хоть одно вложение в поле атач
        Set DocTemp = doc.ParentDatabase.CreateDocument
        DocTemp.ReplaceItemValue  "Name_ListAttach", Name_Stncl_List   ' скрытое поле Name_ListAttach на диалог формне с  Source   |  Name
        
        If Not    ws.DialogBox("ChooseDlg",True,True,False,False,False,False,"Переименовать ",doctemp, True) Then Exit Sub
        
        nameobj2 =  doctemp.ListAttach(0)
        Print "---"
        Print nameobj2         '  псевдоним Name
    End If
    
    datapatch$ = "C:\XML\"
    If  Dir$ (datapatch$ ,16 )="" Then 
        Mkdir datapatch$
    End If
    
    i=1 
    Forall obj In rtitem.EmbeddedObjects
        If obj.Name = nameobj2  Then   ' nameobj2 - ямя выбранного вложения (псевдоним)
            Dim object3 As NotesEmbeddedObject
            Set object3 =     rtitem.GetEmbeddedObject(nameobj2)
            Print "object3.Source " object3.Source
            new_nameobj=Trim(Inputbox$("Введите новое имя приложения "  & i ,"Ввод названия приложения",Strleftback(object3.Source,".")   ))       '  строка слева от первой точки ( без расширения)
            If new_nameobj="" Then Exit Sub
            
            new_nameobj = new_nameobj & "." & Strrightback (object3.Source,".")    '   имя + расширение файла
            
            If new_nameobj<>nameobj2 Then   '  надо переименовать
                Call obj.ExtractFile( datapatch$ & nameobj2) 
                Name datapatch$ & nameobj2   As  datapatch$ & new_nameobj   '  переименовать файл nameobj на диске в new_nameobj
                
                'Call rtitem.EmbedObject ( EMBED_ATTACHMENT, "", datapatch$ & new_nameobj)    СЛЕТАЕТ ИКОНКА
                Call    GetEmbedObject ("attach",   datapatch$ & new_nameobj, doc )
                
            '    Msgbox object.Name 
            '    Call  object.Remove
                Kill  datapatch$ & new_nameobj
            End If
            
        End If
        i=i+1 
    End Forall
    
    Call doc.ComputeWithForm(False, False)
    
    Call    doc.Save(1,0)
    Call uidoc.save
    Print "11."
'    Set rtitem = doc.GetFirstItem("attach")
'    Forall obj In rtitem.EmbeddedObjects
'        Print  object.Source
'        For i = 1 To Len(object.Source)
'            ch = Mid$(object3.Source, i, 1)
'            Print "Символ=" & ch & ",  Код(Asc)=" & Asc(ch)
'        Next    
'    End Forall
    
    
    Print "Сохранили."
'    doc.history= Cstr(Now)      + " "+  session.CommonUserName + " переименовано  приложение ("  + nameobj  + ") "   &Chr(13) & " "&Chr(13) &  doc.history(0)
    
'    doc.ReplaceItemValue({SaveOptions},{0}).SaveToDisk=False
'    Call doc.save (True,False)
'    Call uidoc.Close
'    Call ws.EditDocument(True, doc)  '  False - чтение
    Exit Sub
ErrH:
    Print "Ошибка " & Error(Err) & " в строке " & Erl    
    Exit Sub
End Sub

Function GetEmbedObject(FieldName  As String,    fName As String, doc As NotesDocument)
     ' получаем FieldName - поле на лотус-форме , fName - путь к файлу+ имя файла с расширением
    On Error Goto ErrH    
    Print "Start GetEmbedObject  "  + FieldName  +"  "  + fName 
    Dim session As New NotesSession, ws As New NotesUIWorkspace, CurDataBase As NotesDataBase
    Dim fName2 As String
    Dim uidoc As NotesUIDocument
    Set CurDataBase=session.CurrentDataBase
    Dim docR As NotesDocument'документ TMP'
    Set uidoc =ws.CurrentDocument
    Set docR = New NotesDocument( CurDataBase ) ' создали новый док в базе роутер
    
    docR.Form="work form"   '    временная форма
    docR.header ="TEST TMP"
    docR.adresed = "1"
    docR.isp = "1"
    
    fName2 =  Strrightback (fName,"\") 
    Print "fName2:" fName2    '   имя файла без пути к файлу
    
    session.ConvertMIME = False
    Dim streamIn As NotesStream
    Set streamIn =  session.CreateStream 
    Call streamIn.Open(fName,  "UTF-8")    'windows-1251   UTF-8
    
    Dim body As NotesMIMEEntity, header As NotesMIMEHeader 
    Set body = docR.CreateMIMEEntity("Body")
    
    Set header = body.CreateHeader("Content-Type")
    Call header.SetHeaderValAndParams({multipart/alternative;charset="UTF-8"})
    
    Set header = body.CreateHeader("Content-Disposition")
    Call header.setHeaderVal( {attachment; filename="} + fName2 + {"}  )
    
    Call body.SetContentFromBytes(streamIn, {attachment; filename="} + fName2 + {"}, ENC_IDENTITY_BINARY)   '  stream ,  Content-Type header , encoding 
    Call body.EncodeContent( ENC_BASE64 )  
    
    Call docR.Save(True, True    )
    Call streamIn.Close()
    flag = docR.Closemimeentities(True)
    Print  "flag " flag
    session.ConvertMIME = True
    
'    Call ws.EditDocument(True, docR)  '  False - чтение
    Print "OK"
    
    Dim ftuidoc As NotesUIDocument
    Set ftuidoc = ws.EditDocument( True, docR , True ,  , True, False )'  временный док
    Call ftuidoc.GoToField( "Body" )
    Call ftuidoc.SelectAll
    Call ftuidoc.Copy
    Call ftuidoc.Close(True)'  временный док
    
    Call uidoc.GoToField(FieldName )    
    Call uidoc.Paste
    Call uidoc.Refresh    
    Call uidoc.Save
    
    Print "GetEmbedObject Конец"
    
    Exit Function
ErrH:
    Print "Ошибка GetEmbedObject" & Error(Err) & " в строке " & Erl    
    Exit Function
End Function