Лотус скрипты для работы с XML (Страница 1 из 2)

Sub Click(Source As Button)'v2.0
    'формула скрытия заменена 
    'с 
    '@IsNotMember("[XMLsign]";@UserRoles) | flagXML!="1"
    'на
    '@IsNotMember("[XMLsign]";@UserRoles) | @IsMember(@Name([CN];@UserName); sign_name) | (flagXML="" | flagXML="3")
    ' подписываем готовую XML и проверяем консольнойкриптогсс(необходимо заменить fileexists)
    'изменен механизм вызова криптогсс, ф-ция fileexists не используется
    On Error Goto ErrH 
    Dim workspace As New NotesUIWorkspace
    Dim session As New NotesSession, db As NotesDatabase, outStream As NotesStream, view As NotesView
    Dim ws As New NotesUIWorkspace, uidoc As NotesUIDocument, doc As NotesDocument
    Dim Adr As Variant, strm As NotesStream, inStream As NotesStream, rtitemA As NotesRichTextItem, sText As String, xml As String, total As String
    Dim str1 As String, str2 As String, str3 As String
    Dim rtitem As NotesRichTextItem  '  содержание и приложения
    Dim nam As String, namout As String  ' откуда куда
    Dim xmlPath As Variant ' путь для сохранения файла(xml)    
    
    If ws.Prompt (PROMPT_YESNO, "Внимание",    "Подписать данный документ?") <> 1 Then Exit Sub
    
    Set db = session.CurrentDatabase
    Set uidoc = ws.CurrentDocument
    Call uidoc.save  ' иначе новые доки не отправятся, т.к. XMLattach  не существует еще ((.
    Set doc = uidoc.Document
    
    Print "Старт подписания документа."
    chrset$ = "UTF-8"
    
    Set view = db.GetView ("reg" )
    Set docreg = view.GetFirstDocument
    If docreg Is Nothing Then Messagebox("Нет доступа к настройкам регистрации!") : Exit Sub        
    '*****************************************************для проверки подписи с помощью consolecriptogss Гроза, изменения в данном блоке 28,03,2022 вынесена проверка в настройки(проверять/не проверять консолькой)
    If Not docreg.HasItem("isVerifySign") Then  Messagebox("Устаревшая форма настроек регистрации! (нет поля isVerifySign, обратитесь к разработчику.)") : Exit Sub        
    isVerifySign=False
    If docreg.isVerifySign(0)="1" Then'если в настройках указана доп проверка
        b=False 'проверяем наличие пути к консольной криптогсс
        If docreg.HasItem("ConsoleCriptoGSS") Then
            If docreg.ConsoleCriptoGSS(0)="" Then b=True        
        Else
            b=True        
        End If
        If b Then  Messagebox "Не указан путь к консольной криптоГСС":    Exit Sub
        isVerifySign=True
        path_criptoGSS=docreg.ConsoleCriptoGSS(0)        
    End If
    '*****************************************************для проверки подписи с помощью consolecriptogss    
    
    datapatch$ = docreg.datapatch(0)      'Путь для файла подписи XML  C:\XML\
    If Right(datapatch,1)="\" Then
        datapatch=Left(datapatch, Len(datapatch)-1)
        t$="\"
    End If
    If  Dir$ (datapatch,16 )="" Then 
        Mkdir datapatch
        Mkdir datapatch+"\OUT"
    End If
    datapatch=datapatch+t$
    
    CriptoGSS$ = docreg.CriptoGSS(0) 
    intwait = 0        
    
    ' - ---   ПРОПУСКНАЯ СИСТЕМА - СТАРТ
    If uidoc.IsNewDoc Then
        Messagebox "Сохраните документ"    
        Exit Sub
    End If
    
    If doc.HasEmbedded Then
        Set rtitemA = doc.GetFirstItem("XMLattach" )
        If Isempty( rtitemA.EmbeddedObjects) Then            
            Messagebox "Документ XML еще не сформирован канцелярией."
            Exit Sub
        End If        
    End If
        ' - ---   ПРОПУСКНАЯ СИСТЕМА - КОНЕЦ    
    Call uidoc.save
    Print "Пропускная система - конец"
    
    Set rtitemA = doc.GetFirstItem("XMLattach" )
    Forall o In rtitemA.EmbeddedObjects
        If ( o.Type = EMBED_ATTACHMENT ) Then
            XMLname=o.Source
            'поставить проверку на налицие такогоже файла на диске и если он есть удалить его
            If  Dir$ (datapatch$ + XMLname, 0 )<>"" Then         
                Print "найден старый файл с именем " & datapatch$ + XMLname
                Kill datapatch$ + XMLname    
                Print "удалили старый файл с именем " & datapatch$ + XMLname
            End If            
            Call o.ExtractFile( datapatch$ + XMLname )                            
        End If
    End Forall
    
 ' -----------------------------------------------------------------------------------  
'    XMLname=Ucase(XMLname)    
    
    Print  "CriptoGSS  " CriptoGSS$ 
    Print  "консольная "  path_criptoGSS
    Print  "datapatch$ + XMLname "   datapatch$ + XMLname
    
    
    If SignXMLfile(CriptoGSS$,path_criptoGSS, datapatch$ + XMLname,datapatch$ +   |OUT\| +  XMLname) Then
        Set rtitem = doc.getfirstitem(  "XMLattach" )
'--------
        If Not Isempty( rtitemA.EmbeddedObjects) Then
            Set vFile = rtitemA.GetEmbeddedObject(rtitem.EmbeddedObjects(0).Source)
            Call vFile.Remove 'удаляем аттачмент с лотус дока
            Call rtitemA.Update            
        End If            
'--------            
        Call rtitemA.EmbedObject ( EMBED_ATTACHMENT, "", datapatch$ +   |OUT\| +  XMLname)
        Call rtitemA.Update            
        
        Kill    datapatch$ +   |OUT\| +  XMLname ' подписанный XML
        Print datapatch$ +   |OUT\| +  XMLname & "  прикреплен и удален"
        Kill    datapatch$ + XMLname ' исходный XML        
        Print datapatch$ + XMLname  & "   удален"
        
        doc.IDXml = Strleftback(XMLname,".")
        doc.flagXML="2" 'ставим флаг подписания XML документа
        doc.history="В " + Cstr(Now) + " документ ПОДПИСАН электронной подписью (" + session.CommonUserName + ")." &Chr(13)+" "&Chr(13) + doc.history(0)
'--------        для мультиподписания    
        If doc.HasItem("sign_name") Then 
            mas_tmp=doc.sign_name
            doc.sign_name=Fulltrim(Arrayappend(mas_tmp,session.CommonUserName))
        Else
            doc.sign_name=session.CommonUserName    
        End If                        
'--------        для мультиподписания                                        
        doc.ReplaceItemValue({SaveOptions},{0}).SaveToDisk=False
        Call doc.save (True,False)
        Call uidoc.Close
        Call workspace.EditDocument(True, doc)  '  False - чтение
        Msgbox "Документ успешно подписан."        
    End If    
    Exit Sub
    
ErrH:
    Print "Ошибка выгрузки в XML " & Error(Err) & " в строке " & Erl    
    Exit Sub
End Sub


Function SignXMLfile (criptogss As String, console_criptoGSS As String, infile As String, outfile As String) As Boolean
    On Error Goto errh
    SignXMLfile=False
    Dim cmd As String
    cmd =|"| + CriptoGSS + |CryptoGSS" "| +  infile  +|" "| + outfile    +|"| 
    Print cmd
    Dim WShell As Variant, WshExec As Variant, verify_class As Variant
    Set WShell=Nothing
    Set WshExec=Nothing
    
    Set WShell = CreateObject("WScript.Shell")
    Set WshExec = WShell.Exec(cmd)  'запускаем прогу      
    
    Dim getfile As Boolean, FName As Variant
    While WshExec.Status=0 'ждем закрытия проги
        Sleep 1
    Wend
    
    FName = Dir$(outfile, 0) 
    If FName <> "" Then 
        Print "найден файл: "+FName
        SignXMLfile=True        
    End If    
    
    If Not isVerifySign Then Exit Function 'Гроза, 28,03,2022 добавлена данная строчка (определяем из настроек проверять/не проверять подпись)
    
    Set WShell=Nothing
    Set WshExec=Nothing    
    
    If SignXMLfile Then'проверяем этот файл
        SignXMLfile=False
        Set verify_class=New verify_CriptoGSS
        
        If Not  verify_class.SetAllArg( console_criptoGSS, "All", outfile) Then  
            Messagebox verify_class.GetTextError,16,"Ошибка!!!"                
            Error 1000
        End If
        If Not  verify_class.verify Then 
            Messagebox verify_class.GetTextError,16,"Ошибка!!!"                
            Error 1000
        End If
        
        SignXMLfile=True    
    End If        
    
    Exit Function
errh:
    If Err<>1000 Then Messagebox "Ошибка подписания " & Error(Err) & " в строке " & Erl    & Chr(13) & "Возможно не корректно установлена CryptoGSS либо не корректно указана(либо отсутствует) переменная окружения CryptoPath",16,"Ошибка!!!"            
    SignXMLfile=False
    Exit Function
End Function

%REM
    Library ConsoleCriptoGSS_2.0
    Created Feb 18, 2021 by Admininstrator/CIT
    Description: Библиотека предназначена для подписания и проверки подписи, с использованием ConsoleCriptoGSS версии 2.0.0.7.
 
--Есть возможность подписывания сразу нескольких XML файлов(т.е. передавать в консольную криптогсс список файлов).
--Удобство подписывания сразу нескольких файлов заключается в том, что нет необходимости вводить каждый раз пароль от сертификата.
--Можно получать полную информацию о подписи/сях в файле
--Можно получать полную информацию об установленных сертификатах на ПК

--Пользоваться нужно двумя классами:
    Sign_CriptoGSS         - предназначен для подписания
    Verify_CriptoGSS     - предназначен для проверки

--Необходимо наличие библиотеки "ls.snapps.JSONReader" - библиотека для распарсивания json строки 
  Все ответы от ConsoleCriptoGSS мы получаем в виде json строки

--В ConsoleCriptoGSS версии 2.0.0.7 - добавлена возможность вытягивания ЕРН ФЛ, ЕРН ОИГВ, ЕРН ЮЛ
%END REM
Option Public
Option Declare

Use "ls.snapps.JSONReader" 'библиотека для распарсивания json строки

Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

%REM
    предназначен для массива подписываемых файлов
%END REM
Class SignInfoArray
    Public file_name_source As String     'файл источник
    Public file_name_result As String     'файл результат
    Public about             As String    'инфа о подписываемом файле
    Public additional         As Variant     'дополнительный параметр(можно использовать по своему усмотрению)
    
    Public IsSign             As Boolean    'подписан/не подписан (True/False)
    Public ErrTextSign         As String    'текст ошибки подписания(если была ошибка)
    
    Public IsVerify         As Boolean    'проверен/не проверен (True/False)
    Public ErrTextVerify     As String    'текст ошибки проверки(если была ошибка)    
End Class
%REM
    Class Base_Class - класс родитель для Sign_CriptoGSS и Verify_CriptoGSS

Public
    Property Get GetFormat_ades      As String      'получение формата подписи (Xades / Cades / All)    
    Property Get GetPath_criptoGSS  As String      'получение пути к консольной КриптоГСС    
    Property Get isError              As Boolean     'получение True/False - была/не была ошибка    
    Property Get GetNomError          As Integer     'получаем номер ошибки    
    Property Get GetTextError          As String      'получаем описание ошибки    
    Property Get CountListSert         As integer     'получаем кол-во сертов на ПК    
    Property Get GetListSert         As Variant    'получение записей о сертификатах (массив класса Certificate)    
    Property Get GetVersionConsole     As String      'получение версии консольной криптоГСС        
    Function RunGetListSert         As boolean  'заполнение списка (массив класса Certificate) сертификатов на компе
            
    Sub SetPath_criptoGSS(ByVal st As String)    'устанавливаем путь к консольной криптогсс
        где: st - путь к программе, например "c:\consolecriptogss\consolecriptogss.exe"
    
    Sub SetFormat_ades(ByVal st As String)        'устанавливаем формат подписи (Xades / Cades / All)
        где: st - значение для подписи может быть "Xades" или "Cades", для проверки любое из трех
%END REM
Class Base_Class
    Private m_ListSert() As Certificate 
    Private m_Ubound_idx_ListSertOnPC As Integer
    Private m_path_criptoGSS As String     'путь к консольной криптоГСС
    Private m_format_ades As String        'формат подписи Cades, Xades
    Private m_isError As Boolean     'была или нет ошибка 
    Private m_error_Nom As Integer    'номер ошибки
    Private m_error_Text As String    'описание ошибки
    Private m_error_list List As String    'список всех пользовательских ошибок
    
'РАЗДЕЛ Public НАЧАЛО ***********************************************************
    Public Property Get GetFormat_ades  As String  'получение формата подписи (Xades / Cades)
        If Me.m_isError Then Call NULL_Error
        GetFormat_ades = Me.m_format_ades
    End Property    
    
    Public Property Get GetPath_criptoGSS  As String  'получение пути к консольной КриптоГСС
        If Me.m_isError Then Call NULL_Error
        GetPath_criptoGSS = Me.m_path_criptoGSS
    End Property
    
    Public Property Get isError  As Boolean  'получение True/False - была/не была ошибка
        isError = Me.m_isError
    End Property    
    
    Public Property Get GetNomError  As Integer  'получаем номер ошибки
        GetNomError = Me.m_error_nom
    End Property
    
    Public Property Get GetTextError  As String  'получаем описание ошибки
        GetTextError = Me.m_error_Text
    End Property
    
    Public Property Get CountListSert As integer  'получаем кол-во сертов на ПК
        CountListSert = Me.m_Ubound_idx_ListSertOnPC+1
    End Property
    
    Public Property Get GetListSert As Variant    'получение записей о сертификатах (массив класса Certificate)
        If Me.m_isError Then Call NULL_Error
        If Me.m_Ubound_idx_ListSertOnPC=-1 Then
            Set GetListSert=Nothing                                     
        Else
            GetListSert=Me.m_ListSert            
        End If                
    End Property
    
    Public Property Get GetVersionConsole As String  'получение версии консольной криптоГСС
        If Me.m_isError Then Call NULL_Error
        Print "Получение версии ConsoleCriptoGSS начало"
        On Error GoTo ErrH
        GetVersionConsole=""
        Dim WShell As Variant, WshExec As Variant, OutStream As Variant
        Dim Cmd As String, str1 As String, j As Integer
        Dim sJSON As String, jsonReader As JSONReader, vResults As Variant, vPieces As Variant
        Dim i As Integer, idx As Integer, mes As String, source As String, result As String   
        
        cmd=Me.m_path_criptoGSS+{ }                'путь к криптоГСС*
        cmd=cmd+{ --versJson}    
        
        Set WShell=Nothing
        Set WshExec=Nothing
        
        Set WShell = CreateObject("WScript.Shell")
        Set WshExec = WShell.Exec(cmd)                
        
        Set OutStream = WshExec.StdOut '
        str1=""
        While Not OutStream.AtEndOfStream
            Str1 = Str1 & Trim(OutStream.ReadLine()) & Chr(13)
        Wend
        Str1=me.DecodeOemToChar(Str1)
        Str1=Trim(Replace(Str1, Chr(13), ""))
        
        Set jsonReader = New JSONReader
        Set vResults = jsonReader.Parse(str1)    'this is a JSONObject
        vPieces = vResults.Items

        If vPieces("Code")=0 Then mes=vPieces("Text"): Error 1240 '(0 - Произошла ошибка вызова программы, 1 - Success)
        
        vPieces=vPieces("OperationResultJson").items
        
        If vPieces("GeneralCode")=1 then'GeneralCode - Общий код выполнения операции
            GetVersionConsole=vPieces("VersionProject")
            GoTo ext   'все успешно
        Else        
            mes=vPieces("GeneralText") 
            Error 1241 '!не удалось 
        End If
ext:
        Set WshExec=Nothing
        Set WShell=Nothing
        Print "Получение версии ConsoleCriptoGSS конец"
        Exit Property

ErrH:
        GetVersionConsole="error"    
        Select Case Err
            Case 213   : 
                mes=Me.m_path_criptoGSS & " Системная ошибка № " & Err 
                Err=1243                
            Case Else  :            
        End Select        
        
        Call SetError(Err, mes)
        Resume ext        
    End Property
    
    Public Function RunGetListSert As boolean  'заполнение списка (массив класса Certificate) сертификатов на компе
        If Me.m_isError Then Call NULL_Error
        me.m_Ubound_idx_ListSertOnPC=-1
        Erase me.m_ListSert
        RunGetListSert=true        
        Print "Получение списка серификатов начало"
        On Error GoTo ErrH        
        Dim WShell As Variant, WshExec As Variant, OutStream As Variant
        Dim Cmd As String, str1 As String, j As Integer
        Dim sJSON As String, jsonReader As JSONReader, vResults As Variant, vPieces As Variant
        Dim i As Integer, idx As Integer, mes As String, source As String, result As String   
        
        cmd=Me.m_path_criptoGSS+{ }                'путь к криптоГСС*
        cmd=cmd+{ -o GetSert}    
        
        Set WShell=Nothing
        Set WshExec=Nothing
        
        Set WShell = CreateObject("WScript.Shell")
        Set WshExec = WShell.Exec(cmd)                
        
        Set OutStream = WshExec.StdOut '
        str1=""
        While Not OutStream.AtEndOfStream
            Str1 = Str1 & Trim(OutStream.ReadLine()) & Chr(13)
        Wend
        Str1=me.DecodeOemToChar(Str1)
        Str1=Trim(Replace(Str1, Chr(13), ""))
        
        Set jsonReader = New JSONReader
        Set vResults = jsonReader.Parse(str1)    'this is a JSONObject
        vPieces = vResults.Items

        If vPieces("Code")=0 Then mes=vPieces("Text"): Error 1240 '(0 - Произошла ошибка вызова программы, 1 - Success)
        
        vPieces=vPieces("OperationResultJson").items
        
        If vPieces("GeneralCode")=1 then'GeneralCode - Общий код выполнения операции
            vPieces=vPieces("DocumentGetSertResultsList").items
            For i=0 To UBound(vPieces)
                Dim record As New Certificate     
                With vPieces(i)
                    If Not IsNull(.GetItemValue("Name"))             Then record.FIO=.GetItemValue("Name")
                    If Not IsNull(.GetItemValue("Country"))         Then record.Country=.GetItemValue("Country")
                    If Not IsNull(.GetItemValue("Town"))             Then record.Town=.GetItemValue("Town")
                    If Not IsNull(.GetItemValue("Address"))         Then record.Address=.GetItemValue("Address")
                    If Not IsNull(.GetItemValue("Region"))             Then record.Region=.GetItemValue("Region")
                    If Not IsNull(.GetItemValue("Email"))             Then record.Email=.GetItemValue("Email")
                    If Not IsNull(.GetItemValue("WorkPlace"))         Then record.WorkPlace=.GetItemValue("WorkPlace")
                    If Not IsNull(.GetItemValue("WorkDepartment"))     Then record.WorkDepartment=.GetItemValue("WorkDepartment")
                    If Not IsNull(.GetItemValue("WorkPosition"))     Then record.WorkPosition=.GetItemValue("WorkPosition")
                    If Not IsNull(.GetItemValue("Thumbprint"))         Then record.Thumbprint=.GetItemValue("Thumbprint")
                    If Not IsNull(.GetItemValue("RootThumbprint"))     Then record.RootThumbprint=.GetItemValue("RootThumbprint")
                    If Not IsNull(.GetItemValue("DateFrom"))         Then record.DateFrom=.GetItemValue("DateFrom")    
                    If Not IsNull(.GetItemValue("DateTo"))             Then record.DateTo=.GetItemValue("DateTo")
                    If Not IsNull(.GetItemValue("IsValid"))         Then record.IsValid=(.GetItemValue("IsValid")="True")                
                    If Not IsNull(.GetItemValue("IsSkilled"))         Then record.IsSkilled=(.GetItemValue("IsSkilled")="True")
                    
                    If Not IsNull(.GetItemValue("UINFL"))             Then record.UINFL=.GetItemValue("UINFL")
                    If Not IsNull(.GetItemValue("UINUL"))             Then record.UINUL=.GetItemValue("UINUL")
                    If Not IsNull(.GetItemValue("UINOIGV"))         Then record.UINOIGV=.GetItemValue("UINOIGV")    
                End With        
                Me.m_Ubound_idx_ListSertOnPC=Me.m_Ubound_idx_ListSertOnPC+1
                ReDim Preserve me.m_ListSert(Me.m_Ubound_idx_ListSertOnPC)
                Set me.m_ListSert(Me.m_Ubound_idx_ListSertOnPC)=record        
            Next
            GoTo ext   'все успешно
        Else        
            mes=vPieces("GeneralText") 
            Error 1241 '!не удалось 
        End If            
ext:        
        Set WshExec=Nothing
        Set WShell=Nothing
        Print "Получение списка серификатов конец"
        Exit function

ErrH:
        RunGetListSert=false            
        Select Case Err
            Case 213   : 
                mes=Me.m_path_criptoGSS & " Системная ошибка № " & Err 
                Err=1243                
            Case Else  :            
        End Select        
        
        Call SetError(Err, mes)
        Resume ext                
    End function    

    Public Sub SetPath_criptoGSS(ByVal st As String)'устанавливаем путь к консольной криптогсс
        If Me.m_isError Then Call NULL_Error
        Me.m_path_criptoGSS=Trim(st)
    End Sub
    Public Sub SetFormat_ades(ByVal st As String)
        If Me.m_isError Then Call NULL_Error
        Me.m_Format_ades=Trim(st)
    End Sub
'РАЗДЕЛ Public КОНЕЦ    ************************************************    
    
    Private Sub SetError(ByVal er As Integer, mes As String)'записываем ошибку
        Me.m_isError=True
        Me.m_error_nom=er        
        
        If IsElement(Me.m_error_list(CStr(er))) Then
            Me.m_error_Text="Ошибка № " & Er & " " & Me.m_error_list(CStr(er))            
        Else
            Me.m_error_Text="Ошибка № " & Er & " в строке " & Erl & Chr(13) & Error(Er)            
        End If        
        If mes<>"" Then Me.m_error_Text=Me.m_error_Text & CStr(13) & mes
    End Sub
    
    Private Sub NULL_Error 'устанавливаем начальные значения для ошибок 
        Me.m_isError=False
        Me.m_error_nom=-1
        Me.m_error_Text=""
    End Sub
    
    Private Function DecodeOemToChar(source As String) As String'Функция перекодировки строки в DOS        
        Dim dest As String
        dest = Space$(Len(source))
        OemToChar source, dest
        DecodeOemToChar = dest
    End Function
    
    Private Sub GetListErrorBase 'заполняем лист данных пользовательскими ошибками
        'диаппазон пользовательских ошибок 1000-1999    
        Me.m_error_list("1240")="Произошла ошибка вызова программы!" '!
        Me.m_error_list("1241")="Не удалось получить версию программы!"'!все доки не подписаны (ничего не подписано)
        Me.m_error_list("1243")="Ошибка обращения к консольной КриптоГСС!" & _
        Chr(13)& "Возможно не найдена консольная КриптоГСС по пути" & Chr(13)
            %REM
        '            , mes As String
        'используется в ф-ции check SetPath_Source SetPath_Result
        Me.m_error_list("1000")="Не указан или не верный формат подписи!" '!
        Me.m_error_list("1001")="Не заполнена информация о файлах для подписи!" '!
        Me.m_error_list("1002")="Не заполнена или не полностью заполнена информация о файлах для подписи!" '!    
        Me.m_error_list("1003")="Не указан путь к консольной криптоГСС!" '!
        Me.m_error_list("1004")="Не указан hash сертификата пользователя!"     '!
        Me.m_error_list("1005")="Не указан путь к папке источника!" '!
        Me.m_error_list("1006")="Не указан путь к папке результата!" '!
        Me.m_error_list("1007")="Ошибка проверки либо создания каталога для файлов источников!" '!
        Me.m_error_list("1008")="Ошибка проверки либо создания каталога для подписанных файлов!" '!
        
        'ошибки по редактированию данных о файлах для подписи в ф-циях DelItem    ReplaceItemValue    ReplaceAllItemValue  AddItem
        Me.m_error_list("1020")="Индекс не входит в диаппазон данных!" '!
        Me.m_error_list("1021")="Нет данных для удаления!" '!
        Me.m_error_list("1022")="Нет данных для редактирования!"  '!
        Me.m_error_list("1023")="Неверное имя параметра!"' '!(ReplaceItemValue)    
        Me.m_error_list("1024")="Ошибка добавления записи о файле!"    & Chr(13) & "Значение не может быть пустым." '!
        
        'ошибки ф-ции подписания sign    
        Me.m_error_list("1040")="Произошла ошибка вызова программы!" '!
        Me.m_error_list("1041")="Не удалось подписать документы!"'!все доки не подписаны (ничего не подписано)                
        Me.m_error_list("1042")="Не все документы подписаны!"'!
        Me.m_error_list("1043")="Ошибка обращения к консольной КриптоГСС!" & _
        Chr(13)& "Возможно не найдена консольная КриптоГСС по пути" & Chr(13)
        'ошибки ф-ции подписания sign следующие ошибки могуть никогда и не произойти(сделал на всяк случай)
        Me.m_error_list("1044")="Не могу получить строку названий файлов!"'!
        Me.m_error_list("1045")="Не могу сделать начальные установки перед подписанием!"'!
        Me.m_error_list("1046")="Не могу установить успешное подписание!"'!
    

                %END REM                
    End Sub
End Class
%REM 
    Class Sign_CriptoGSS
    Description: Класс для подписания

==================================КРАТКОЕ ОПИСАНИЕ Public методов и свойств класса Sign_CriptoGSS============================================
*Наследованы от Base_Class: 
    Property Get GetFormat_ades      As String      'получение формата подписи (Xades / Cades)    
    Property Get GetPath_criptoGSS  As String      'получение пути к консольной КриптоГСС    
    Property Get isError              As Boolean     'получение True/False - была/не была ошибка    
    Property Get GetNomError          As Integer     'получаем номер ошибки    
    Property Get GetTextError          As String      'получаем описание ошибки    
    Property Get CountListSert         As integer     'получаем кол-во сертов на ПК    
    Property Get GetListSert         As Variant    'получение записей о сертификатах (массив класса Certificate)    
    Property Get GetVersionConsole     As String      'получение версии консольной криптоГСС        
    Function RunGetListSert         As boolean  'заполнение списка (массив класса Certificate) сертификатов на компе            
    Sub SetPath_criptoGSS                        'устанавливаем путь к консольной криптогсс    
    Sub SetFormat_ades                            'устанавливаем формат подписи (Xades / Cades)
    
*Объявлены в текущем классе (Sign_CriptoGSS)
    Property Get CountItems         As Integer     'получение кол-ва записей о файлах для подписи
    Property Get Items                 As Variant    'получение записей о файлах для подписи (массив типа SignInfoArray)
    Property Get GetHash             As String     'получение отпечатка серта пользователя
    Property Get GetServ_time_stamp As String      'получение адреса сервера штампа времени
    Property Get GetDir_Source      As String      'получение пути к папке источника файлов для подписи
    Property Get GetDir_Result      As String      'получение пути к папке подписанных файлов                
    Sub SetIsVerify                                 'устанавливаем инициировать проверку сразу или нет (по умолчанию False)
    Sub SetHash                                    'передаем отпечаток серта
    Sub SetServ_time_stamp                        'передаем адрес сервера штампа времени
    Function SetDir_Source            As Boolean     'передаем путь к каталогу источнику
    Function SetDir_Result            As Boolean    'передаем путь к каталогу результату
    Function SetAllArg                As Boolean    'устанавливаем все необходимие настройки (кроме данных о файлах)
    Function AddItem                As Boolean    'добавляем информацию о подписываем файле и файле результате
    Function ReplaceAllItemValue     As Boolean    'редактируем указанную запись о файлах
    Function ReplaceItemValue        As Boolean     'редактируем указанный элемент указанной записи о файлах
    Function DelItem                As Boolean    'удаляем запись о файле
    Function check                     As Boolean    'проверяем на корректность всех переданных установок для подписания
    Function sign                     As Boolean    'подписываем



=====================================ПОЛНОЕ ОПИСАНИЕ Public методов и свойств класса Sign_CriptoGSS============================================
*Наследованы от Base_Class:
    Property Get GetFormat_ades      As String      'получение формата подписи (Xades / Cades)    
    Property Get GetPath_criptoGSS  As String      'получение пути к консольной КриптоГСС    
    Property Get isError              As Boolean     'получение True/False - была/не была ошибка    
    Property Get GetNomError          As Integer     'получаем номер ошибки    
    Property Get GetTextError          As String      'получаем описание ошибки    
    Property Get CountListSert         As integer     'получаем кол-во сертов на ПК    
    Property Get GetListSert         As Variant    'получение записей о сертификатах (массив класса Certificate)    
    Property Get GetVersionConsole     As String      'получение версии консольной криптоГСС        
    Function RunGetListSert         As boolean  'заполнение списка (массив класса Certificate) сертификатов на компе
            
    Sub SetPath_criptoGSS(ByVal st As String)    'устанавливаем путь к консольной криптогсс
        где: st - путь к программе, например "c:\consolecriptogss\consolecriptogss.exe"
    
    Sub SetFormat_ades(ByVal st As String)        'устанавливаем формат подписи (Xades / Cades)
        где: st - значение для подписи может быть "Xades" или "Cades"
    
*Объявлены в текущем классе (Sign_CriptoGSS)    
    Property Get CountItems         As Integer     'получение кол-ва записей о файлах для подписи
    Property Get Items                 As Variant    'получение записей о файлах для подписи (массив типа SignInfoArray)
    Property Get GetHash             As String     'получение отпечатка серта пользователя
    Property Get GetServ_time_stamp As String      'получение адреса сервера штампа времени
    Property Get GetDir_Source      As String      'получение пути к папке источника файлов для подписи
    Property Get GetDir_Result      As String      'получение пути к папке подписанных файлов
                
    Sub SetIsVerify(ByVal st As Boolean)         'устанавливаем инициировать проверку сразу или нет
        где: st - True -проверять, False -не проверять
    
    Sub SetHash(ByVal st As String)             'передаем отпечаток серта
        где: st - отпечаток сертификата пользователя
    
    Sub SetServ_time_stamp(ByVal st As String)    'передаем адрес сервера штампа времени
        где: st - адрес сервера штампа времени
    
    Function SetDir_Source(ByVal st As String) As Boolean             'передаем путь к каталогу источнику
        где: st - путь к каталогу, например: "c:\xml"
             возвращаемое значение True - все успешно, False - была какая-то ошибка
    
    Function SetDir_Result(ByVal st As String) As Boolean            'передаем путь к каталогу результату
        где: st - путь к каталогу, например: "c:\xml\out"
             возвращаемое значение True - все успешно, False - была какая-то ошибка
        
    Function SetAllArg(_                        'устанавливаем все необходимие настройки (кроме данных о файлах)
            ByVal Path_criptoGSS As String, ByVal Hash As String,          ByVal Serv_time_stamp As String, _
            ByVal Format_ades As String,     ByVal Dir_Source As String,  ByVal Dir_Result As String) As Boolean
        где: Path_criptoGSS  - путь к программе, например: "c:\consolecriptogss\consolecriptogss.exe"
             Hash             - отпечаток сертификата пользователя
             Serv_time_stamp - адрес сервера штампа времени
             Format_ades     - устанавливаем формат подписи, значение для подписи может быть "Xades" или "Cades"
             Dir_Source         - путь к каталогу, например: "c:\xml"
             Dir_Result         - путь к каталогу, например: "c:\xml\out"
             возвращаемое значение True - все успешно, False - была какая-то ошибка
             
    Function AddItem(_                    'добавляем информацию о подписываем файле и файле результате
            ByVal source As String, ByVal  result As String, ByVal about As String, additional As Variant) As Boolean
        где: source           - имя подписываемого файла, например: "1.xml"
             result             - имя подписанного файла, например: "2.xml"
             about             - информация о файле, например: "№01-11/235 от 2.02.2021"
             additional         - можно использовать как контейнер для NotesDocument (для удобства обработки документов лотус)
             возвращаемое значение True - все успешно, False - была какая-то ошибка
             
    Function ReplaceAllItemValue(_        'редактируем указанную запись о файлах
            ByVal idx As Integer, ByVal source As String, ByVal result As String,_
            ByVal about As String, additional As Variant) As Boolean
        где: idx                - индекс редактируемого файла (нумерация начинается с нуля)
             source           - имя подписываемого файла, например: "1.xml"
             result             - имя подписанного файла, например: "2.xml"
             about             - информация о файле, например: "№01-11/235 от 2.02.2021"
             additional         - можно использовать как контейнер для NotesDocument (для удобства обработки документов лотус)
             возвращаемое значение True - все успешно, False - была какая-то ошибка
             
    Function ReplaceItemValue(_                'редактируем указанный элемент указанной записи о файлах
            idx As Integer, ItemName As String, ItemValue As Variant) As Boolean
        где: idx                - индекс редактируемого файла (нумерация начинается с нуля)
             ItemName           - название поля: "file_name_source" - имя файл исходника
                                               "file_name_result" - имя подписанного файл
                                               "about" - описание к документу
                                               "additional" - служебный аргумент(контейнер)    
             ItemValue         - новое значение, например: если меняем about - то "№01-11/231 от 2.02.2021"             
             возвращаемое значение True - все успешно, False - была какая-то ошибка
             
    Function DelItem(idx As Integer) As Boolean            'удаляем запись о файле
        где: idx                - индекс удаляемого файла из массива (нумерация начинается с нуля)
    
    Function check                     As Boolean    'проверяем на корректность всех переданных установок для подписания
    Function sign                     As Boolean    'подписываем


***ПРИМЕР 1 подписание двух документов*************************************************
    Dim doc as NotesDocument
    Dim sign_class As New Sign_CriptoGSS
'устанавливаем настройки    
    If Not  sign_class.SetAllArg("C:\ConsoleCriptoGSS\ConsoleCriptoGSS.exe", "ed08369c5d4b4f6ac431a0578f4f1cc6422f721b", _
                                "http://ca.agroprombank.com/tsa", "Xades", _
                                "c:\XML", "c:\XML\out") Then  Messagebox sign_class.GetTextError,16,"Ошибка!!!"

    If Not sign_class.AddItem("1.xml","2.xml","№123 от 1.02.2021",doc) Then 'добавляем первый документ 
        Messagebox sign_class.GetTextError,16,"Ошибка!!!"  
        Exit Sub
    end if
    
    If Not sign_class.AddItem("3.xml","4.xml","№321 от 2.02.2021",doc) Then 'добавляем второй документ 
        Messagebox sign_class.GetTextError,16,"Ошибка!!!"  
        Exit Sub
    end if
    
    If Not  sign_class.check Then  'проверка данных для подписания. вся ли информация собрана
        Messagebox sign_class.GetTextError,16,"Ошибка!!!" 
        Exit Sub    
    end if
    
    If Not sign_class.sign then 'ПОДПИСЫВАЕМ        
        Messagebox sign_class.GetTextError,16,"Ошибка!!!"
        if sign_class.GetNomError=1042 then'ошибка №1042 - обозначает, что документы подписались частично
            'часть доков подписалась - часть нет можем поработать с массивом типа SignInfoArray
            For i=0 To sign_class.CountItems-1    
                If sign_class.Items(i).IsSign Then'подписан
                    'какие-то действия
                end if
            next
        else
            'никто не подписался
        end if 
        Exit Sub
    else
        'все доки успешно подписаны        
    end if

***ПРИМЕР 2 получение списка сертификатов установленных на ПК*************************************************    
    Dim sign_class As New Sign_CriptoGSS
    
    Call sign_class.SetPath_criptoGSS("C:\ConsoleCriptoGSS\ConsoleCriptoGSS.exe")

    If Not sign_class.RunGetListSert Then  Messagebox sign_class.GetTextError,16,"Ошибка!!!"  : Exit Sub'не удалось получить список сертификатов
    If sign_class.CountListSert>0 Then
        For i=0 To sign_class.CountListSert-1
            If s<>"" Then s = s + Chr(13)+Chr(13)                
            s=s+"Name="            +    sign_class.GetListSert(i).FIO+Chr(13)
            s=s+"Country="        +    sign_class.GetListSert(i).Country+Chr(13)
            s=s+"Town="            +    sign_class.GetListSert(i).Town+Chr(13)
            s=s+"Address="        +    sign_class.GetListSert(i).Address+Chr(13)
            s=s+"Region="        +    sign_class.GetListSert(i).Region+Chr(13)
            s=s+"Email="        +    sign_class.GetListSert(i).Email+Chr(13)
            s=s+"WorkPlace="    +    sign_class.GetListSert(i).WorkPlace+Chr(13)
            s=s+"WorkDepartment="+    sign_class.GetListSert(i).WorkDepartment+Chr(13)
            s=s+"WorkPosition="    +    sign_class.GetListSert(i).WorkPosition+Chr(13)
            s=s+"Thumbprint="    +    sign_class.GetListSert(i).Thumbprint+Chr(13)
            s=s+"RootThumbprint="+    sign_class.GetListSert(i).RootThumbprint+Chr(13)
            s=s+"DateFrom="        +    sign_class.GetListSert(i).DateFrom+Chr(13)
            s=s+"DateTo="        +    sign_class.GetListSert(i).DateTo+Chr(13)
            s=s+"IsValid="        +    Cstr(sign_class.GetListSert(i).IsValid)+Chr(13)
            s=s+"IsSkilled="    +    Cstr(sign_class.GetListSert(i).IsSkilled)        
        Next    
    else
        Messagebox "Нет установленных сертификатов"        
    End If    
    Messagebox s                
=================================================================================================
%END REM

Public Class Sign_CriptoGSS As Base_Class 
    Private m_hash                     As String    'отпечаток сертификата пользователя
    Private m_serv_time_stamp         As String     'адрес сервера штампа сервера    
    Private m_Dir_Source             As String    'путь для источников для подписи
    Private m_Dir_Result             As String    'путь для результатов подписи
    Private m_Ubound_idx_SignInfo     As Integer     'номер последней записи в массиве записей о подписываемых файлах    
    Private m_isVerify                 As Boolean     'по умолчанию false (проверять не будем)     
    Private m_OBJECT_SIGN_INFO()     As SignInfoArray     'массив данных о файлах которые нужно подписать

'РАЗДЕЛ Public НАЧАЛО ***********************************************************    
    Public Sub New
        Call Me.NULL_Error
        Call Me.GetListErrorBase
        Call Me.GetListError
        
        me.m_error_nom=0
        me.m_path_criptoGSS=""
        me.m_hash=""
        me.m_serv_time_stamp=""
        me.m_format_ades=""
        me.m_Dir_Source=""
        me.m_Dir_Result=""                    
        Me.m_Ubound_idx_SignInfo=-1        
        Me.m_Ubound_idx_ListSertOnPC=-1
    End Sub
        
    Public Function sign As Boolean    'подписываем    
        Print "Подписание документа/ов ConsoleCriptoGSS начало"
        On Error GoTo ErrH
        sign=True        
        
        Dim WShell As Variant, WshExec As Variant, OutStream As Variant
        Dim Cmd As String, str1 As String, j As Integer
        Dim sJSON As String, jsonReader As JSONReader, vResults As Variant, vPieces As Variant
        Dim i As Integer, idx As Integer, mes As String, source As String, result As String   
        
        If Not GetFileNameInStr(source, result) Then Error 1044'! получаем строку названий фалов ч/з запятую
        If Not SetSignNULL Then Error 1045 '! устанавливаем информацию о подписании в false и очищаем текст ошибки
        
        'cmd="ConsoleCriptoGss.exe -o Sign -f Xades -s 1.xml,2.xml -r 3.xml,4.xml -t f1bd5c420e00d774189c20cf489fbdf74b8fc0eb -u http://ca.agroprombank.com/tsa"    
        cmd=Me.m_path_criptoGSS+{ }                'путь к криптоГСС*
        cmd=cmd+{-o Sign }
        cmd=cmd+{-f }+Me.m_format_ades +{ }        'формат подписи *
        cmd=cmd+{-s }+source+{ }     'исходник        *
        cmd=cmd+{-r }+result+{ }     'подписанный результат*
        cmd=cmd+{-t }+Me.m_hash+{ }                 'хэш    *
        If Trim(Me.m_serv_time_stamp)<>"" Then 'если указан адрес сервера штампа времени - используем его
            cmd=cmd+{-u "}+Me.m_serv_time_stamp+{"}        
        End If                
        
        Set WShell=Nothing
        Set WshExec=Nothing
        
        Set WShell = CreateObject("WScript.Shell")
        Set WshExec = WShell.Exec(cmd)                
        
        Set OutStream = WshExec.StdOut '
        str1=""
        While Not OutStream.AtEndOfStream
            Str1 = Str1 & Trim(OutStream.ReadLine()) & Chr(13)
        Wend
        Str1=me.DecodeOemToChar(Str1)
        Str1=Trim(Replace(Str1, Chr(13), ""))
        
        Set jsonReader = New JSONReader
        Set vResults = jsonReader.Parse(str1)    'this is a JSONObject
        vPieces = vResults.Items

        If vPieces("Code")=0 Then mes=vPieces("Text"): Error 1040 '(0 - Произошла ошибка вызова программы, 1 - Success)
        
        vPieces=vPieces("OperationResultJson").items
        
        Select Case vPieces("GeneralCode")'GeneralCode - Общий код выполнения операции
            Case 1: 
                If Not SetGoodAllSign Then Error 1046'!устанавливаем для всех файлов успешное подписание
                GoTo ver   'все успешно подписаны
            Case 2:
                vPieces=vPieces("documentSigningResultsList").items
                'смотрим с каким файлом произошла ошибка при подписании, а с каким нет                 
                For i=0 To UBound(vPieces)
                    For j=0 To me.m_Ubound_idx_SignInfo
                        If vPieces(i).GetItemValue("PathToXmlFile")=me.m_OBJECT_SIGN_INFO(j).file_name_result Then
                            idx=j
                            Exit For
                        End If                        
                    Next
                    If vPieces(i).GetItemValue("Code")=1 Then
                        me.m_OBJECT_SIGN_INFO(idx).IsSign=True
                    Else
                        me.m_OBJECT_SIGN_INFO(idx).IsSign=False
                        me.m_OBJECT_SIGN_INFO(idx).ErrTextSign=vPieces(i).GetItemValue("Text")                        
                    End If    
                Next    
                Error 1042 'не все подписаны успешно
            Case 3:
                mes=vPieces("GeneralText") 
                Error 1041 '!не удалось подписать ничего
        End Select    
ver:
        If Me.m_isVerify Then 'если нужно сразу проверять
            Dim verify_class As New verify_CriptoGSS
            If Not verify_class.SetAllArg( Me.m_path_criptoGSS, "All", "") Then
                sign=False
                me.m_error_text=Trim(CStr(me.m_error_nom)+" "+me.m_error_text+Chr(13))
                me.m_error_text=me.m_error_text+CStr(verify_class.GetNomError)+" "+verify_class.GetTextError
                GoTo ext
            End If
            For idx=0 To me.m_Ubound_idx_SignInfo    
                If me.m_OBJECT_SIGN_INFO(idx).IsSign Then'подписан
                    verify_class.SetFullPath_File(me.m_Dir_Result & me.m_OBJECT_SIGN_INFO(idx).file_name_result)
                    If verify_class.verify Then
                        me.m_OBJECT_SIGN_INFO(idx).IsVerify=True                        
                    Else
                        me.m_OBJECT_SIGN_INFO(idx).IsVerify=False
                        me.m_OBJECT_SIGN_INFO(idx).ErrTextVerify=CStr(verify_class.GetNomError)+" "+verify_class.GetTextError
                    End If
                End If
            Next    
        End If            
ext:
        Set WshExec=Nothing
        Set WShell=Nothing
        Print "Подписание документа/ов ConsoleCriptoGSS конец"
        Exit Function

ErrH:
        sign=False    
        Select Case Err
            Case 213   : 
                mes=Me.m_path_criptoGSS & " Системная ошибка № " & Err 
                Err=1043                
            Case Else  :            
        End Select        
        
        Call SetError(Err, mes)
        If Err=1042 Then'часть доков подписана
            Resume ver
        Else
            Resume ext    
        End If         
    End Function
            
  

%REM
    Library MED_XML
    Created Mar 23, 2021 by Admininstrator/CIT
    Description: библиотека для формирования XML и импорта в ворд
    
ВНИМАНИЕ!!!
4.10.2021
ф-ция CreateXML - изменение в формировании выбора адресатов - используется другая форма(чекбоксы на форме отрисовываются динамически)

22.03.2022 - изменена ф-ция ParsHtmlText
29.04.2022 - в ф-ции Replace_img убрано объявление переменной datpatch (т.к. это глобальная переменная)                          
%END REM
Option Public
Option Declare
Use "libBase64"

Const L_chrset$ = "UTF-8"
Const sys_sep$="->"
Const sys_NUL$="NUL"
Const sys_NOT_NUL$="NOT_NUL"
Const sys_NEW_L$="NEW_LINE"
Const sys_NEW_L2$="NEW_LINE2"
Const sys_FIO$="xxxx x. x."
Const sys_GERB$="REPLACE_GERB"
Const sys_Style$="REPLACE_STYLE"
Const wdEditorEveryone=-1
Const wdWithInTable=12
Const wdReplaceAll=2

Dim recv_list List As String
Dim c_files_MIME List As String
Dim L_db As NotesDatabase, L_doc As NotesDocument, uidoc As NotesUIDocument
Dim doc_templ As NotesDocument 'документ шаблона
Dim doc_reg As NotesDocument 'документ общий настроек
Dim pars_template As String, datpatch As String, L_docpatch As string


Sub Initialize
    
End Sub

%REM
    Function GetBol
    Description: 
flag=1 будем или нет изменять или брать значение из ворда
flag=2 будем или нет проверять значение в ворде
%END REM
Function GetBool(item As Variant, flag As Byte) As Boolean
    Dim tmp As String
    GetBool=False
    If flag=1 Then tmp="1" Else tmp=sys_NUL$ 
    ForAll v In item
        If flag=1 Then 
            If v=tmp Then GetBool=True
        Else
            If v<>sys_NUL Then GetBool=True    
        End if        
    End ForAll    
End Function


%REM
    Function ConvertToFormat
    Description: конвертируем значение в указанный формат
    
дата/время в виде '21 января 2020 8:00'|d mmmm yyyy h:nn
дата в виде '21 января 2020'|d mmmm yyyy
дата/время в виде '21.01.2020 8:00'|d.mm.yyyy h:nn
дата в виде '21.01.2020'|d.mm.yyyy
все БОЛЬШИЕ буквы|>
все маленькие буквы|<        
%END REM
Function ConvertToFormat(value As String, formattext As String) As String
    On Error GoTo errh
    Dim tmp As String, tmp2 As String, tmp3 As String, mas As Variant, i As Byte, sp As string
    ConvertToFormat=value
    sp=""
    Select Case formattext
        Case sys_FIO$:
            If InStr(value, Chr(13))>0 Then 
                sp=Chr(13)
            elseif InStr(value, "<br/>")>0 Then 
                sp="<br/>"
            end if
            If sp<>"" Then
                tmp2=StrLeft(value, sp)
                tmp3=sp+StrRight(value, sp)
                mas=Split(tmp2, " ")
            Else
                mas=Split(value, " ")
            End if    
                
            i=0
            ForAll v In mas
                If i=0 Then 
                    tmp = mas(i) 
                ElseIf i>0 And i<=2 Then
                    tmp =tmp +" "+ Left$(mas(i),1)+ ". "
                Else
                    tmp =tmp +mas(i)
                End If                 
            i=i+1
            End ForAll
            tmp =tmp + tmp3
        Case else:
            tmp=Format$(value, formattext)
            If InStr(formattext,"mmmm")>0 Then        
                tmp2=GetMonthRus(Month(CDat(value)))
                If tmp2<>"" Then
                    mas=Split(tmp," ")
                    mas(1)=tmp2
                    tmp=Join(mas," ")
                End If            
            End If
    End Select
    
    ConvertToFormat=tmp
    Exit Function
errh:    
    Exit Function
End Function
%REM
    Function GetMonthRus
    Description: получение названий месяцев на русском языке
%END REM
Function GetMonthRus(nom As byte) As String
    Dim mas As Variant
    
    If nom<1 And nom>12 Then GetMonthRus="" : Exit function
    mas=Split("января,февраля,марта,апреля,мая,июня,июля,августа,сентября,октября,ноября,декабря",",")
    GetMonthRus=mas(nom-1)
End Function
%REM
    Function GetItemValue
    Description: получаем значение из нотес документа
flag = 0 - для XML
flag = 1 - для Word
several_items
параллельно|0
последовательно|1

%END REM
Function GetItemValue(doc_templ As NotesDocument, idx As Variant, flag As Byte) As String
    Dim sep As String, mas_tmp As Variant, doc_tmp As NotesDocument, tmp_tmp As String, item As NotesItem, mas_tmp2() As String
    Dim i As Integer, j As integer
    GetItemValue=""
    If doc_templ.separator(idx)=sys_NUL$ Then 
        sep$=""
    ElseIf doc_templ.separator(idx)=sys_NEW_L$ Then
        Select Case flag
            Case 0: sep$="<br/>"
            Case 1: sep$=Chr(13)
        End Select
    ElseIf doc_templ.separator(idx)=sys_NEW_L2$ Then
        Select Case flag
            Case 0: sep$="<br/><br/>"
            Case 1: sep$=Chr(13)+Chr(13)
        End Select        
    ElseIf doc_templ.separator(idx)="_" Then 
        sep$=" "
    Else 
        sep$=doc_templ.separator(idx)                    
    End If
    
    mas_tmp=Split(doc_templ.items_notes_doc(idx),sys_sep$)    
    Set doc_tmp=Nothing
    If doc_templ.from_notesdoc(idx)="1" Then Set doc_tmp=L_doc
    If doc_templ.from_notesdoc(idx)="0" Then Set doc_tmp=doc_reg
    If Not doc_tmp Is Nothing Then        
        i=0:j=-1        
        ReDim mas_tmp2(UBound(mas_tmp),0)
        ForAll v1 In mas_tmp
            If doc_tmp.HasItem(v1) Then
                Set item=doc_tmp.GetFirstItem(v1)
                j=-1                
                ForAll v2 In item.Values
                    If Trim(v2)<>"" Then
                        j=j+1
                        If UBound(mas_tmp2,2)<j Then ReDim Preserve mas_tmp2(UBound(mas_tmp),j)
                        mas_tmp2(i,j)=v2                        
                    End If
                End ForAll
            End If
            i=i+1
        End ForAll
        tmp_tmp=""
        Select Case doc_templ.several_items(idx)
            Case "0":'параллельно(берем первое значение с первого итема, потом первое значение со второго итема .... второе - значение с 1, второе значение со 2)
                For j=0 To UBound(mas_tmp2,2)
                    For i=0 To UBound(mas_tmp2,1)                
                        If Trim(mas_tmp2(i,j))<>"" Then
                            If tmp_tmp="" Then tmp_tmp=mas_tmp2(i,j) Else tmp_tmp=tmp_tmp+sep$+mas_tmp2(i,j)
                        End If                    
                    Next
                Next            
            Case "1":'последовательно(старый вариант - применялся во всех случаях, сначала одно поле - потом второе и т.д.)
                For i=0 To UBound(mas_tmp2,1)
                    For j=0 To UBound(mas_tmp2,2)
                        If Trim(mas_tmp2(i,j))<>"" Then
                            If tmp_tmp="" Then tmp_tmp=mas_tmp2(i,j) Else tmp_tmp=tmp_tmp+sep$+mas_tmp2(i,j)
                        End If                    
                    Next
                Next
        End Select            
    End If
        '?????If sep="<br/>" then    tmp_tmp_for_Word=Replace(tmp_tmp,"<br/>",Chr(13)) else    tmp_tmp_for_Word=tmp_tmp    
    GetItemValue=tmp_tmp
End Function
%REM
    Sub ImportToWord
    Description: импорт в ворд, используем настройки документа шаблона
%END REM
Sub ImportToWord
    Print "Старт - экспорт с данных лотус дока в ворд файл"
    On Error GoTo ErrH    
    Dim Session As New NotesSession, uiworkspace As New NotesUIWorkspace
    Dim rtitemA As NotesRichTextItem
    Dim worddoc As Variant, WordApp As Variant, obj As Variant, myRange As Variant, tmp_tmp As String, tmp_tmp2 As String
    Dim i As Byte, idx As Variant, view As NotesView, isEditWord As Boolean, dat1 As NotesDateTime
    Dim worddoc_tmp As Variant, j As Byte
    Dim textob As Variant, fio As Variant, sep As String, mas_tmp As Variant, item As NotesItem
    Dim oname As String, myText As String, myText1 As String, doc_tmp As NotesDocument
            
    Set view = L_db.GetView ("reg" )
    Set doc_reg = view.GetFirstDocument
    If doc_reg Is Nothing Then MessageBox "Нет доступа к настройкам регистрации!": Exit Sub
    
    idx=ArrayGetIndex(doc_templ.name_rekv, "текст_документа")
    If Not IsNull(idx) Then                
        If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then                    
            Set rtitemA = L_doc.GetFirstItem(doc_templ.items_notes_doc(idx))
        End If
    Else
        MessageBox "Не настроен документ шаблона. Укажите в документе настроек шаблона реквизит 'текст_документа'" 
        Exit Sub        
    End If
    
    If rtitemA Is Nothing Then MessageBox "Нет документа word" : Exit Sub
    If IsEmpty( rtitemA.EmbeddedObjects) Then     MessageBox "Нет документа word" : Exit Sub
    
    Set obj=rtitemA.EmbeddedObjects(0)    
    If  Not  (obj.Type = EMBED_ATTACHMENT ) Then         MessageBox "Нет документа word" : Exit Sub
    
    Call obj.ExtractFile( L_docpatch & obj.Source )    '  М/Б ошибка, если ворд завис. Не возвращает ничего
    Sleep 1
    oname$ = obj.Source 
    
    Set WordApp = CreateObject ("Word.Application")
    WordApp.Visible=  True  'False
    Set worddoc = WordApp.Documents.Open(L_docpatch + oname)
    worddoc.Select    
    isEditWord=False
    For idx=0 To UBound(doc_templ.name_rekv)
        tmp_tmp=""    
        If doc_templ.flag_N_to_W(idx)="1" Then  'из notes в Word
            If doc_templ.table(idx)<>sys_NUL$ And doc_templ.items_notes_doc(idx)<>sys_NUL$ Then 'получаем значение из ворда
                If doc_templ.separator(idx)=sys_NUL$ Then 
                    sep$=""
                ElseIf doc_templ.separator(idx)=sys_NEW_L$ Then    
                    sep$=Chr(13)
                ElseIf doc_templ.separator(idx)=sys_NEW_L2$ Then    
                    sep$=Chr(13)+Chr(13)
                ElseIf doc_templ.separator(idx)="_" Then 
                    sep$=" "
                Else 
                    sep$=doc_templ.separator(idx)                    
                End If
                
                mas_tmp=Split(doc_templ.items_notes_doc(idx),sys_sep$)
                Set doc_tmp=Nothing
                If doc_templ.from_notesdoc(idx)="1" Then Set doc_tmp=L_doc
                If doc_templ.from_notesdoc(idx)="0" Then Set doc_tmp=doc_reg
                If Not doc_tmp Is Nothing Then
                    ForAll v1 In mas_tmp
                        If doc_tmp.HasItem(v1) Then
                            Set item=doc_tmp.GetFirstItem(v1)
                            ForAll v2 In item.Values
                                If Trim(v2)<>"" Then
                                    If tmp_tmp="" Then tmp_tmp=v2 Else tmp_tmp=tmp_tmp+sep$+v2
                                End If
                            End ForAll
                        End If
                    End ForAll                        
                End If
                Print tmp_tmp
                If Trim (tmp_tmp)<>"" Then
                    If doc_templ.format(idx)<>sys_NUL$    Then tmp_tmp=ConvertToFormat(tmp_tmp, doc_templ.format(idx))                                        
                End If    
                'Print doc_templ.name_rekv(idx) , tmp_tmp
                tmp_tmp2=""
                mas_tmp=Split(doc_templ.table(idx),sys_sep$)
                Set worddoc_tmp=Nothing
                Set worddoc_tmp=worddoc
                Set myRange=GetRange(worddoc_tmp, mas_tmp, 0)'рекурсией получаем нужную ячейку мз нужной таблицы                
                tmp_tmp2=Replace(MyRange.text,Chr(13)+Chr(7),"")                    
                If Trim(LCase(tmp_tmp))<>Trim(LCase(tmp_tmp2)) Then'нужно записать в ворд нужное значение                                                    
                    For j=1 To CInt(doc_templ.CountEditableRange(0))
                        worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)                                                                
                        If     (myRange.Start<=worddoc.Application.Selection.Start)And (myRange.End  >=worddoc.Application.Selection.End) Then
                            If tmp_tmp="" Then tmp_tmp=" "
                            worddoc.Application.Selection.TypeText(tmp_tmp)                                    
                            Exit For                                                                
                        End If
                    Next            
                    isEditWord=True
                End If                                                        
            End If
        End If
    Next    
    
    worddoc.Close
    WordApp.Quit
    Set worddoc=Nothing
    Set WordApp=Nothing                    
    Print "WordApp.Quit"
    Sleep 1
    
    If isEditWord Then
        Call obj.remove ' удалили старое письмо с поля
        rtitemA.Update
        
        Call rtitemA.EmbedObject ( EMBED_ATTACHMENT, "", L_docpatch + oname)  ' прикрепили новое
        rtitemA.Update
        
        uidoc.AutoReload=False
        uidoc.Save
        Call uidoc.Close(True)        
        L_doc.history=CStr(Now) + " импорт в ворд (" + session.CommonUserName + ")." &Chr(13)+" "&Chr(13) + L_doc.history(0)    
        Call L_doc.Save(True, False)    
        Set  uidoc=uiworkspace.EditDocument(True,L_doc)    
        
        Kill  L_docpatch + oname
        'MessageBox    "Данные с документа добавлены в  Письмо"
        MessageBox    "Данные из карточки документа были добавлены в письмо!"            
    End If
    
    Print "Конец - экспорт с дока в ворд"
    Exit Sub
ErrH:
    If Not IsEmpty(worddoc) Then If Not (worddoc Is Nothing) Then worddoc.close        
    If Not IsEmpty(WordApp) Then If Not    (WordApp Is Nothing) Then WordApp.quit            
    Print "Библиотека 'MED_XML' ф-ция 'ImportToWord'. Ошибка импорта в ворд " & Error(Err) & " в строке " & Erl    
    Exit Sub    
End Sub
Function Proverka(mes As String, b_templ As Boolean) As Boolean
    On Error GoTo errh    
    Dim mas_tmp As Variant, item As NotesItem
    Dim i As Integer, view As NotesView, tmp As String, sep As String, b As Boolean
    Dim rtitemA As Variant, idx As variant, c_files_ext As string
    Proverka=True    
    
    If Not GetTemplSett(mes, b_templ) Then Error 1000
    
    ' Индивидуальные значения для организации
    Set view = L_db.GetView ("reg" )
    Set doc_reg = view.GetFirstDocument
    If doc_reg Is Nothing Then mes="Нет доступа к настройкам регистрации!" :  Error 1000
    
    If b_templ Then
        idx=ArrayGetIndex(doc_templ.name_rekv, "адресат")
        If Not IsNull(idx) Then
            If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then                
                mas_tmp=Split(doc_templ.items_notes_doc(idx),sys_sep$)
                Set item=L_doc.Getfirstitem(mas_tmp(0))'для адресата берем только первый итем для проверки
                If Not item Is Nothing Then
                    If item.values(0)="" Or (L_doc.Server_id(0)<>"" And L_doc.Server_id_resp(0)="") Or L_doc.Server_id(0)="" Then
                        mes="Воспользуйтесь кнопкой выбора адресата мэд"    
                        Error 1000
                    End If
                End If                
            End If
        End If
    Else
        'если нужно скрыть саму кнопку для новых адресатов то в условие скрытия нужно добавть | (Server_id!="" & Server_id_resp="") | Server_id=""
        'НАЧАЛО исправлен баг №1    
        If L_doc.adresed(0)="" Or (L_doc.Server_id(0)<>"" And L_doc.Server_id_resp(0)="") Or L_doc.Server_id(0)="" Then
            mes="Воспользуйтесь кнопкой выбора адресата мэд"    
            Error 1000
        End If
        'КОНЕЦ исправлен баг №1        
    End If
    
    tmp$="" 
    sep$=""    
    If b_templ Then
        i=0
        ForAll v In doc_templ.flag_obyaz_XML
            If v="1" Then
                If doc_templ.items_notes_doc(i)<>sys_NUL$ And doc_templ.name_rekv(i)<>"адресат" Then
                    mas_tmp=Split(doc_templ.items_notes_doc(i),sys_sep$)
                    b=True
                    ForAll v1 In mas_tmp
                        If L_doc.HasItem(v1) Then
                            Set item=L_doc.GetFirstItem(v1)
                            If Trim( item.Text )="" Then b=False:Exit ForAll
                        End If
                    End ForAll
                    If Not b  Then tmp$=tmp$+sep$+Replace(doc_templ.name_rekv(i),"_"," ") : sep$=", "
                End If                
            End If
            i=i+1
        End ForAll
    Else
        If  Trim(L_doc.regnom(0)) = "" Then tmp$="Номер документа" : sep$=", "
        If  Trim(L_doc.datereg(0)) = "" Then tmp$=tmp$+sep$+"Дата регистрации документа" : sep$=", "
        If  Trim(L_doc.isp(0)) = "" Or Trim(L_doc.phone(0)) = "" Then tmp$=tmp$+sep$+"Исполнитель (и его телефон)" : sep$=", "
        If  Trim(L_doc.header(0)) = "" Then tmp$=tmp$+sep$+"Заголовок" : sep$=", "            
    End If    
    If  tmp$<>""Then mes= "Заполните все поля: " + tmp$    :  Error 1000    
    
    Set rtitemA=Nothing
    If b_templ Then
        idx=ArrayGetIndex(doc_templ.name_rekv, "xml_документ")
        If Not IsNull(idx) Then
            If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then
                Set rtitemA = L_doc.GetFirstItem(doc_templ.items_notes_doc(idx))
                If Not rtitemA Is Nothing Then
                    If Not IsEmpty( rtitemA.EmbeddedObjects) Then mes="Документ XML уже был сформирован." : Error 1000
                End If                
            End If                    
        End If        
    Else
        Set rtitemA = L_doc.GetFirstItem("XMLattach" )
        If Not IsEmpty( rtitemA.EmbeddedObjects) Then mes="Документ XML уже был сформирован." : Error 1000
    End If    
    
%REM
pars_template - записано в доке регистрации что делать с шаблоном Word 
парсить ШАБЛОН Word|0
НЕ парсить ШАБЛОН Word, а добавлять его как приложение|1
брать текст из поля где должен быть шаблон Word|2
%END REM
    pars_template="0" 'по умолчанию парсим ШАБЛОН Word
    If doc_reg.hasitem("pars_template") Then    If doc_reg.pars_template(0)<>"" Then pars_template=doc_reg.pars_template(0)
    
    If Not L_doc.HasEmbedded And pars_template="1" Then    mes="Нет вложений в документе!." : Error 1000
    
    Set rtitemA=Nothing
    If pars_template="0" Then 'проверяем наличие шаблона только в случае если нужно парсить
        If b_templ Then'берем только название поля
            idx=ArrayGetIndex(doc_templ.name_rekv, "текст_документа")
            If Not IsNull(idx) Then                
                If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then                    
                    Set rtitemA = L_doc.GetFirstItem(doc_templ.items_notes_doc(idx))
                End If
            End If
        Else
            Set rtitemA = L_doc.GetFirstItem("text" )     '   ---------   ПРОПУСКНАЯ СИСТЕМА Письмо  И ВЛОЖЕНИЯ    
        End If            
        
        If  rtitemA Is Nothing Then    mes= "Нет письма (docm/docx) для подписания! " :    Error 1000
        
        ForAll empID In c_files_MIME 'собираем список допустимых типов файлов для приложений
            If c_files_ext$="" Then c_files_ext$=ListTag(empID) Else c_files_ext$=c_files_ext$+", "+Listtag(empID)
        End ForAll                            
        
        If IsEmpty( rtitemA.EmbeddedObjects) Then
            mes= "Нет письма (docm/docx) для подписания! " 
            Error 1000
        Else            
            If  rtitemA.EmbeddedObjects(0).Type = EMBED_ATTACHMENT  Then    
                If pars_template="0" Then ' если парсим
                    If   LCase(StrRightBack(rtitemA.EmbeddedObjects(0).Source , ".")) <> "docm" And LCase(StrRightBack(rtitemA.EmbeddedObjects(0).Source , ".")) <> "docx"Then
                        mes="Допустимо формирование XML только на основе файла с расширением .docm/.docx"
                        Error 1000
                    End If                            
                Else ' если цепляем вложением
                    If IsElement(c_files_MIME(LCase(StrRightBack(rtitemA.EmbeddedObjects(0).Source , ".")))) Then    
                        mes="Допустимы вложения в форматах: "+c_files_ext$
                        Error 1000
                    End If                                                
                End If
            End If                                
        End If            
    End If
    
    Set rtitemA=Nothing
    If b_templ Then'берем только название поля
        idx=ArrayGetIndex(doc_templ.name_rekv, "приложение")
        If Not IsNull(idx) Then                
            If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then                    
                Set rtitemA = L_doc.GetFirstItem(doc_templ.items_notes_doc(idx))
            End If
        End If
    Else
        Set rtitemA = L_doc.GetFirstItem("attach" )   
    End If            
    
    If  Not rtitemA Is Nothing Then
        If Not IsEmpty( rtitemA.EmbeddedObjects) Then
            ForAll obj In rtitemA.EmbeddedObjects
                If  ( obj.Type = EMBED_ATTACHMENT ) Then
                    If Not IsElement(c_files_MIME(LCase(StrRightBack(obj.Source , ".")))) Then    
                        mes="Допустимы вложения в форматах: "+c_files_ext$
                        Error 1000
                    End If                    
                End If
            End ForAll
        End If        
    End If    
ext:
    Exit Function

errh:
    proverka=False
    If Err<>1000 Then mes="Ошибка пропускной системы " & Error(Err) & " в строке " & Erl    
    Resume ext
End Function

Function Replace_OName(oname As String) As String
    'oname = Replace (oname,")","_")
    'oname = Replace (oname,"(","_")
    oname = Replace (oname,"&","&amp;")
    Replace_OName=oname
End Function

%REM
    Sub RunCreateXML
    Description: точка входа формирования XML
%END REM
Sub RunCreateXML
    On Error GoTo ErrH
    Dim session As New NotesSession, ws As New NotesUIWorkspace, tmp_tmp As String
    Dim b_templ As Boolean 'true-берем данные для формирования из документа шаблона, false - по старому работаем        
    Set L_db = session.CurrentDatabase    
    Set uidoc = ws.CurrentDocument
    
    If ws.Prompt (PROMPT_YESNO, "Внимание",    "Сформировать XML документ?") <> 1 Then Exit Sub
    Print "Старт формирования документа."    
    Call uidoc.save  ' иначе новые доки не отправятся, т.к. XMLattach  не существует еще ((.    
    Set L_doc = uidoc.Document
    
    Call ZapolnTypeFiles 'заполняем разрешенными типами документов приложений
    
    If Not proverka(tmp_tmp, b_templ) Then  MessageBox tmp_tmp : Exit Sub ' - ---   ПРОПУСКНАЯ СИСТЕМА
    
    Call DataPatchInstall    
    
    'b_templ=false
    Select Case b_templ
        Case True:     Call CreateXML("")'CreateXML         'используем настройки из документа шаблона
        Case False: Call CreateXML_OLD    'работаем по старой схеме
    End Select
    Exit Sub
    
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'RunCreateXML'. Ошибка выгрузки в XML " & Error(Err) & " в строке " & Erl    
    Exit Sub 
End Sub

%REM
    Function ProverkaForAttach
    Description: Comments for Function
%END REM
Function Proverka_attach(mes As String, namefile As String) As Boolean
    On Error GoTo errh    
    Dim mas_tmp As Variant, item As NotesItem, ws As New NotesUIWorkspace, dc As NotesDocumentCollection
    Dim i As Integer, view As NotesView, tmp As String, sep As String, b As Boolean, c_files_ext As string
    Dim rtitemA As Variant, idx As Variant, oname As String, mas() As String, picklist As Variant
    Proverka_attach=True    
    pars_template="0"
    If Not L_doc.HasEmbedded Then    mes="Нет вложений в документе!." : Error 1000        
    ' Индивидуальные значения для организации
    Set view = L_db.GetView ("reg" )
    Set doc_reg = view.GetFirstDocument
    If doc_reg Is Nothing Then mes="Нет доступа к настройкам регистрации!" :  Error 1000    
    
    'выбор шаблона по которому будем формировать
    Set view = L_db.GetView("searchtemplates")    
        
    picklist = ws.PickListStrings(PICKLIST_CUSTOM,     False, L_db.Server, L_db.FilePath,     "admin_templatesO1",     "Шаблоны", "Выберите шаблон, по которому будем формировать XML:", 2) 
    If IsEmpty(picklist) Then mes="Шаблон не выбран!" :  Error 1000
    
    Set dc = view.GetAllDocumentsByKey(picklist(0), True)
    Set doc_templ = dc.GetFirstDocument()
    If doc_templ Is Nothing Then mes="Не найден документ шаблона": Error 1000
    
    'выбор приложения с которого будем формировать
    Set rtitemA=Nothing
    idx=ArrayGetIndex(doc_templ.name_rekv, "приложение")
    If Not IsNull(idx) Then                
        If doc_templ.items_notes_doc(idx)<>sys_NUL$ Then                    
            Set rtitemA = L_doc.GetFirstItem(doc_templ.items_notes_doc(idx))
        Else
            mes="В документе шаблона не указано поле для приложений." : Error 1000
        End If
    Else
        mes="В документе шаблона не указано поле для приложений." : Error 1000
    End If
    i=0
    If  Not rtitemA Is Nothing Then
        Call rtItemA.update    
        If rtitemA.Type = RICHTEXT Then 
            If Not IsEmpty(rtitemA.EmbeddedObjects) Then
                ForAll empID In c_files_MIME 'собираем список допустимых типов файлов для приложений
                    If c_files_ext$="" Then c_files_ext$=ListTag(empID) Else c_files_ext$=c_files_ext$+", "+Listtag(empID)
                End ForAll      
                ForAll obj In rtitemA.EmbeddedObjects
                    If ( obj.Type = EMBED_ATTACHMENT ) Then   
                        If Not IsElement(c_files_MIME(LCase(StrRightBack(obj.Source , ".")))) Then    'проверим на соответствие типов приложений                            
                            mes="Допустимы приложения в форматах: "+c_files_ext$
                            Error 1000
                        End If                            
                        If LCase(StrRightBack(obj.Source , "."))="docx" Or LCase(StrRightBack(obj.Source , "."))="docm" Then
                            oname$ = Replace_OName(CStr(obj.Source ))
                            ReDim Preserve mas(i)        
                            mas(i)=oname$ 
                            i=i+1
                        End If                    
                    End If                
                End ForAll
            End If
        End If
    Else
        mes="В документе нет итема для приложений." : Error 1000
    End If
    
    If i=0 Then mes="Нет подходящего вложения в документе!." : Error 1000    
    'вывод списка для выбора вложения
    Erase picklist
    picklist = ws.Prompt (PROMPT_OKCANCELLIST, "Выбор приложения", "Выберите приложение из которого необходимо формировать XML.", "", mas)
    If IsEmpty (picklist) Then     mes="Не выбрано приложение для формирования XML!." : Error 1000        
    namefile=picklist
    tmp$="" 
    sep$=""    
    i=0
    'проверяем на обязательность заполнения полей в документе лотус
    ForAll v In doc_templ.flag_obyaz_XML
        If v="1" Then
            If doc_templ.items_notes_doc(i)<>sys_NUL$ Then
                mas_tmp=Split(doc_templ.items_notes_doc(i),sys_sep$)
                b=True
                ForAll v1 In mas_tmp
                    If L_doc.HasItem(v1) Then
                        Set item=L_doc.GetFirstItem(v1)
                        If Trim( item.Text )="" Then b=False:Exit ForAll
                    End If
                End ForAll
                If Not b  Then tmp$=tmp$+sep$+Replace(doc_templ.name_rekv(i),"_"," ") : sep$=", "
            End If                
        End If
        i=i+1
    End ForAll
    If  tmp$<>""Then mes= "Заполните все поля: " + tmp$    :  Error 1000        
ext:
    Exit Function

errh:
    Proverka_attach=False
    If Err<>1000 Then mes="Ошибка пропускной системы " & Error(Err) & " в строке " & Erl    
    Resume ext
End Function
Function Replace_img(mytext  As String) As String 'ищем картинки в тексте и конвертим их в base64
    On Error GoTo ErrH   
    Const sub_dir="doctmp.files"
    Const c_files_ext="jpeg; jpg; png; tif"    'для проверки на типы картинок которые могут быть в тексте
    
    Dim inStream As NotesStream, patchName As String, fileName As String, session As New NotesSession, c_files_MIME List As String
    Dim arr As Variant, L_str As String, R_str As String, plainText As String
    Set inStream=session.Createstream()     
    
    patchName=datpatch+sub_dir
    
    If  Dir$ (patchName,16 )="" Then ' проверка на наличие  папки "doctmp.files", т.к. если в шаблоне в тексте нет картинок, то эта папка не создается
        Replace_img=mytext
        Exit Function
    '    Mkdir datpatch
    '    Mkdir datpatch+"\OUT"
    End If
    
    patchName=patchName+"\"    
    
    fileName = Dir$(patchName, 0)    
    
    If fileName$<>"" Then
        arr=Split(c_files_ext,"; ")
        GoSub const_zapoln                
    End If
    
    Do While fileName$ <> ""
        Print "картинка: "+fileName$
        If Not IsNull(ArrayGetIndex(arr,LCase(StrRightBack(fileName$, "."))))    Then 'проверяем на допустимый тип картинки
%REM
дана подстрока 
<img width=236 height=420 id="Рисунок 1" src="doctmp.files/image001.jpg">
<img width=603 height=190 src="doctmp.files/image001.png" align=left hspace=12>
ее нужно заменить на соответствующий base64 файл
%END REM
        'нужно найти src="doctmp.files/image001.jpg"
            '    If Instr(mytext, {src="}+sub_dir+{/}+fileName$+{">})>0 Then 'если в html файле есть картинка которая есть в директории - то преобразовываем картинку в base64
            If InStr(mytext, {src="}+sub_dir+{/}+fileName$+{"})>0 Then 'если в html файле есть картинка которая есть в директории - то преобразовываем картинку в base64
            '    L_str$=Strleft(mytext, {src="}+sub_dir+{/}+fileName$+{">}) 'вырезали все что до src="doctmp.files/image001.jpg">
                L_str$=StrLeft(mytext, {src="}+sub_dir+{/}+fileName$+{"}) 'вырезали все что до src="doctmp.files/image001.jpg"
                L_str$=StrLeftBack(  L_str$ ,  {<img})                                 'вырезали все что до <img        
            '    R_str$=Strright(mytext, {src="}+sub_dir+{/}+fileName$+{">})        ''вырезали все что после src="doctmp.files/image001.jpg"
                R_str$=StrRight(mytext, {src="}+sub_dir+{/}+fileName$+{"})        ''вырезали все что после src="doctmp.files/image001.jpg"
                R_str$=StrRight(R_str$, {>})        ''вырезали все что после src="doctmp.files/image001.jpg"
                
                Call inStream.Open(patchName & fileName$, "binary")    ' в поток inStream файл        
                Dim b64 As New CBase64()
                plainText$ =  b64.encode (inStream)        
                plainText$=     Replace(plainText$,Chr(10),"") ' удаляем спецсимволы во вложениях
                plainText$=     Replace(plainText$,Chr(9),"")
                plainText$=     Replace(plainText$,Chr(13),"")
                Call inStream.Close
                Kill patchName & fileName$
        'склеиваем результат            
                mytext = L_str$  + {<object }+Replace(c_files_MIME(LCase(StrRightBack(fileName$, "."))),"href","data")
                mytext = mytext + plainText$ +{"></object>} 
                mytext = mytext +R_str$+ Chr(13)                                            
            End If
            
        End If
        fileName$ = Dir$()
    Loop
    Replace_img=mytext
    Exit Function
    
const_zapoln:
    ' https://ru.wikipedia.org/wiki/Список_MIME-типов      -   подсказка
    c_files_MIME("jpeg")    =    {href="data:image/jpeg;base64,}
    c_files_MIME("jpg")    =    {href="data:image/jpeg;base64,}
    c_files_MIME("png")    =    {href="data:image/png;base64,}
    c_files_MIME("tif")        =    {href="data:image/tif;base64,}
    Return
ErrH:    
    Print "Библиотека 'MED_XML' ф-ция 'Replace_img'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function
Function Strclean (mystr As String) As String
    On Error GoTo ErrH
    Dim ascx As String, tmpstr  As String, lenstr As Variant, x As Variant
    tmpstr= ""
    'tmpstr=mystr
    lenstr = Len(mystr)
    'MsgBox mystr
    '%REM
    For x=1 To lenstr 'очищаем от ненужных символов (указываем только те - которые нужны)
        ascx =  Mid$(mystr,x,1) 
'        If (Asc(ascx)>31) And (Asc(ascx)<38) Or ( Asc(ascx)>38 And Asc(ascx)<153) Or (Asc(ascx)>191)  And (Asc(ascx)<256) _
'        Or (Asc(ascx)=171)  Or (Asc(ascx)=187) Or (Asc(ascx)=185) Then        
        If (Asc(ascx)>31 And Asc(ascx)<38) Or ( Asc(ascx)>38 And Asc(ascx)<153) Or (Asc(ascx)>191 And Asc(ascx)<256) _
        Or Asc(ascx)=163 Or Asc(ascx)=165 Or Asc(ascx)=168_
        Or Asc(ascx)=170 Or Asc(ascx)=171 Or Asc(ascx)=175 Or Asc(ascx)=178 Or Asc(ascx)=179_
        Or Asc(ascx)=180 Or (Asc(ascx)>=184 And Asc(ascx)<=187)_
        Or Asc(ascx)=191 Or Asc(ascx)=177 Then                
            tmpstr = tmpstr + ascx
        End If
    Next
    'MsgBox tmpstr    
    '%END REM
    
'HTML символы заменяем (появляются после сохрания в html)   http://_.ascii.cl/htmlcodes.htm
    

    tmpstr = Replace(tmpstr,{quot;},{&quot;})  ' "
    tmpstr = Replace(tmpstr,{amp;},{&amp;})  ' &
    
    tmpstr = Replace(tmpstr,{lt;},{&lt;})  ' <
    tmpstr = Replace(tmpstr,{gt;},{&gt;})  ' >
    
    tmpstr = Replace(tmpstr,{nbsp;},{&nbsp;})  ' неразрывный пробел
    tmpstr = Replace(tmpstr,{iexcl;},{&iexcl;})  
    tmpstr = Replace(tmpstr,{cent;},{&cent;})  
    tmpstr = Replace(tmpstr,{pound;},{&pound;})  
    tmpstr = Replace(tmpstr,{curren;},{&curren;})  
    tmpstr = Replace(tmpstr,{yen;},{&yen;})  
    tmpstr = Replace(tmpstr,{brvbar;},{&brvbar;})  
    tmpstr = Replace(tmpstr,{sect;},{&sect;})  
    tmpstr = Replace(tmpstr,{uml;},{&uml;})  
    tmpstr = Replace(tmpstr,{copy;},{&copy;})  
    tmpstr = Replace(tmpstr,{laquo;},{&laquo;})  
    tmpstr = Replace(tmpstr,{reg;},{&reg;})  
    tmpstr = Replace(tmpstr,{macr;},{&macr;})  
    
    tmpstr = Replace(tmpstr,{euro;},{&euro;})  
    
    tmpstr = Replace(tmpstr,{sup1;},{&#185;})  ' верхний индекс "один"
    tmpstr = Replace(tmpstr,{sup2;},{&#178;})  
    tmpstr = Replace(tmpstr,{sup3;},{&#179;})  
    
    tmpstr = Replace(tmpstr,{frac14;},{&#188;})  'дробь - одна четверть
    tmpstr = Replace(tmpstr,{frac12;},{&#189;})  '     дробь - одна вторая
    tmpstr = Replace(tmpstr,{frac34;},{&#190;})  'дробь - три четверти
    'MsgBox tmpstr    
    'удаляем пустые параграфы
    tmpstr = Replace(tmpstr,{<p><span style="padding:0px 10px;"></span></p>},"") 
    
    'fileNum% = Freefile()
    'Open  "C:\xml\temp.txt" For Append As fileNum%
    'Print # fileNum%, tmpstr
    'Close  fileNum%
    
    'Dim array1(1) As String ' для замены переносов строк в содержании
    'Dim array2(1) As String
    'array1(0) = Chr(13)
    'array1(1) = Chr(9)
    'array2(0) = "</p><p>"
    'array2(1) = {<span style="padding:0px 10px;"></span>}
    'tmpstr = Replace(tmpstr,array1,array2) 
    'tmpstr = "<p>" +  tmpstr + "</p>"
    
    'Msgbox tmpstr
    Strclean  =    tmpstr

    Exit Function
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'Strclean'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function

Function Strclean2 (mystr As String) As String
    ' для обращения "Уважаемый", отдельная функция, т.к. может быть в ображении две строки с Имя Отчество.
    On Error GoTo ErrH
    Dim ascx As String, tmpstr  As String    
    tmpstr= mystr
    
'HTML символы заменяем (появляются после сохрания в html)   http://_.ascii.cl/htmlcodes.htm
    tmpstr = Replace(tmpstr,{quot;},{&quot;})  ' "
    tmpstr = Replace(tmpstr,{amp;},{&amp;})  ' &
    
    tmpstr = Replace(tmpstr,{lt;},{&lt;})  ' <
    tmpstr = Replace(tmpstr,{gt;},{&gt;})  ' >
    
    tmpstr = Replace(tmpstr,{nbsp;},{&nbsp;})  ' неразрывный пробел
    tmpstr = Replace(tmpstr,{iexcl;},{&iexcl;})  
    tmpstr = Replace(tmpstr,{cent;},{&cent;})  
    tmpstr = Replace(tmpstr,{pound;},{&pound;})  
    tmpstr = Replace(tmpstr,{curren;},{&curren;})  
    tmpstr = Replace(tmpstr,{yen;},{&yen;})  
    tmpstr = Replace(tmpstr,{brvbar;},{&brvbar;})  
    tmpstr = Replace(tmpstr,{sect;},{&sect;})  
    tmpstr = Replace(tmpstr,{uml;},{&uml;})  
    tmpstr = Replace(tmpstr,{copy;},{&copy;})  
    tmpstr = Replace(tmpstr,{laquo;},{&laquo;})  
    tmpstr = Replace(tmpstr,{reg;},{&reg;})  
    tmpstr = Replace(tmpstr,{macr;},{&macr;})  
    
    tmpstr = Replace(tmpstr,{euro;},{&euro;})  
    
    tmpstr = Replace(tmpstr,{sup1;},{&#185;})  ' верхний индекс "один"
    tmpstr = Replace(tmpstr,{sup2;},{&#178;})  
    tmpstr = Replace(tmpstr,{sup3;},{&#179;})  
    
    tmpstr = Replace(tmpstr,{frac14;},{&#188;})  'дробь - одна четверть
    tmpstr = Replace(tmpstr,{frac12;},{&#189;})  '     дробь - одна вторая
    tmpstr = Replace(tmpstr,{frac34;},{&#190;})  'дробь - три четверти
    
    'удаляем пустые параграфы
    tmpstr = Replace(tmpstr,{<p><span style="padding:0px 10px;"></span></p>},"") 
    
    Strclean2  =    tmpstr
    Exit Function
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'StrClean2'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function

Function ParsHtmlTextOLD(htmltext As Variant) As String
    On Error GoTo ErrH   
    Dim mytext As String, objRegExp As Variant
    mytext$=htmltext
    mytext$ = StrRight (mytext$,"<body lang=RU" )
    mytext$ = StrRight (mytext$,">" )
    mytext$ = StrLeftBack  (mytext$,"</body>" )
    
    mytext$=     Replace(mytext$,Chr(10)," ") ' переход на новую строку - надо пробел
    mytext$=     Replace(mytext$,Chr(9),"") ' табуляция?
    mytext$=     Replace(mytext$,Chr(13),"")  'возврат каретки 
    mytext$=     Replace(mytext$,Chr(7),"")     
        '                                                               ЗАМЕНЫ РЕГУЛЯРКАМИ    
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True '  проверять по всему тексту
    objRegExp.Multiline = True ' обрабатывать много строк
    
    objRegExp.Pattern ={<br(.*?)>}  '   ? - Ленивый режим 
    mytext$= objRegExp.Replace(mytext$, "<br />")    
    
    objRegExp.Pattern ={<hr(.*?)">}  ' hr
    mytext$= objRegExp.Replace(mytext$, "<hr />")    
    
    objRegExp.Pattern ={onmouseover="(.*?)"} '  \s - пробел   [" ]
    mytext$= objRegExp.Replace(mytext$, "")    
    
    objRegExp.Pattern ={onmouseout="(.*?)"}  
    mytext$= objRegExp.Replace(mytext$, "")    
    mytext$= Replace(mytext$,{<p class='MsoNormal'>},"") 
    mytext$=  Replace(mytext$,{'},{"})
    
    objRegExp.Pattern ={border=} ' ТАБЛИЦЫ
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={border="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={cellspacing=}
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={cellspacing="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={cellpadding=}
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={cellpadding="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={colspan=}
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={colspan="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={rowspan=}
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={rowspan="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={tr height=}  ' 2020.02.03 Боря
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={tr height="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    'objRegExp.Pattern ={<table(.*?)>}  ' временно очищаем все таблицы
    'mytext$= objRegExp.Replace(mytext$, "<table>")    
    
    objRegExp.Pattern ={<span(.*?)>}    'найти и удалить span
    mytext$= objRegExp.Replace(mytext$, "")    
    
    objRegExp.Pattern ={ class=[\S]+?\>} ' найти  "class=...>"     \S -    непробельные символы, \s - пробелбные
    mytext$= objRegExp.Replace(mytext$, ">")    
    
    objRegExp.Pattern ={ class=[^ ]*} ' найти все "class=...пробел" 
    mytext$= objRegExp.Replace(mytext$, "")    
    
    objRegExp.Pattern ={ style=(.*?)>} ' найти все style=...>
    mytext$= objRegExp.Replace(mytext$, ">")    
    
    objRegExp.Pattern ={<div(.*?)>} ' найти все div=...>
    mytext$= objRegExp.Replace(mytext$, "")    
    
    objRegExp.Pattern ={font-family(.*?)>}
    mytext$= objRegExp.Replace(mytext$, "")    
    
    'objRegExp.Pattern ={width="([0-9])%"}
    'mytext$ = objRegExp.Replace(mytext$, {$&"})    
    
    objRegExp.Pattern ={width=}
    mytext$ = objRegExp.Replace(mytext$, {$&"})    
    objRegExp.Pattern ={width="([0-9])+}
    mytext$ = objRegExp.Replace(mytext$,  {$&"})    
    
    objRegExp.Pattern ={valign=(.*?)(top|middle|bottom|baseline)}     
    mytext$= objRegExp.Replace(mytext$, "")    
    
'***************************************************************************
    mytext$=Replace_img(mytext$)
    objRegExp.Pattern ={<img(.*?)>}
    mytext$= objRegExp.Replace(mytext$, "КАРТИНКА УДАЛЕНА")    
'***************************************************************************    
    
    objRegExp.Pattern ={<INPUT(.*?)>}
    mytext$= objRegExp.Replace(mytext$, "")
    
    objRegExp.Pattern =|<a {0,4}name=(.*?)>| ' найти все <a name=p5368> 13.11.2020
    mytext$= objRegExp.Replace(mytext$, "<a>")    
    
    mytext$=  Replace(mytext$,{width=""},{width="})        
    
    mytext$=  Replace(mytext$,"language=JavaScript ","")
    mytext$=  Replace(mytext$,"</span>","")
    mytext$=  Replace(mytext$,"<div />","")
    mytext$=  Replace(mytext$,"<div >","")
    mytext$=  Replace(mytext$,"</div>","")
    mytext$=  Replace(mytext$,"<div>","")
    mytext$=  Replace(mytext$,"<div  >","")
    mytext$=  Replace(mytext$,"nowrap","")
    mytext$=  Replace(mytext$,"nowrap","")
    
    mytext$=  Replace(mytext$,"<br>","<blok></blok>")    '   неидеально!  было <br />, но браузер при подписании удаляет этот тег и эцп летит.
    mytext$=  Replace(mytext$,"&nbsp;"," ") ' Неразрывный пробел
    mytext$=  Replace(mytext$,"&#8201","") ' короткий пробел
    mytext$=  Replace(mytext$,"#8776;","≈") '  ≈
    
    mytext$=  Replace(mytext$,"<div >","")
    mytext$=  Replace(mytext$,"align=center",{align="center"})
    mytext$=  Replace(mytext$,"align=right",{align="right"})
    mytext$=  Replace(mytext$,"align=left",{align="left"})
'ВРЕМЕННАЯ МЕРА9.10.2020    
    mytext$=  Replace(mytext$,"hspace=0",{hspace="0"})
    mytext$=  Replace(mytext$,"vspace=0",{vspace="0"})
'ВРЕМЕННАЯ МЕРА    

    mytext$=  Replace(mytext$,"<p></p>","<blok></blok>")'ранее меняли на "<blok></blok>" 
    mytext$=  Replace(mytext$,"<p> </p>","<blok></blok>")
    mytext$=  Replace(mytext$,"<p>  </p>","<blok></blok>")
    mytext$=  Replace(mytext$,"<p>   </p>","<blok></blok>")
    mytext$=  Replace(mytext$,"<p>    </p>","<blok></blok>")
    mytext$=  Replace(mytext$,"<p>     </p>","<blok></blok>")

    'mytext$=  Replace(mytext$,{border="0"},{border="1"})  '  кривой вариант...
    mytext$=  Replace(mytext$,"<h1>","<p>")    
    mytext$=  Replace(mytext$,"<h2>","<p>")
    mytext$=  Replace(mytext$,"<h3>","<p>")
    mytext$=  Replace(mytext$,"<h4>","<p>")
    mytext$=  Replace(mytext$,"<h5>","<p>")
    mytext$=  Replace(mytext$,"<h6>","<p>")
    mytext$=  Replace(mytext$,"<h1 ","<p ")
    mytext$=  Replace(mytext$,"<h2 ","<p ")
    mytext$=  Replace(mytext$,"<h3 ","<p ")
    mytext$=  Replace(mytext$,"<h4 ","<p ")
    mytext$=  Replace(mytext$,"<h5 ","<p ")
    mytext$=  Replace(mytext$,"<h6 ","<p ")
    mytext$=  Replace(mytext$,"</h1>","</p>")
    mytext$=  Replace(mytext$,"</h2>","</p>")
    mytext$=  Replace(mytext$,"</h3>","</p>")
    mytext$=  Replace(mytext$,"</h4>","</p>")
    mytext$=  Replace(mytext$,"</h5>","</p>")
    mytext$=  Replace(mytext$,"</h6>","</p>")
    
'    objRegExp.Pattern =|<p>{0,10}</p>| ' найти все <p></p>27.11.2021
'    mytext$= objRegExp.Replace(mytext$, "<blok></blok>")    
    
'%REM 
'8.10.2021 <pre> была замена на <p> изменил на пустоту(НЕЛЬЗЯ МЕНЯТЬ НА ПУСТОТУ!!!! КОСЯКИ ВЫЛАЗЯТ, теряются абзацы)
'01.11.2021 изменил на objRegExp.Pattern =|<pre {0,10}>| - пока обкатываем
    mytext$=  Replace(mytext$,"<pre>","<p>")
    '10.02.2021
    mytext$=  Replace(mytext$,"<pre >","<p>")
    mytext$=  Replace(mytext$,"<pre  >","<p>")
    mytext$=  Replace(mytext$,"<pre   >","<p>")
    '10.02.2021
    mytext$=  Replace(mytext$,"</pre>","</p>")        
'%END REM
%REM
    mytext$=  Replace(mytext$,"<pre>","")    
    mytext$=  Replace(mytext$,"<pre >","")
    mytext$=  Replace(mytext$,"<pre  >","")
    mytext$=  Replace(mytext$,"<pre   >","")    
    mytext$=  Replace(mytext$,"</pre>","")    
%END REM    
    
    mytext$=  Replace(mytext$,"uml;","¨")   '  &uml;  - две точки нд буквой в немецком
    
    mytext$   =  Strclean (mytext$)   ' для корректной подписи в криптопровайдере. Парсятся ненужные спецсимволы.
    ParsHtmlTextOLD=mytext$
    
    Exit Function
    
ErrH:    
    Print "Библиотека 'MED_XML' ф-ция 'ParsHtmlText'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function

Function Strclean (mystr As String) As String
    On Error GoTo ErrH
    Dim ascx As String, tmpstr  As String, lenstr As Variant, x As Variant
    tmpstr= ""
    'tmpstr=mystr
    lenstr = Len(mystr)
    'MsgBox mystr
    '%REM
    For x=1 To lenstr 'очищаем от ненужных символов (указываем только те - которые нужны)
        ascx =  Mid$(mystr,x,1) 
'        If (Asc(ascx)>31) And (Asc(ascx)<38) Or ( Asc(ascx)>38 And Asc(ascx)<153) Or (Asc(ascx)>191)  And (Asc(ascx)<256) _
'        Or (Asc(ascx)=171)  Or (Asc(ascx)=187) Or (Asc(ascx)=185) Then        
        If (Asc(ascx)>31 And Asc(ascx)<38) Or ( Asc(ascx)>38 And Asc(ascx)<153) Or (Asc(ascx)>191 And Asc(ascx)<256) _
        Or Asc(ascx)=163 Or Asc(ascx)=165 Or Asc(ascx)=168_
        Or Asc(ascx)=170 Or Asc(ascx)=171 Or Asc(ascx)=175 Or Asc(ascx)=178 Or Asc(ascx)=179_
        Or Asc(ascx)=180 Or (Asc(ascx)>=184 And Asc(ascx)<=187)_
        Or Asc(ascx)=191 Or Asc(ascx)=177 Then                
            tmpstr = tmpstr + ascx
        End If
    Next
    'MsgBox tmpstr    
    '%END REM
    
'HTML символы заменяем (появляются после сохрания в html)   [url]http://_.ascii.cl/htmlcodes.htm[/url]
    

    tmpstr = Replace(tmpstr,{quot;},{&quot;})  ' "
    tmpstr = Replace(tmpstr,{amp;},{&amp;})  ' &
    
    tmpstr = Replace(tmpstr,{lt;},{&lt;})  ' <
    tmpstr = Replace(tmpstr,{gt;},{&gt;})  ' >
    
    tmpstr = Replace(tmpstr,{nbsp;},{&nbsp;})  ' неразрывный пробел
    tmpstr = Replace(tmpstr,{iexcl;},{&iexcl;})  
    tmpstr = Replace(tmpstr,{cent;},{&cent;})  
    tmpstr = Replace(tmpstr,{pound;},{&pound;})  
    tmpstr = Replace(tmpstr,{curren;},{&curren;})  
    tmpstr = Replace(tmpstr,{yen;},{&yen;})  
    tmpstr = Replace(tmpstr,{brvbar;},{&brvbar;})  
    tmpstr = Replace(tmpstr,{sect;},{&sect;})  
    tmpstr = Replace(tmpstr,{uml;},{&uml;})  
    tmpstr = Replace(tmpstr,{copy;},{&copy;})  
    tmpstr = Replace(tmpstr,{laquo;},{&laquo;})  
    tmpstr = Replace(tmpstr,{reg;},{&reg;})  
    tmpstr = Replace(tmpstr,{macr;},{&macr;})  
    
    tmpstr = Replace(tmpstr,{euro;},{&euro;})  
    
    tmpstr = Replace(tmpstr,{sup1;},{&#185;})  ' верхний индекс "один"
    tmpstr = Replace(tmpstr,{sup2;},{&#178;})  
    tmpstr = Replace(tmpstr,{sup3;},{&#179;})  
    
    tmpstr = Replace(tmpstr,{frac14;},{&#188;})  'дробь - одна четверть
    tmpstr = Replace(tmpstr,{frac12;},{&#189;})  '     дробь - одна вторая
    tmpstr = Replace(tmpstr,{frac34;},{&#190;})  'дробь - три четверти
    'MsgBox tmpstr    
    'удаляем пустые параграфы
    tmpstr = Replace(tmpstr,{<p><span style="padding:0px 10px;"></span></p>},"") 
    
    'fileNum% = Freefile()
    'Open  "C:\xml\temp.txt" For Append As fileNum%
    'Print # fileNum%, tmpstr
    'Close  fileNum%
    
    'Dim array1(1) As String ' для замены переносов строк в содержании
    'Dim array2(1) As String
    'array1(0) = Chr(13)
    'array1(1) = Chr(9)
    'array2(0) = "</p><p>"
    'array2(1) = {<span style="padding:0px 10px;"></span>}
    'tmpstr = Replace(tmpstr,array1,array2) 
    'tmpstr = "<p>" +  tmpstr + "</p>"
    
    'Msgbox tmpstr
    Strclean  =    tmpstr

    Exit Function
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'Strclean'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function