1

Тема: Лотус скрипты для работы с XML

Данный скрипт создает с ворд файла внутри лотус карточки  - XML файл.
В  globals  у формы
Option Public
Use "Library"
Use "ConsoleCriptoGSS_2.0"
Use "MED_XML"
Use "LogEvents"


Декларации
Dim nTimer As NotesTimer
Public XMLname As String
Public datapatch As String
Public intwait As Integer ' сколько попыток поиска конца xml
Dim currUIDoc As NotesUIDocument
Dim path_criptoGSS As String


Кнопка Сформировать XML

Sub Click(Source As Button)
    Call RunCreateXML
End Sub

Поделиться

2

Re: Лотус скрипты для работы с XML

Кнопка "Подписать XML"


Декларации
Dim isVerifySign As Boolean 'Гроза, 28,03,2022 добавлена данная строчка (определяем из настроек проверять/не проверять подпись)


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

Поделиться

3

Re: Лотус скрипты для работы с XML

Отправить XML в Межвед

Опции
Use "VerifySignedXML"

Sub Click(Source As Button)'v.2.0 - ВКЛЮЧУ, КОГДА ЧИЛЮК ПОСТАВЛЮ КОНСОЛЬНУЮ КРИПТОГСС
%REM    ' копирует документ и приложение XML в базу роутер
добавлено
    If CurDoc.hasitem("count_adressed") Then '9.02.2021
        docR.count_adressed=CurDoc.count_adressed    
    End If
    
20.09.2021 добавлена проверка на подпись(проверяется ФИО в сопроводе - ФИО в ЭП(+ЕРН) и ФИО в базе подписантов(+ЕРН) )
                убраны лишние строки, которые проверяли наличие пути к XML на диске пользователя
                из объявления переменных убраны лишние переменные
                Use "Library" - закомментировал за ненадобностью
%END REM    
    On Error Goto ErrH    
    Print "В Межвед отправка"    
    Dim Session As New NotesSession, uiworkspace As New NotesUIWorkspace, CurDataBase As NotesDataBase
    Dim rtitemA As NotesRichTextItem, view As NotesView, db2 As NotesDatabase, item As NotesItem, uiDoc As NotesUIDocument    
    Dim CurDoc As NotesDocument, docR As NotesDocument
    Dim verify_p As New Verify_Signed_XML
    'Dim verify_p As Variant
    'Set verify_p=New Verify_Signed_XML
    
    If uiworkspace.Prompt (PROMPT_YESNO, "Внимание",    "Отправить подписанный документ в МЕЖВЕД?") <> 1 Then Exit Sub
    
    Set CurDataBase=Session.CurrentDataBase
    
    Set view = CurDataBase.GetView ("reg" )
    Set docreg = view.GetFirstDocument
    If docreg Is Nothing Then Messagebox("Нет доступа к настройкам регистрации!") : Exit Sub    
    
    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
    path_criptoGSS=docreg.ConsoleCriptoGSS(0)    
    
    server$ = docreg.Router(0)   
    databaseFileName$ =   docreg.RouterFile(0)
    
    Set db2 = Session.GetDatabase(server$, databaseFileName$)
    If Not db2.Isopen Then
        Messagebox    "Нет доступа к Базе Роутер!", 16, "Ошибка!!!"    
        Exit Sub
    End If
    
    Set CurDoc=uiworkspace.CurrentDocument.Document
    Set uidoc = uiworkspace.CurrentDocument
    Call uidoc.save
    
    If CurDoc.Server_id(0) ="отправлено" Then
        Messagebox    "Документ уже был отправлен в МЭД!", 16, "Ошибка!!!"    
        Exit Sub
    End If
    
    If CurDoc.HasEmbedded Then
        Set rtitemA = CurDoc.GetFirstItem("XMLattach" )
        If Isempty( rtitemA.EmbeddedObjects) Then
            Messagebox    "В документе нет xml для отправки", 16, "Ошибка!!!"    
            Exit Sub
        Else            
            Forall obj In rtitemA.EmbeddedObjects
                If  ( obj.Type = EMBED_ATTACHMENT ) Then    
                    If   Not Lcase(Strrightback(obj.Source , ".")) = "xml"  Then
                        Messagebox    "Нет подписанного вложения XML", 16, "Ошибка!!!"    
                        Exit Sub
                    End If
                End If
            End Forall
        End If
    End If
    
    If Not verify_p.VerifySignedXMLFromDoc(path_criptoGSS, "", "", CurDoc, "XMLattach") Then 'проверка подписанта    
        If Not Messagebox(verify_p.GetErrorText+Chr(13)+Chr(13)+"Возможно Ваш документ могут не принять на стороне адресата!!!"+Chr(13)+Chr(13)+"Продолжить отправку?",     4+64+256, "Внимание!!!")=6 Then Exit Sub
    End If
    
    Set docR = New NotesDocument( db2 ) ' создали новый док в базе роутер    
    
    Set item = CurDoc.GetFirstItem( "header" )
    Call docR.CopyItem (item,"ЗАГОЛОВОК")
    
    Set item = CurDoc.GetFirstItem( "adresed" )
    Call docR.CopyItem (item,"АДРЕСАТ")
    
    Set item = CurDoc.GetFirstItem( "regnom_1" )
    Call docR.CopyItem (item,"РЕГИСТРАЦИОННЫЙ_НОМЕР")
    
    Set item = CurDoc.GetFirstItem( "datereg" )
    Call docR.CopyItem (item,"ДАТА_РЕГИСТРАЦИИ")
    
    Set item = CurDoc.GetFirstItem( "NameOrg" )  'НЕИСП в XML, 
    Call docR.CopyItem (item,NameOrg)
    
    Set item = CurDoc.GetFirstItem( "isp" )
    Call docR.CopyItem (item,"ФАМИЛИЯ")
    
    Set item = CurDoc.GetFirstItem( "Server_id" )
    Call docR.CopyItem (item,Server_id)
    
    docR.id_doc =  CurDoc.id(0)
    
    If CurDoc.hasitem("count_adressed") Then '9.02.2021
        docR.count_adressed=CurDoc.count_adressed    
    End If
    
    Set item = CurDoc.GetFirstItem( "XMLattach" )
    If Not item Is  Nothing     Then Call docR.CopyItem (item,"ПРИЛОЖЕНИЯ_")
    
    Set item = CurDoc.GetFirstItem( "IDXml" )
    Call docR.CopyItem (item,IDXml)
    
' ----------------            
    docR.Form="fmejved"
    docR.fxml="0"
    docR.ТИП_ДОКУМЕНТА="Исходящий"
    
    Call docR.Save(True, True)
    CurDoc.Server_id="отправлено"
    CurDoc.flagXML="3"
    Adresat$=""
    Adr = CurDoc.GetItemValue( "NameOrg" )
    Forall tmp In Adr ' все адресаты в строку
        Adresat$ = Adresat$  +" " + tmp
    End Forall    
    
    CurDoc.history="МЭД: в " + Cstr(Now) + " документ " + CurDoc.IDXml(0) + " отправил " + session.CommonUserName + " "&Chr(13)+" на "+ Adresat$  +"." &Chr(13)+" "&Chr(13) + CurDoc.history(0)
    
    Call CurDoc.Save(True,False)    
    
    Messagebox "Документ успешно отправлен в МЭД!"
    
    Call uidoc.Reload
    
    Print "В Межвед отправка - конец"    
    Exit Sub
ErrH:
    Print "Межвед! - Ошибка: " & Error(Err) & " в строке " & Erl
    Exit Sub
End Sub

Поделиться

4

Re: Лотус скрипты для работы с XML

Библиотека ConsoleCriptoGSS_2.0


%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
            
  

Поделиться

5

Re: Лотус скрипты для работы с XML

Продолжение

  Public Property Get CountItems As Integer 'получение кол-ва записей о файлах для подписи
        If Me.m_isError Then Call NULL_Error
        CountItems=me.m_Ubound_idx_SignInfo+1
    End Property
    
    Public Property Get Items As Variant    'получение записей о файлах для подписи (массив типа SignInfoArray)
        If Me.m_isError Then Call NULL_Error
        If Not IsArray(Me.m_OBJECT_SIGN_INFO) Or Me.m_Ubound_idx_SignInfo=-1 Then
            Set items=Nothing                                     
        Else
            items=Me.m_OBJECT_SIGN_INFO            
        End If                
    End Property

    Public Property Get GetHash As String  'получение отпечатка серта пользователя
        If Me.m_isError Then Call NULL_Error
        GetHash = Me.m_hash
    End Property    
    
    Public Property Get GetServ_time_stamp  As String  'получение адреса сервера штампа времени
        If Me.m_isError Then Call NULL_Error
        GetServ_time_stamp = Me.m_serv_time_stamp
    End Property

    Public Property Get GetDir_Source  As String  'получение пути к папке источника файлов для подписи
        If Me.m_isError Then Call NULL_Error
        GetDir_Source = Me.m_Dir_Source
    End Property

    Public Property Get GetDir_Result  As String  'получение пути к папке подписанных файлов
        If Me.m_isError Then Call NULL_Error
        GetDir_Result = Me.m_Dir_Result
    End Property

    Public Sub SetIsVerify(ByVal st As Boolean) 'устанавливаем инициировать проверку сразу или нет
        If Me.m_isError Then Call NULL_Error
        Me.m_IsVerify=st
    End Sub    
    
    Public Sub SetHash(ByVal st As String) 'передаем отпечаток серта
        If Me.m_isError Then Call NULL_Error
        Me.m_hash=Trim(st)
    End Sub    
    
    Public Sub SetServ_time_stamp(ByVal st As String)'передаем адрес сервера штампа времени
        If Me.m_isError Then Call NULL_Error
        Me.m_Serv_time_stamp=Trim(st)
    End Sub
    
    Public Function SetDir_Source(ByVal st As String) As Boolean 'передаем путь к каталогу источнику
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        Dim  mes As String
        SetDir_Source=True
        If Not path(st) Then Error 1007 '!"Ошибка проверки либо создания каталога для файлов источников!" '!
        Me.m_Dir_Source=Trim(st)
        Exit Function
ErrH:
        SetDir_Source=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function

    Public Function SetDir_Result(ByVal st As String) As Boolean'передаем путь к каталогу результату
        On Error GoTo ErrH    
        If Me.m_isError Then Call NULL_Error
        Dim  mes As String
        SetDir_Result=True
        If Not path(st) Then Error 1008 '!"Ошибка проверки либо создания каталога для подписанных файлов!"
        Me.m_Dir_Result=Trim(st)
        Exit Function
ErrH:        
        SetDir_Result=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function
    
    Public 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
        
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        SetAllArg=True
        Dim  mes As String
        
        Me.m_path_criptoGSS=Trim(Path_criptoGSS)
        Me.m_hash=Trim(Hash)
        Me.m_Serv_time_stamp=Trim(Serv_time_stamp)
        Me.m_Format_ades=Trim(Format_ades)
        If Not path(Trim(Dir_Source)) Then Error 1007 '!"Ошибка проверки либо создания каталога для файлов источников!" '!
        Me.m_Dir_Source=Trim(Dir_Source)
        If Not path(Trim(Dir_Result)) Then Error 1008  '!"Ошибка проверки либо создания каталога для подписанных файлов!"
        Me.m_Dir_Result=Trim(Dir_Result)
        Exit Function
ErrH:
        SetAllArg=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function

    Public Function AddItem(ByVal source As String, ByVal  result As String, ByVal about As String, additional As Variant) As Boolean
        'добавляем информацию о подписываем файле и файле результате
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        Dim record As New SignInfoArray, mes As String
        AddItem=True
        source=Trim(source)
        result=Trim(result)
        If source="" Or result="" Then Error 1024'"Ошибка добавления записи о файле!"
        record.file_name_source=source
        record.file_name_result=result
        record.about=about
        If IsObject(additional) Then
            Set record.additional=additional
        Else
            record.additional=additional
        End If
        Me.m_Ubound_idx_SignInfo=Me.m_Ubound_idx_SignInfo+1
        If Not IsArray(me.m_OBJECT_SIGN_INFO) Then
            ReDim me.m_OBJECT_SIGN_INFO(0)
        Else
            ReDim Preserve me.m_OBJECT_SIGN_INFO(Me.m_Ubound_idx_SignInfo)
        End If        
        Set me.m_OBJECT_SIGN_INFO(Me.m_Ubound_idx_SignInfo)=record
        Exit Function
errh:        
        AddItem=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function
    
    Public Function ReplaceAllItemValue(ByVal idx As Integer, ByVal source As String, ByVal result As String, ByVal about As String, additional As Variant) As Boolean
        'редактируем указанную запись о файлах
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        ReplaceAllItemValue=True
        Dim i As Integer, tmp As Variant, mes As String
        source=Trim(source)
        result=Trim(result)            
        If source="" Or result="" Then Error 1024'"Ошибка добавления записи о файле!"
        If Not IsArray(Me.m_OBJECT_SIGN_INFO) Or Me.m_Ubound_idx_SignInfo=-1 Then Error 1022 '!нет у нас пока еще массива 
        If Not (idx>=0 And idx<=Me.m_Ubound_idx_SignInfo) Then Error 1020'!индекс не входит в диаппазон
                
        Me.m_OBJECT_SIGN_INFO(idx).file_name_source=source
        Me.m_OBJECT_SIGN_INFO(idx).file_name_result=result
        Me.m_OBJECT_SIGN_INFO(idx).about=about
        
        If IsObject(additional) Then
            Set Me.m_OBJECT_SIGN_INFO(idx).additional=additional
        Else
            Me.m_OBJECT_SIGN_INFO(idx).additional=additional
        End If    
        Exit Function        
errh:
        ReplaceAllItemValue=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function                
    End Function

    Public Function ReplaceItemValue(idx As Integer, ItemName As String, ItemValue As Variant) As Boolean
        'редактируем в указанной записи указанное значение
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        ReplaceItemValue=True
        Const itemNames="file_name_source,file_name_result,about,additional"
        Dim i As Integer, tmp As Variant, mes As String
        tmp=Split(itemNames,",")
        If IsNull(ArrayGetIndex(tmp, LCase(ItemName))) Then Error 1023 '!неверное имя                
        If Not IsArray(Me.m_OBJECT_SIGN_INFO) Or Me.m_Ubound_idx_SignInfo=-1  Then Error 1022 '!нет у нас пока еще массива 
        If Not (idx>=0 And idx<=Me.m_Ubound_idx_SignInfo) Then Error 1020'!индекс не входит в диаппазон
        
        Select Case ItemName
            Case "file_name_source":
                ItemValue=Trim(ItemValue)
                If ItemValue="" Then Error 1024'"Ошибка добавления записи о файле!"         
                Me.m_OBJECT_SIGN_INFO(idx).file_name_source=ItemValue
                
            Case "file_name_result":         
                ItemValue=Trim(ItemValue)
                If ItemValue="" Then Error 1024'"Ошибка добавления записи о файле!"
                Me.m_OBJECT_SIGN_INFO(idx).file_name_result=ItemValue
                
            Case "about":                     
                Me.m_OBJECT_SIGN_INFO(idx).about=ItemValue
                
            Case "additional":
                If IsObject(ItemValue) Then
                    Set Me.m_OBJECT_SIGN_INFO(idx).additional=ItemValue
                Else
                    Me.m_OBJECT_SIGN_INFO(idx).additional=ItemValue
                End If
        End Select        
        Exit Function        
errh:
        ReplaceItemValue=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function        
    End Function
    
    Public Function DelItem(idx As Integer) As Boolean'удаляем запись о файле        
        On Error GoTo ErrH    
        If Me.m_isError Then Call NULL_Error    
        Dim i As Integer, mes As String
        DelItem=True
        If Not IsArray(Me.m_OBJECT_SIGN_INFO) Or Me.m_Ubound_idx_SignInfo=-1  Then Error 1021 '!Нет данных для удаления! 
        If Not (idx>=0 And idx<=Me.m_Ubound_idx_SignInfo) Then Error 1020'!индекс не входит в диаппазон

        If Me.m_Ubound_idx_SignInfo=0 Then
            Erase Me.m_OBJECT_SIGN_INFO
            Me.m_Ubound_idx_SignInfo=-1
        Else
            For i=idx To Me.m_Ubound_idx_SignInfo-1                        
                Set me.m_OBJECT_SIGN_INFO(idx)=me.m_OBJECT_SIGN_INFO(idx+1)                                                                        
            Next                        
            Me.m_Ubound_idx_SignInfo=Me.m_Ubound_idx_SignInfo-1
            ReDim Preserve me.m_OBJECT_SIGN_INFO(Me.m_Ubound_idx_SignInfo)            
        End If
        Exit Function        
errh:
        DelItem=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function
    
    Public Function check As Boolean'проверяем на корректность всех переданных установок для подписания
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        Const c_format_ades="Xades,Cades"
        Dim mas1 As Variant, mes As String
        
        check=True    
                
        If Trim(Me.m_Format_ades)="" Then
            Error 1000 'не указан или не верный формат подписи
        Else
            mas1=Split(c_format_ades,",")
            If IsNull(ArrayGetIndex(mas1, Trim(me.m_format_ades))) Then Error 1000 '!не указан или не верный формат подписи
        End If
        
        If Me.m_Ubound_idx_SignInfo=-1 Then Error 1001 '!не заполнена информация о файлах для подписи 

        ForAll v In Me.m_OBJECT_SIGN_INFO
            If v.file_name_source="" Or v.file_name_result="" Then Error 1002 '!не заполнена или не полностью заполнена информация о файлах для подписи         
        End ForAll
        
        If Trim(me.m_path_criptoGSS)="" Then Error 1003 '!не указан путь к консольнойкриптогсс
        If Trim(me.m_hash)=""             Then Error 1004 '!не указан hash сертификата
        If Trim(me.m_Dir_Source)=""     Then Error 1005 '!не указан путь к папке источника
        If Trim(me.m_Dir_Result)=""     Then Error 1006 '!не указан путь к папке результата                
        Exit Function        
ErrH:        
        check=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function    
'РАЗДЕЛ Public КОНЕЦ ***********************************************************
    
    Private Function SetGoodAllSign() As Boolean
        On Error GoTo ErrH
        SetGoodAllSign=True
        Dim i As Integer
        For i=0 To me.m_Ubound_idx_SignInfo
            me.m_OBJECT_SIGN_INFO(i).IsSign=True            
        Next        
        Exit Function
ErrH:
        SetGoodAllSign=False 'не надо вызывать ф-цию для ошибок(вызовется из другого места)
        Exit Function
    End Function
    
    Private Function SetSignNULL() As Boolean
        On Error GoTo ErrH
        SetSignNULL=True
        Dim i As Integer
        For i=0 To me.m_Ubound_idx_SignInfo
            me.m_OBJECT_SIGN_INFO(i).IsSign=False
            me.m_OBJECT_SIGN_INFO(i).ErrTextSign=""
            me.m_OBJECT_SIGN_INFO(i).IsVerify=False
            me.m_OBJECT_SIGN_INFO(i).ErrTextVerify=""
        Next        
        Exit Function
ErrH:
        SetSignNULL=False 'не надо вызывать ф-цию для ошибок(вызовется из другого места)
        Exit Function
    End Function
    
    Private Function GetFileNameInStr(source As String, result As String) As Boolean
        On Error GoTo ErrH
        GetFileNameInStr=True
        source=""
        result=""
        ForAll v In me.m_OBJECT_SIGN_INFO
            If source="" Then source={"}+me.m_Dir_Source & v.file_name_source+{"}    Else source=source & "," & {"}+me.m_Dir_Source & v.file_name_source+{"}
            If result="" Then result={"}+me.m_Dir_Result & v.file_name_result+{"}    Else result=result & "," & {"}+me.m_Dir_Result & v.file_name_result+{"}                
        End ForAll
        
        Exit Function
ErrH:
        GetFileNameInStr=False 'не надо вызывать ф-цию для ошибок(вызовется из другого места)
        Exit Function
    End Function
    
    Private Function path(st As String) As Boolean
        On Error GoTo ErrH
        path=True
        Dim tmp As String*1
        tmp="\"
        st=Trim(st)        
        If Right(st,1)="\" Then    st=Left(st, Len(st)-1)
        If  Dir$ (st,16 )="" Then MkDir st    
        st=st+tmp
        Exit Function
ErrH:
        path=False  'НЕ надо вызывать SetError, вызывается в другом месте
        Exit Function        
    End Function    
    

    
    Private Sub GetListError 'заполняем лист данных пользовательскими ошибками
        'диаппазон пользовательских ошибок 1000-1999    
'        %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")="Не могу установить успешное подписание!"'!
        
        'Call SetError(Err, mes)'номера ошибок соотв. списку
'        %END REM                
    End Sub
    
End Class
%REM
    Class Verify_CriptoGSS
    Description: Класс для проверки подписи

==================================КРАТКОЕ ОПИСАНИЕ Public методов и свойств класса Verify_CriptoGSS============================================
*Наследованы от Base_Class:
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                        'устанавливаем путь к консольной криптогсс    
    Sub SetFormat_ades                            'устанавливаем формат подписи (Xades / Cades / All)

*Объявлены в текущем классе (Sign_CriptoGSS)
    Property Get CountListSertInDoc    As Integer  'получаем кол-во сертов на ПК
    Property Get GetListSertInDoc     As Variant    'получение записей о сертификатах которыми подписан документ(массив класса InfoSignSertificate)
    Property Get GetFullPath_File      As String      'получение пути к проверяемому файлу
    Function check                     As Boolean     'проверяем на корректность всех переданных установок для проверки
    Function SetAllArg                As Boolean    'устанавливаем все необходимые настройки
    Function verify                 As Boolean    'проверяем    
    Sub SetFullPath_File                        'указываем какой файл нужно проверять
    


=====================================ПОЛНОЕ ОПИСАНИЕ Public методов и свойств класса Verify_CriptoGSS============================================
*Наследованы от Base_Class: 
    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" или "All"
    
*Объявлены в текущем классе (Verify_CriptoGSS)    
Public    
    Property Get CountListSertInDoc As Integer  'получаем кол-во сертов на ПК
    Property Get GetListSertInDoc     As Variant    'получение записей о сертификатах которыми подписан документ(массив класса InfoSignSertificate)
    Property Get GetFullPath_File      As String      'получение пути к проверяемому файлу
    
    Function check                     As Boolean    'проверяем на корректность всех переданных установок для проверки    
        где: возвращаемое значение True -все норм, False - не все указано корректно
    
    Function SetAllArg(_                        'устанавливаем все необходимые настройки
            ByVal Path_criptoGSS As String, ByVal Format_ades As String, ByVal FullPath_File As String) As Boolean
        где: Path_criptoGSS - путь к программе, например "c:\consolecriptogss\consolecriptogss.exe"
             Format_ades - значение для подписи может быть "Xades" или "Cades" или "All"
             FullPath_File - указываем какой файл нужно проверять
             
    Function verify                 As Boolean    'проверяем    
        где: возвращаемое значение True -все норм, False - не все прошло успешно успешно
    
    Sub SetFullPath_File(ByVal st As String)    'указываем какой файл нужно проверять
        где: FullPath_File - указываем какой файл нужно проверять

***ПРИМЕР 1 проверяем файл и получаем информацию о подписях в файле*************************************************    
    Dim verify_class As New Verify_CriptoGSS
    
    If Not  verify_class.SetAllArg( "c:\consolecriptogss\consolecriptogss.exe", "All", "c:\consolecriptogss\2.xml") Then  Messagebox verify_class.GetTextError,16,"Ошибка!!!": Exit Sub
    If verify_class.verify Then 'файл проверен - все норм
        Messagebox "проверен - все гуд"        
    Else
        Messagebox verify_class.GetTextError,16,"Ошибка!!!"        
    End If    
    If verify_class.CountListSertInDoc>0 Then
        For i=0 To verify_class.CountListSertInDoc-1            
            If s<>"" Then s = s + Chr(13)+Chr(13)
            s=s+"Подпись №"+Cstr(i+1)+" :"+Chr(13)
            s=s+"Error="            +    verify_class.GetListSertInDoc(i).eror+Chr(13)            
            s=s+"Warning="            +    verify_class.GetListSertInDoc(i).Warning+Chr(13)
            s=s+"DateCreate="        +    verify_class.GetListSertInDoc(i).DateCreate+Chr(13)
            s=s+"Сертификат:"+Chr(13)
            s=s+"Name="                +    verify_class.GetListSertInDoc(i).Certificate.FIO+Chr(13)
            s=s+"Country="            +    verify_class.GetListSertInDoc(i).Certificate.Country+Chr(13)
            s=s+"Town="                +    verify_class.GetListSertInDoc(i).Certificate.Town+Chr(13)
            s=s+"Address="            +    verify_class.GetListSertInDoc(i).Certificate.Address+Chr(13)
            s=s+"Region="            +    verify_class.GetListSertInDoc(i).Certificate.Region+Chr(13)
            s=s+"Email="            +    verify_class.GetListSertInDoc(i).Certificate.Email+Chr(13)
            s=s+"WorkPlace="        +    verify_class.GetListSertInDoc(i).Certificate.WorkPlace+Chr(13)
            s=s+"WorkDepartment="    +    verify_class.GetListSertInDoc(i).Certificate.WorkDepartment+Chr(13)
            s=s+"WorkPosition="        +    verify_class.GetListSertInDoc(i).Certificate.WorkPosition+Chr(13)
            s=s+"Thumbprint="        +    verify_class.GetListSertInDoc(i).Certificate.Thumbprint+Chr(13)
            s=s+"RootThumbprint="    +    verify_class.GetListSertInDoc(i).Certificate.RootThumbprint+Chr(13)
            s=s+"DateFrom="            +    verify_class.GetListSertInDoc(i).Certificate.DateFrom+Chr(13)
            s=s+"DateTo="            +    verify_class.GetListSertInDoc(i).Certificate.DateTo+Chr(13)
            s=s+"IsValid="            +    Cstr(verify_class.GetListSertInDoc(i).Certificate.IsValid)+Chr(13)
            s=s+"IsSkilled="        +    Cstr(verify_class.GetListSertInDoc(i).Certificate.IsSkilled)+Chr(13)
            s=s+"UIN:"+Chr(13)
            s=s+"UINFL="            +    verify_class.GetListSertInDoc(i).UIN.UINFL+Chr(13)
            s=s+"UINUL="            +    verify_class.GetListSertInDoc(i).UIN.UINUL+Chr(13)
            s=s+"UINOIGV="            +    verify_class.GetListSertInDoc(i).UIN.UINOIGV+Chr(13)            
            s=s+"Штамп времени:"+Chr(13)
            s=s+"DateCreate="        +    verify_class.GetListSertInDoc(i).TimeShtamp.DateCreate+Chr(13)
            s=s+"Name="                +    verify_class.GetListSertInDoc(i).TimeShtamp.NameOffice+Chr(13)
            s=s+"Thumbprint="        +    verify_class.GetListSertInDoc(i).TimeShtamp.Thumbprint            
        Next        
    End If
    Messagebox s
    Print "в доке подписей - " + Cstr(verify_class.CountListSertInDoc)
=================================================================================================
        
%END REM
Public Class Verify_CriptoGSS As Base_Class
    Private m_FullPath_File As String        'путь к файлу для проверки для подписи
    Private m_InfoSign() As InfoSignSertificate        'информация о подписях в документе
    Private m_Ubound_idx_ListSertInDoc As integer        'индекс подписи в документе
    
    Public Sub New        
        Call Me.NULL_Error
        Call Me.GetListErrorBase
        Call Me.GetListError
        
        me.m_path_criptoGSS=""
        me.m_format_ades=""
        me.m_FullPath_File=""
        Me.m_Ubound_idx_ListSertOnPC=-1
        me.m_Ubound_idx_ListSertInDoc=-1
    End Sub
    
    Public Property Get CountListSertInDoc As Integer  'получаем кол-во сертов на ПК
        CountListSertInDoc = Me.m_Ubound_idx_ListSertInDoc+1
    End Property
    
    Public Function check As Boolean
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        Const c_format_ades="Xades,Cades,All"
        Dim mas1 As Variant, mes As String
        
        check=True    
        
        If Trim(Me.m_Format_ades)="" Then
            Error 1100 'не указан или не верный формат подписи
        Else
            mas1=Split(c_format_ades,",")
            If IsNull(ArrayGetIndex(mas1, Trim(me.m_format_ades))) Then Error 1100 '!не указан или не верный формат подписи
        End If

        If Trim(me.m_path_criptoGSS)="" Then Error 1101 '!не указан путь к консольнойкриптогсс
        If Trim(me.m_FullPath_File)=""     Then Error 1102 '!не указан путь к проверяемому файлу            
        Exit Function        
ErrH:        
        check=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function
        
    Public Property Get GetFullPath_File  As String  'получение пути к проверяемому файлу
        If Me.m_isError Then Call NULL_Error
        GetFullPath_File = Me.m_FullPath_File
    End Property
    
    Public Property Get GetListSertInDoc As Variant    'получение записей о сертификатах
        If Me.m_isError Then Call NULL_Error
        If Me.m_Ubound_idx_ListSertInDoc=-1 Then
            Set GetListSertInDoc=Nothing                                     
        Else
            GetListSertInDoc=Me.m_InfoSign            
        End If                
    End Property
    
    Public Function SetAllArg(ByVal Path_criptoGSS As String, ByVal Format_ades As String, ByVal FullPath_File As String) As Boolean        
        On Error GoTo ErrH
        If Me.m_isError Then Call NULL_Error
        SetAllArg=True
        Dim  mes As String
        
        Me.m_path_criptoGSS=Trim(Path_criptoGSS)
        Me.m_Format_ades=Trim(Format_ades)
        Me.m_FullPath_File=Trim(FullPath_File)
        Exit Function
ErrH:
        SetAllArg=False
        Call SetError(Err, mes)'номера ошибок соотв. списку
        Exit Function
    End Function
    
    Public Sub SetFullPath_File(ByVal st As String)
        If Me.m_isError Then Call NULL_Error
        Me.m_FullPath_File=Trim(st)
    End Sub    
    
    Public Function verify As Boolean
        Erase me.m_InfoSign
        me.m_Ubound_idx_ListSertInDoc=-1
        On Error GoTo ErrH
        verify=True
        Print "Проверка подписи НАЧАЛО"
        Dim WShell As Variant, WshExec As Variant, OutStream As Variant
        Dim Cmd As String, str1 As String, iser As Boolean, vPieces1 As variant    
        Dim sJSON As String, jsonReader As JSONReader, vResults As Variant, vPieces As Variant
        Dim i As Byte, mes As String, record As Variant, record_Sert As Variant, record_Time As Variant', record_UIN As Variant
                        
        cmd=Me.m_path_criptoGSS+{ }                'путь к криптоГСС*
        cmd=cmd+{-o Verify }
        cmd=cmd+{-f }+Me.m_format_ades +{ }        'формат подписи *
        cmd=cmd+{-s "}+Me.m_FullPath_File+{"}         'файл который проверяем на подпись
        Print cmd
        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 1140 '(0 - Произошла ошибка вызова программы, 1 - Success)
        
        vPieces=vPieces("OperationResultJson").items
        
        Select Case vPieces("GeneralCode")'GeneralCode - Общий код выполнения операции
            Case 1: 'все успешно проверены
                vPieces=vPieces("DocumentVerifyResultsList").items
                If Not IsArray(vPieces) Then Error 1144        'нет подписей в документе            
'!!!!!!!!!!!!!!!!!!!                'нужно запустить процедуру заполнения объекта инфы о подписях
                iser=false                        
                For i=0 To UBound(vPieces)
                    Set record= New InfoSignSertificate
                    With vPieces(i)
                        If Not IsNull(.GetItemValue("Error")) Then
                            iser=True '"Ошибка в подписи документа"
                            record.eror=.GetItemValue("Error")                        
                        End If 
                        If Not IsNull(.GetItemValue("Warning")) Then record.Warning=.GetItemValue("Warning")    
                        If Not IsNull(.GetItemValue("DateCreate")) Then record.DateCreate=.GetItemValue("DateCreate")
                        
                        Set record_Sert= New Certificate
                        With .GetItemValue("Certificate")
                            If Not IsNull(.GetItemValue("Name"))             Then record_Sert.FIO=.GetItemValue("Name")
                            If Not IsNull(.GetItemValue("Country"))         Then record_Sert.Country=.GetItemValue("Country")
                            If Not IsNull(.GetItemValue("Town"))             Then record_Sert.Town=.GetItemValue("Town")
                            If Not IsNull(.GetItemValue("Address"))         Then record_Sert.Address=.GetItemValue("Address")
                            If Not IsNull(.GetItemValue("Region"))             Then record_Sert.Region=.GetItemValue("Region")
                            If Not IsNull(.GetItemValue("Email"))             Then record_Sert.Email=.GetItemValue("Email")
                            If Not IsNull(.GetItemValue("WorkPlace"))         Then record_Sert.WorkPlace=.GetItemValue("WorkPlace")
                            If Not IsNull(.GetItemValue("WorkDepartment"))     Then record_Sert.WorkDepartment=.GetItemValue("WorkDepartment")
                            If Not IsNull(.GetItemValue("WorkPosition"))     Then record_Sert.WorkPosition=.GetItemValue("WorkPosition")
                            If Not IsNull(.GetItemValue("Thumbprint"))         Then record_Sert.Thumbprint=.GetItemValue("Thumbprint")
                            If Not IsNull(.GetItemValue("RootThumbprint"))     Then record_Sert.RootThumbprint=.GetItemValue("RootThumbprint")
                            If Not IsNull(.GetItemValue("DateFrom"))         Then record_Sert.DateFrom=.GetItemValue("DateFrom")    
                            If Not IsNull(.GetItemValue("DateTo"))             Then record_Sert.DateTo=.GetItemValue("DateTo")
                            If Not IsNull(.GetItemValue("IsValid"))         Then record_Sert.IsValid=(.GetItemValue("IsValid")="True")                
                            If Not IsNull(.GetItemValue("IsSkilled"))         Then record_Sert.IsSkilled=(.GetItemValue("IsSkilled")="True")                            
                        End With
                        With .GetItemValue("UIN")
                            If Not IsNull(.GetItemValue("UINFL"))         Then record_Sert.UINFL=.GetItemValue("UINFL")
                            If Not IsNull(.GetItemValue("UINUL"))         Then record_Sert.UINUL=.GetItemValue("UINUL")
                            If Not IsNull(.GetItemValue("UINOIGV"))     Then record_Sert.UINOIGV=.GetItemValue("UINOIGV")                                                        
                        End With
                        Set record.certificate=record_Sert
                                                                        
                        %REM хотел сделать отдельным блоком, как и криптогсс - передумал, нужно в инфе про серт продолжить список параметров
                        Set record_UIN= New UIN
                        With .GetItemValue("UIN")
                            If Not IsNull(.GetItemValue("UINFL"))         Then record_UIN.UINFL=.GetItemValue("UINFL")
                            If Not IsNull(.GetItemValue("UINUL"))         Then record_UIN.UINUL=.GetItemValue("UINUL")
                            If Not IsNull(.GetItemValue("UINOIGV"))     Then record_UIN.UINOIGV=.GetItemValue("UINOIGV")                                                        
                        End With
                        Set record.UIN=record_UIN                                                        
                        %END REM
                        
                        Set record_Time= New TimeShtamp
                        With .GetItemValue("TimeShtamp")
                            If Not IsNull(.GetItemValue("DateCreate"))         Then record_Time.DateCreate=.GetItemValue("DateCreate")
                            If Not IsNull(.GetItemValue("Name"))             Then record_Time.NameOffice=.GetItemValue("Name")
                            If Not IsNull(.GetItemValue("Thumbprint"))         Then record_Time.Thumbprint=.GetItemValue("Thumbprint")                                                        
                        End With                        
                        Set record.TimeShtamp=record_Time
                    End With            
                    me.m_Ubound_idx_ListSertInDoc=me.m_Ubound_idx_ListSertInDoc+1        
                    ReDim Preserve me.m_InfoSign(me.m_Ubound_idx_ListSertInDoc)
                    Set me.m_InfoSign(me.m_Ubound_idx_ListSertInDoc)=record
                Next
                If iser Then Error 1142 '"Ошибка в подписи документа"
            Case -3:'!не удалось проверить ничего
                mes=vPieces("GeneralText") 
                Error 1141 '
        End Select

ext:
        Set WshExec=Nothing
        Set WShell=Nothing
        Print "Проверка подписи КОНЕЦ"
        Exit Function        
ErrH:
        verify=False
        Select Case Err
            Case 213   : 
                mes=Me.m_path_criptoGSS & " Системная ошибка № " & Err 
                Err=1143                
            Case Else  :            
        End Select        
        
        Call SetError(Err, mes)
        Resume ext
    End Function
        
    Private Sub GetListError 'заполняем лист данных пользовательскими ошибками
        'диаппазон пользовательских ошибок 1000-1999    
        '        %REM
        
        Me.m_error_list("1100")="Не указан или не верный формат подписи!" '!
        Me.m_error_list("1101")="Не указан путь к консольной криптоГСС!" '!
        Me.m_error_list("1102")="Не указан путь к проверяемому файлу!" '!
        
        'ошибки ф-ции проверки verify    
        Me.m_error_list("1140")="Произошла ошибка вызова программы!" '!
        Me.m_error_list("1141")="Не удалось проверить ничего!"'!    ?????            
        Me.m_error_list("1142")="Не все подписи корректны!"'!
        Me.m_error_list("1143")="Ошибка обращения к консольной КриптоГСС!" & _
        Chr(13)& "Возможно не найдена консольная КриптоГСС по пути" & Chr(13)
        Me.m_error_list("1144")="Документ не подписан! В документе нет подписей"'!
        'Call SetError(Err, mes)'номера ошибок соотв. списку
        '        %END REM                
    End Sub
    
End Class
%REM
    Class Certificate - предназначен для объектов с иформацией о сертификатах    
%END REM
Class Certificate
    Public FIO                 As String            
    Public Country             As String        
    Public Town             As String            
    Public Address             As String        
    Public Region             As String
    Public Email             As String
    Public WorkPlace         As String
    Public WorkDepartment     As String
    Public WorkPosition     As String
    Public Thumbprint         As String
    Public RootThumbprint     As String
    Public DateFrom         As String
    Public DateTo             As String
    Public IsValid             As boolean
    Public IsSkilled         As Boolean
    
    Public UINFL             As String
    Public UINUL             As String
    Public UINOIGV             As String
End Class

%REM
    Class InfoSign
    Description: информация о подписях и сертах которыми подписан документ
%END REM
Class InfoSignSertificate
    Public DateCreate As String
    Public Eror As String
    Public Warning As String
    Public Certificate As Certificate
    'Public UIN As UIN
    Public TimeShtamp As TimeShtamp    
End Class

%REM
    Class TimeShtamp
    Description: Comments for Class
%END REM
Class TimeShtamp
    Public DateCreate As String
    Public NameOffice As String
    Public Thumbprint As String    
End Class

Поделиться

6

Re: Лотус скрипты для работы с XML

Библиотека MED_XML

%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

Поделиться

7

Re: Лотус скрипты для работы с XML

Продолжение

%REM
    Sub ImportToWord_OLD
    Description: импорт в ворд, работаем по старому механизсу
%END REM
Sub ImportToWord_OLD
    On Error GoTo ErrH
    Dim Session As New NotesSession, uiworkspace As New NotesUIWorkspace
    Dim WordApp As Variant, worddoc As Variant, textob As Variant, fio As Variant, i As byte
    Dim rtitemA As NotesRichTextItem, obj As Variant, oname As String, myText As String, myText1 As String
    
    Set rtitemA = L_doc.GetFirstItem("text")    
    
    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    

    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    myText=UIDoc.FieldGetText("adresed")
    'BEGINкасаемо нового функционала по выбору дресатов
    If L_doc.HasItem("adresed_hand") Then
        myText1=UIDoc.FieldGetText("adresed_hand")                        
        If Trim(myText)<>"" And Trim(myText1)<>""Then    myText=myText+Chr(13)+Chr(13)+myText1
        If Trim(myText)="" And Trim(myText1)<>""Then    myText=myText1                        
    End If
    'ENDкасаемо нового функционала по выбору дресатов
    worddoc.Application.Selection.TypeText(myText) ' Адресат
    
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    myText=UIDoc.FieldGetText("header")
    worddoc.Application.Selection.TypeText(myText) ' Заголовок
    
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    If  worddoc.Tables.Item(3).Tables.Count>0 Then 'проверяем если новый шаблон, т.е. есть таблица где подпись руководителя
        worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    End If
    Set textob = worddoc.Application.Selection.Find ' раздел исполнителя в ворд файле
    
    textob.Text = "Фамилия"
    textob.Execute ,,,,,,,,, wdReplaceAll
    myText=UIDoc.FieldGetText("isp") 
    fio=Split(myText, " ")
    i=0
    ForAll v In fio
        If i=0 Then myText = fio(i) Else    myText =myText +" "+ Left$(fio(i),1)+ ". "
        i=i+1
    End ForAll
    
    worddoc.Application.Selection.TypeText(myText)
    
    textob.Text = "Телефон"
    textob.Execute ,,,,,,,,, wdReplaceAll
    myText=UIDoc.FieldGetText("phone") 
    worddoc.Application.Selection.TypeText(Chr(13)+myText)
    
    worddoc.Close
    WordApp.Quit
    Set worddoc=Nothing
    Set WordApp=Nothing                    
    Print "WordApp.Quit"
    Sleep 1
    
    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    "Данные из карточки документа были добавлены в письмо!"            
    
    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_OLD'. Ошибка импорта в ворд " & Error(Err) & " в строке " & Erl    
    Exit Sub
End Sub
Function R(sour As String)As String
    Dim ar1(4) As String, ar2(4) As String
    ar1(0)={&}
    ar1(1)={>}
    ar1(2)={<}
    ar1(3)={}  
    ar1(4)={}  
    ar2(0)={&amp;}
    ar2(1)={&gt;}
    ar2(2)={&lt;}
    ar2(3)={ }
    ar2(4)={ }
    R=Replace(FullTrim(sour),ar1,ar2)
End Function

Function Textword (myRange) As string
' сохраняем word в html файл
    'добавлен кусок кода на случай если контент в ворд вставляют вместе с таблицей - в v.1.1изменен на универсальный код
    'подправлен кусок кода где контент мог начинаться как с абзаца, так и с таблицы, так и с заголовка (<h1>)
'т.е. сделан универсальный код для избавления от внешней таблицы текста сопроводиловки
    On Error GoTo ErrH   
    Dim str1 As String, str2 As String
    Dim sText As String, mytext As String, str0 As String, str3 As String
    Dim htmlStream As NotesStream, session As NotesSession, idx As Long
    Dim mypar  As Variant, myRangeTmp As Variant, WrdAppTmp As Variant, WrdDocTmp  As Variant  ' временый док
    
    Print "ФУНКЦИЯ Textword"
    
    myRange.Copy
    
    ' Во временный Word документ вставляем текст письма (myRange), cохраняем как doctmp.html
    
    Set WrdAppTmp = CreateObject("Word.Application") 'Создание объекта Word'a
    WrdAppTmp.Visible= False 'True  
    Print "создали временный ворд WrdAppTmp"
    If WrdAppTmp Is Nothing Then  MessageBox "Не установлен Word!!!", 0 + 16 , "ошибка" : Exit Function

    WrdAppTmp.Documents.Add ("Normal")   '("C:\XML\tempdoc.docx")
    Set WrdDocTmp = WrdAppTmp.ActiveDocument
    WrdDocTmp.Select
    
    Set mypar = WrdDocTmp.Paragraphs(1)
    mypar.range.Find.ClearFormatting
    mypar.range.Paste
    
    WrdAppTmp.ChangeFileOpenDirectory datpatch
    Call WrdDocTmp.SaveAs  ("doctmp.html", 10,False, "",False,"",,,,,,,,,, )
    WrdDocTmp.Close
    WrdAppTmp.Quit
    Set WrdAppTmp = Nothing
    Print  "сохранили в html"
    
    ' Вырезаем с doctmp.html текст письма
    Set session = New NotesSession
    Set htmlStream = session.CreateStream
    Call htmlStream.Open(datpatch+"doctmp.html")
    mytext$=""
    mytext$ = htmlStream.ReadText
    Call htmlStream.Close
    Print "прочитали и закрыли html"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!    
    'здесь нужно почистить тест дока от внешней таблицы
%REM может быть что текст вставили с таблицей и получилась вложенная таблица
    1начало файла
<table class=MsoTableGrid border=0 cellspacing=0 cellpadding=0
 style='border-collapse:collapse;border:none'>
     <tr>
      <td width=657 valign=top style='width:492.7pt;padding:0cm 5.4pt 0cm 5.4pt'>
        <table class=MsoTableGrid border=0 cellspacing=0 cellpadding=0
         style='border-collapse:collapse;border:none'>
         <tr>
          <td width=657 valign=top style='width:492.7pt;padding:0cm 5.4pt 0cm 5.4pt'>
          <p
            2сам текст документа
          </td>
         </tr>
        </table>
      </td>
    </tr>
</table>
3конец файла
%END REM
    str1=StrLeft(mytext$,"<table") 'взяли начало файла до таблицы (начало файла)
        
    'стало в версии 1.1(заменили алгоритм получения str2)    
'НАЧАЛО ПОЛУЧЕНИЯ str2
    idx=InStr(Len(str1+"<table"),mytext$,"<td")
    idx=InStr(idx,mytext$,">")
    str0=Mid$(mytext$, idx+1)
    str2=StrLeftBack(str0,"</td>") 'взяли все что до последней строки внешней ячейки
'КОНЕЦ ПОЛУЧЕНИЯ str2    
    str3=StrRightBack(mytext$,"</table>") 'взяли все что после последней строки внешней ячейки (конец файла)
    mytext$=str1+str2+str3
        
    Textword=ParsHtmlText(mytext$)    
    Print "ФУНКЦИЯ - конец Textword."
    Exit Function
    
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'Textword'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function
%REM
    Function Strclean22
    Description: Comments for Function
%END REM
Function Strclean22 (mystr As String) As String
    On Error GoTo ErrH
    Dim ascx As String, tmpstr  As String, lenstr As Variant, x As Variant
    tmpstr= ""
    'Strclean22=mystr
    'Exit function
    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
    'Strclean22=mystr
    'Exit function
    'MsgBox tmpstr    
    '%END REM
    
    'HTML символы заменяем (появляются после сохрания в html)   http://_.ascii.cl/htmlcodes.htm
    
    
    '%REM
    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>},"") 
    '%END REM
    'Msgbox tmpstr
    Strclean22  =    tmpstr
    

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

Поделиться

8

Re: Лотус скрипты для работы с XML

%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

Поделиться

9

Re: Лотус скрипты для работы с XML

%REM
    Function Getstructuralsubdivision
    Description: Comments for Function
%END REM
Function GetStructuralSubDivision(idx As Variant) As String
    Dim mas As Variant
    GetStructuralSubDivision=""   
    If L_doc.Hasitem("Server_id_Resp") Then
        mas=Split(L_doc.Server_id_Resp(idx),".")
        ForAll v In mas
            If CInt(v)>=500 Then
                If GetStructuralSubDivision="" Then GetStructuralSubDivision=CStr(v) Else GetStructuralSubDivision=GetStructuralSubDivision+"."+CStr(v)
            End If
        End ForAll       
    End If   
End Function

Поделиться

10

Re: Лотус скрипты для работы с XML

%REM
    Function GetTemplSett
    Description: опеределяем будем с настройками шаблна работать или нет и получаем документ шаблона
%END REM
Function GetTemplSett(mes As String, b_templ As Boolean) As Boolean
    On Error GoTo errh
    Dim view_templ As NotesView, i As integer
    GetTemplSett=True
    b_templ=false
    If L_doc.HasItem("id_template") Then b_templ=L_doc.id_template(0)<>""
   
    If b_templ Then'берем с настроек шаблона
        Set view_templ=L_db.GetView("templates_All")
        If view_templ Is Nothing Then      mes="Нет доступа к представлению с шаблонными документами!" : Error 1000
        Set doc_templ=view_templ.GetFirstDocument
        i=0
        Do While Not doc_templ Is Nothing
            If doc_templ.id(0)=L_doc.id_template(0) Then    i=1 : Exit Do           
            Set doc_templ=view_templ.GetNextDocument(doc_templ)
        Loop
        If i=0 Then  mes="Нет доступа к настройкам выбранного шаблона!" :  Error 1000
    End If
ext:
    Exit Function

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

Поделиться

11

Re: Лотус скрипты для работы с XML

%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

Поделиться

12

Re: Лотус скрипты для работы с XML

%REM
    Sub ImportToWord_OLD
    Description: импорт в ворд, работаем по старому механизсу
%END REM
Sub ImportToWord_OLD
    On Error GoTo ErrH
    Dim Session As New NotesSession, uiworkspace As New NotesUIWorkspace
    Dim WordApp As Variant, worddoc As Variant, textob As Variant, fio As Variant, i As byte
    Dim rtitemA As NotesRichTextItem, obj As Variant, oname As String, myText As String, myText1 As String
   
    Set rtitemA = L_doc.GetFirstItem("text")   
   
    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   

    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    myText=UIDoc.FieldGetText("adresed")
    'BEGINкасаемо нового функционала по выбору дресатов
    If L_doc.HasItem("adresed_hand") Then
        myText1=UIDoc.FieldGetText("adresed_hand")                       
        If Trim(myText)<>"" And Trim(myText1)<>""Then    myText=myText+Chr(13)+Chr(13)+myText1
        If Trim(myText)="" And Trim(myText1)<>""Then    myText=myText1                       
    End If
    'ENDкасаемо нового функционала по выбору дресатов
    worddoc.Application.Selection.TypeText(myText) ' Адресат
   
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    myText=UIDoc.FieldGetText("header")
    worddoc.Application.Selection.TypeText(myText) ' Заголовок
   
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    If  worddoc.Tables.Item(3).Tables.Count>0 Then 'проверяем если новый шаблон, т.е. есть таблица где подпись руководителя
        worddoc.Application.Selection.GoToEditableRange (wdEditorEveryone)
    End If
    Set textob = worddoc.Application.Selection.Find ' раздел исполнителя в ворд файле
   
    textob.Text = "Фамилия"
    textob.Execute ,,,,,,,,, wdReplaceAll
    myText=UIDoc.FieldGetText("isp")
    fio=Split(myText, " ")
    i=0
    ForAll v In fio
        If i=0 Then myText = fio(i) Else    myText =myText +" "+ Left$(fio(i),1)+ ". "
        i=i+1
    End ForAll
   
    worddoc.Application.Selection.TypeText(myText)
   
    textob.Text = "Телефон"
    textob.Execute ,,,,,,,,, wdReplaceAll
    myText=UIDoc.FieldGetText("phone")
    worddoc.Application.Selection.TypeText(Chr(13)+myText)
   
    worddoc.Close
    WordApp.Quit
    Set worddoc=Nothing
    Set WordApp=Nothing                   
    Print "WordApp.Quit"
    Sleep 1
   
    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    "Данные из карточки документа были добавлены в письмо!"           
   
    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_OLD'. Ошибка импорта в ворд " & Error(Err) & " в строке " & Erl   
    Exit Sub
End Sub

Поделиться

13

Re: Лотус скрипты для работы с XML

%REM
    Function ParsHtmlText
    Description: Comments for Function
8.10.2021 <pre> была замена на <p> изменил на пустоту(НЕЛЬЗЯ МЕНЯТЬ НА ПУСТОТУ!!!! КОСЯКИ ВЫЛАЗЯТ, теряются абзацы)
    ф-ция обновлена 1,11,2021
22.03.2022 - замена строк
    с 'mytext$ = StrRight (mytext$,"<body lang=RU" )
    на mytext$ = StrRight (mytext$,"<body lang=" )
    данная замена связана с тем, что когда у ворда установлен по умолчанию англйский язык то будет <body lang=EN-US>
    если русский - <body lang=RU>
%END REM
Function ParsHtmlText(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$,"<body lang=" )
    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 ={[^href=(.*?)](title=(.*?)>)}  ' 2022 Боря, удаление title внутри href
    mytext$= objRegExp.Replace(mytext$, ">")    
    
    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 ={<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=}
    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\n{0,1}\s{1,9}name=(.*?)>| '   <a     name=dst100639> , \n - перевод строки, \s - пробел
    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"})
    'ВРЕМЕННАЯ МЕРА    

    'objRegExp.Pattern =|<p> {0,10}</p>| ' найти все <p></p>1.11.2021 перенес вниз
    'mytext$= objRegExp.Replace(mytext$, "<blok></blok>")    
    
    'mytext$=  Replace(mytext$,{border="0"},{border="1"})  '  кривой вариант...
    objRegExp.Pattern ={<h([0-9])>}
    mytext$ = objRegExp.Replace(mytext$, {<p>})    
    
    'objRegExp.Pattern =|<h([0-9]) {1}>|
    'mytext$ = objRegExp.Replace(mytext$, {<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 ={</h([0-9])>}
    mytext$ = objRegExp.Replace(mytext$, {</p>})
    %REM
    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>")            
    %END REM    
    
    objRegExp.Pattern =|<pre {0,10}>|
    mytext$= objRegExp.Replace(mytext$, "<p>")
    mytext$=  Replace(mytext$,"</pre>","</p>")
    
    objRegExp.Pattern =|<p> {0,10}</p>| ' найти все <p></p>1.11.2021
    mytext$= objRegExp.Replace(mytext$, "<blok></blok>")    
    
    mytext$=  Replace(mytext$,"uml;","¨")   '  &uml;  - две точки нд буквой в немецком
    
    mytext$   =  Strclean (mytext$)   ' для корректной подписи в криптопровайдере. Парсятся ненужные спецсимволы.
    'mytext$   =  Strclean22 (mytext$)
    ParsHtmlText=mytext$
    
    Exit Function
    
ErrH:    
    Print "Библиотека 'MED_XML' ф-ция 'ParsHtmlText'. Ошибка " & Error(Err) & " в строке " & Erl    
End Function

Поделиться

14

Re: Лотус скрипты для работы с XML

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

Поделиться

15

Re: Лотус скрипты для работы с XML

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

Поделиться

16

Re: Лотус скрипты для работы с XML

%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

Поделиться

17

Re: Лотус скрипты для работы с XML

%REM
    Function proverka_import
    Description: Comments for Function
%END REM
Function Proverka_import(mes As String, b_templ As Boolean) As Boolean
    On Error GoTo errh
    Proverka_import=true
    If Not L_doc.HasEmbedded Then mes="Нет вложения Письмо.docx. Используйте Шаблоны -> Письмо." : Error 1000
       
    If Not GetTemplSett(mes, b_templ) Then Error 1000
ext:
    Exit Function

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

Поделиться

18

Re: Лотус скрипты для работы с XML

Function R(sour As String)As String
    Dim ar1(4) As String, ar2(4) As String
    ar1(0)={&}
    ar1(1)={>}
    ar1(2)={<}
    ar1(3)={} 
    ar1(4)={ } 
    ar2(0)={&amp;}
    ar2(1)={&gt;}
    ar2(2)={&lt;}
    ar2(3)={ }
    ar2(4)={ }
    R=Replace(FullTrim(sour),ar1,ar2)
End Function

Поделиться

19

Re: Лотус скрипты для работы с XML

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:
    ' [url]https://ru.wikipedia.org/wiki/Список_MIME-типов[/url]      -   подсказка
    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

Поделиться

20

Re: Лотус скрипты для работы с XML

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

Поделиться

21

Re: Лотус скрипты для работы с XML

%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

Поделиться

22

Re: Лотус скрипты для работы с XML

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

Поделиться

23

Re: Лотус скрипты для работы с XML

%REM
    Sub RunImportToWord
    Description: точка входа импорта в ворд   
%END REM
Sub RunImportToWord
    Print "Старт - экспорт с данных лотус дока в ворд файл"
    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, "Внимание",    "Импортировать в письмо данные из текущего документа?") <> 1 Then Exit Sub

    Call uidoc.save     
    Set L_doc = uidoc.Document   
   
    If Not proverka_import(tmp_tmp, b_templ) Then  MessageBox tmp_tmp : Exit Sub ' - ---   ПРОПУСКНАЯ СИСТЕМА
   
    L_docpatch = Environ$("TEMP") + "\" ' путь во временную папку
   
    'b_templ=false
    Select Case b_templ
        Case True:     Call ImportToWord         'используем настройки из документа шаблона
        Case False: Call ImportToWord_OLD    'работаем по старой схеме
    End Select
    Exit Sub
   
ErrH:
    Print "Библиотека 'MED_XML' ф-ция 'RunImportToWord'. Ошибка импорта в Word " & Error(Err) & " в строке " & Erl   
    Exit Sub
End Sub

Поделиться

24

Re: Лотус скрипты для работы с XML

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

Поделиться

25

Re: Лотус скрипты для работы с XML

%REM
    Function Strclean22
    Description: Comments for Function
%END REM
Function Strclean22 (mystr As String) As String
    On Error GoTo ErrH
    Dim ascx As String, tmpstr  As String, lenstr As Variant, x As Variant
    tmpstr= ""
    'Strclean22=mystr
    'Exit function
    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
    'Strclean22=mystr
    'Exit function
    'MsgBox tmpstr    
    '%END REM
    
    'HTML символы заменяем (появляются после сохрания в html)   [url]http://_.ascii.cl/htmlcodes.htm[/url]
    
    
    '%REM
    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>},"") 
    '%END REM
    'Msgbox tmpstr
    Strclean22  =    tmpstr
    

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

Поделиться