26

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

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

Поделиться

27

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

Function Unique As String
    Dim unik
    unik = Evaluate("@Unique")
    Unique = StrToken(unik(0), "-", -1)
    Unique  = Right (Unique, 3 )
End Function

Поделиться

28

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

%REM
    Sub ZapolnTypeFiles
    Description: указываем разрешенные типы файлов
    ' [url]https://ru.wikipedia.org/wiki/Список_MIME-типов[/url]      -   подсказка
    ' [url]https://wp-kama.ru/id_8643/spisok-rasshirenij-fajlov-i-ih-mime-tipov.html[/url]    - тут поболее типов
%END REM
Sub ZapolnTypeFiles
    c_files_MIME("docx")    =    {href="data:application/msword;base64,}
    c_files_MIME("doc")        =    {href="data:application/msword;base64,}
    c_files_MIME("docm")    =    {href="data:application/msword;base64,}
    c_files_MIME("rtf")        =    {href="data:application/msword;base64,}
    c_files_MIME("jpeg")    =    {href="data:image/jpeg;base64,}
    c_files_MIME("jpg")        =    {href="data:image/jpeg;base64,}
    c_files_MIME("pdf")        =    {href="data:application/pdf;base64,}
    c_files_MIME("xls")        =    {href="data:application/vnd.ms-excel;base64,}
    c_files_MIME("xlsx")    =    {href="data:application/vnd.ms-excel;base64,}
    c_files_MIME("tif")        =    {href="data:image/tif;base64,}
    c_files_MIME("xml")        =    {href="data:application/xml;base64,}
    c_files_MIME("rar")        =    {href="data:application/x-rar-compressed;base64,}
    c_files_MIME("zip")        =    {href="data:application/zip;base64,}
    c_files_MIME("txt")        =    {href="data:text/plain;base64,}    
    c_files_MIME("ppt")        =    {href="data:application/vnd.ms-powerpoint;base64,}
    c_files_MIME("pptx")    =    {href="data:application/vnd.ms-powerpoint;base64,}
    c_files_MIME("vsd")        =    {href="data:application/vnd.visio;base64,}
    c_files_MIME("vsdx")    =    {href="data:application/vnd.visio2013;base64,}
End Sub

Поделиться

29

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

Библиотека Library VerifySignedXML

%REM
    Library VerifySignedXML
    Created Aug 18, 2021 by Гроза Вадим Иванович/Home
    Description:Библиотека для проверки подписи в документе XML и сравнение подписей с базой подписанты   

для работы данной библиотеки необходимо наличие других библиотек
"ConsoleCriptoGSS_2.0"   
"ls.snapps.JSONReader"

для проверки - используем класс Verify_Signed_XML
%END REM
Option Public
Option Declare

Use "ConsoleCriptoGSS_2.0"

Поделиться

30

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

Declare Function w32_OSGetSystemTempDirectory Lib "nnotes" Alias "OSGetSystemTempDirectory" ( ByVal S As String) As Integer
Const db_title="Подписанты"

Поделиться

31

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

%REM
    Class Lico
    Description: используется в классах Podpisant и Verify_Signed_XML
%END REM
Class Lico
    Public FIO As String
    Public UINFL As String
    Public UINUL As String
    Public UINOIGV As String
End Class

Поделиться

32

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

%REM
    Class Podpisant
    Description: дает возможность получить информацию из базы Подписантов об указанной1 организации
    используется классом Vefify_Signed_XML
    можно использовать и отдельно как самостоятельный класс
%END REM
Public Class Podpisant   
    Private m_ListSignPodp() As Lico        'список имеющих право подписи в организации
    Private m_Ubound_idx_SignPodp As Integer
    Private m_kod_org As String
    Private m_name_org As String
   
    Private m_serverDB_Signed As String 'сервер где находится БД подписанты
    Private m_pathDB_Signed As String     'путь к БД подписанты
   
    Private m_isError As Boolean
    Private m_error_Text As String
   
    Public Sub New       
        Dim session As New NotesSession, cur_db As NotesDatabase
        Set cur_db=session.CurrentDatabase
       
        me.m_serverDB_Signed=cur_db.server
        me.m_pathDB_Signed="promdoc\SignVerify.nsf"
        Me.m_kod_org=""
               
        Call me.RestoreNULL       
    End Sub

    Public Function RunGetPodpisant(server_nameDB As String, pathDB As String, kod_org As String) As Boolean
        On Error GoTo errh
       
        Call me.RestoreNULL
       
        RunGetPodpisant=False       
        Dim session As New NotesSession, db As NotesDatabase, view As NotesView, doc_p As NotesDocument
        Dim mes As String, i As Integer, view_name As String, db_title2 As String, record As Variant
       
        If Not Trim(server_nameDB)=""     Then Me.m_serverDB_Signed=server_nameDB
        If Not Trim(pathDB)=""             Then Me.m_pathDB_Signed=pathDB
        If Not Trim(kod_org)=""         Then Me.m_kod_org=kod_org
       
        view_name="On_OrgKod"
               
        If Trim(Me.m_serverDB_Signed)=""     Then mes="Не указан сервер базы '"+db_title+"'": Error 1000
        If Trim(Me.m_pathDB_Signed)=""      Then mes="Не указан путь к базе '"+db_title+"'": Error 1000
        If Trim(Me.m_kod_org)=""             Then mes="Не указан код организации": Error 1000
       
        Set db = session.GetDatabase(me.m_serverDB_Signed, me.m_pathDB_Signed)
        If Not db.IsOpen Then mes="Нет подключения к базе '"+db_title+"'": Error 1000
        db_title2=db.Title
        Set view=db.Getview(view_name)
        If view Is Nothing Then mes="Не могу найти служебное представление '"+view_name+"' в базе '"+db_title2+"'": Error 1000
       
        Set doc_p=view.Getdocumentbykey(me.m_kod_org, True)
        If doc_p Is Nothing Then mes="Не найден документ организации в базе '"+db_title2+"'": Error 1000
       
        If Not doc_p.Hasitem("fam")    Or Not doc_p.Hasitem("im") Or Not doc_p.Hasitem("ot") Or Not doc_p.Hasitem("ern") _
        Then mes="Не заполнен документ организации в базе '"+db_title2+"'": Error 1000       
        If Trim(doc_p.fam(0))="" Or Trim(doc_p.im(0))="" Or Trim(doc_p.ot(0))="" Or Trim(doc_p.ern(0))="" _
        Then mes="Не заполнен документ организации в базе '"+db_title2+"'": Error 1000
       
        ForAll v In doc_p.NameOrg
            If me.m_name_org="" Then me.m_name_org=v Else me.m_name_org=me.m_name_org+Chr(13)+v   
        End ForAll
       
        For i=0 To UBound(doc_p.fam)           
            Set record=New Lico           
            record.FIO=doc_p.fam(i)
            record.FIO=record.FIO+" "+doc_p.im(i)
            record.FIO=record.FIO+" "+doc_p.ot(i)
            record.UINFL=doc_p.ern(i)
            record.UINUL=doc_p.ernul(i)
            record.UINOIGV=doc_p.ernoigv(i)
           
            ReDim Preserve me.m_ListSignPodp(i)           
            Set me.m_ListSignPodp(i)=record
            me.m_Ubound_idx_SignPodp=i
        Next
       
        RunGetPodpisant=True
        Exit Function
errh:           
        If Err=1000 Then mes="Ошибка получения данных!!! "+mes
        Call me.SetError(Err, mes)
        Exit Function
    End Function
   
'геттеры******************
    Public Property Get GetListPodp As Variant
        On Error GoTo errh
        Dim mes As String
        If me.m_Ubound_idx_SignPodp=-1 Then mes="Нет данных по ведомству о подписантах": Error 1000
        GetListPodp=me.m_ListSignPodp
        Exit Property
errh:
        GetListPodp=Null
        Call me.SetError(Err, mes)
        Exit Property
    End Property

    Public Property Get GetCountListPodp As Integer
        GetCountListPodp=me.m_Ubound_idx_SignPodp+1
    End Property   
    Public Property Get GetNameOrg As String
        GetNameOrg=me.m_name_org       
    End Property
    Public Property Get GetErrorText As String
        GetErrorText=me.m_error_Text
    End Property
'сеттеры******************   
    Public Property Set SetServerDBSigned As String
        me.m_serverDB_Signed=SetServerDBSigned
    End Property
    Public Property Set SetPathDBSigned As String
        me.m_pathDB_Signed=SetPathDBSigned
    End Property   
    Public Property Set SetKodOrg As String
        me.m_kod_org=SetKodOrg
    End Property   
'**********************************************************************************************   
    Private Sub RestoreNULL
        me.m_isError=False
        me.m_error_Text=""
        Me.m_Ubound_idx_SignPodp=-1
       
        me.m_name_org=""
        If IsArray(me.m_ListSignPodp)        Then Erase me.m_ListSignPodp
    End Sub
   
    Private Sub SetError(Er As Integer, mes As String)'записываем ошибку
        Me.m_isError=True
        If er>=1000 And er<=1100 Then
            Me.m_error_Text=mes           
        Else
            Me.m_error_Text="Ошибка № " & Er & " в строке " & Erl & Chr(13) & Error(Er)           
        End If       
    End Sub
End Class

Поделиться

33

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

%REM
    класс для получения информации о ФИО из тега XML документа
    используется классом Vefify_Signed_XML
    можно использовать и отдельно как самостоятельный класс
%END REM
Public Class SAX_Parser
    Private axis As String 'служебная для парсера
    Private nodetext As String 'служебная для парсера
   
    Private m_path_XML As String         'путь к проверяемому файлу
    Private m_isError As Boolean
    Private m_error_Text As String
    Private m_kod_med As String
    Private m_kod_med_sub As String
    Private m_Ubound_idx_Signed As Integer
   
    Private m_List_FIO() As String 'список ФИО которые в теге XML
'*******************************************************************************   
    Public Sub New()
        Me.m_path_XML=""   
        Call RestoreNULL           
    End Sub
   
    Public Property Get GetListFIO As Variant
        On Error GoTo errh
        Dim mes As String
        If me.m_Ubound_idx_Signed=-1 Then mes="Нет подписей в сопроводе": Error 1000
        GetListFIO=me.m_List_FIO
        Exit Property
errh:
        GetListFIO=Null
        Call me.SetError(Err, mes)
        Exit Property
    End Property
   
    Public Property Get GetKodMed As String
        GetKodMed=me.m_kod_med
    End Property
   
    Public Property Get GetKodMedSub As String
        GetKodMedSub=me.m_kod_med_sub
    End Property
   
    Public Property Get GetCountListFIO As Integer
        GetCountListFIO=me.m_Ubound_idx_Signed+1
    End Property
   
    Public Property Get isError As Boolean
        isError=me.m_isError
    End Property
   
    Public Property Get GetErrorText As String
        GetErrorText=me.m_error_Text
    End Property
   
    Public Function Run(pathFile As String) As Boolean
        On Error GoTo errh
        Call RestoreNULL
        Run=False   
               
        Dim mes As String, session As New NotesSession, strm As NotesStream, outputStream As NotesStream
        Dim saxParser As NotesSAXParser
       
        If Trim(pathFile)="" Then
            If Me.m_path_XML="" Then mes="Ошибка!!! Не указан путь к проверяемому файлу.": Error 1000
        Else
            Me.m_path_XML=pathFile   
        End If       
       
        Set outputStream =session.CreateStream()
        Set strm = session.CreateStream()       
        Call strm.Open(Me.m_path_XML, "UTF-8" )
        
        Set saxParser=session.CreateSAXParser(strm, outputStream)
        On Event SAX_StartDocument From saxParser Call SAXStartDocument
        On Event SAX_StartElement From saxParser Call SAXStartElement
        On Event SAX_Characters From saxParser Call SAXCharacters ' содержимое элемента
        On Event SAX_StartElement  From saxParser Call SAXStartElement 'старт элемента
        On Event SAX_EndElement From saxParser Call SAXEndElement 'конец элемента
        On Event SAX_Error From saxParser Call SAXError
        On Event SAX_FatalError From saxParser Call SAXFatalError
        saxParser.Process   
        Call outputStream.close                           
        Call strm.Close
        Run=True
        Exit Function
errh:       
        Call me.SetError(Err, mes)
        Exit Function
    End Function
'*******************************************************************************   
    Private Sub RestoreNULL
        Me.m_isError=False
        Me.m_error_Text=""
        Me.m_kod_med=""
        Me.m_kod_med_sub=""       
        Me.m_Ubound_idx_Signed=-1
        If IsArray(me.m_List_FIO) Then Erase me.m_List_FIO   
    End Sub
   
    Private Sub SAXCharacters (Source As NotesSAXParser, ByVal Characters As String, Count As Long)
        On Error GoTo ErrH   
        Dim ItemName As String, mes As String
        Select Case me.axis   
        '    Case  "/htmlx/body2/container/signaturestextinfo/post"     : ItemName="ДОЛЖНОСТЬ"
            Case  "/htmlx/body2/container/signaturestextinfo/fio"     : ItemName="ФИО"
            Case  "/htmlx/body2/container/kodorg"                     : ItemName="Код_МЭД"
            Case  "/htmlx/body2/container/kodorgsub"                 : ItemName="Код_МЭД_суб"
        End Select
       
        'If ItemName="ФИО" Or ItemName="ДОЛЖНОСТЬ" Then
        If ItemName="ФИО" Then               
            Me.m_Ubound_idx_Signed=Me.m_Ubound_idx_Signed+1
            If Not IsArray(me.m_List_FIO) Then
                ReDim me.m_List_FIO(0)
            Else
                ReDim Preserve me.m_List_FIO(Me.m_Ubound_idx_Signed)
            End If       
            me.m_List_FIO(Me.m_Ubound_idx_Signed)=Trim(Characters)
        ElseIf ItemName="Код_МЭД" Then
            me.m_kod_med=Characters
        ElseIf ItemName="Код_МЭД_суб" Then
            me.m_kod_med_sub=Characters
        End If
       
        Exit Sub       
ErrH:
        Call me.SetError(Err, mes)
        Exit Sub       
    End Sub
   
    Private Sub SAXStartDocument (Source As NotesSAXParser)
        me.axis=""
    End Sub
   
    Private Sub SAXStartElement (Source As NotesSAXParser, ByVal elementname As String, Attributes As NotesSAXAttributeList)
        If me.nodetext<>elementname Then Me.axis=me.axis+"/"+elementname ' хз несколько раз подрят срабатывает событие
        me.nodetext=elementname
    End Sub
   
    Private Sub SAXEndElement (Source As NotesSAXParser, ByVal ElementName As String)
        me.axis= StrLeftBack(me.axis,"/")
        me.nodetext=""
    End Sub
   
    Private Sub SAXEndDocument (Source As NotesSAXParser)
        me.axis=""
    End Sub
   
    Private Sub SAXFatalError (Source As NotesSAXParser, Exception As NotesSAXException)       
        Source.Output ("FatalError - "+Exception.Message)
    End Sub
   
    Sub SAXError (Source As NotesSAXParser, Exception As NotesSAXException )       
        Source.Output ("Error - "+Exception.Message)
    End Sub
   
    Private Sub SetError(Er As Integer, mes As String)'записываем ошибку
        Me.m_isError=True
        If er>=1000 And er<=1100 Then
            Me.m_error_Text=mes           
        Else
            Me.m_error_Text="Ошибка № " & Er & " в строке " & Erl & Chr(13) & Error(Er)           
        End If       
    End Sub
End Class

Поделиться

34

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

'Const type_prov=123 '??????планирую сделать проверку настраиваемой(все три проверять или только 2 проверять по ЕРН или нет)
'Const type_prov_ern=0
'Const db_path_default="promdoc\SignVerify.nsf"       
%REM
    Класс для проверки подписи в документе XML и сравнение подписей с базой подписанты
    Вытягиваем ФИО из тега XML
    Вытягиваем ФИО и ЕРНы из ЭП XML
    Вытягиваем список ФИО и и ЕРНы из базы 'Подписанты'
    если будет хоть одно совпадение по всем трем Фамилия И.О. а также по ЕРНФЛ и по одному из ЕРНЮЛ/ЕРНОИГВ- считается документ успешно прошел проверку
   

==================================ОПИСАНИЕ Public методов и свойств класса Verify_Signed_XML============================================   
Public
    Property Get GetListFIOTeg             As Variant     'получаем массив данных ФИО из тега (если нет ФИО - возвращается NULL)
    Property Get GetListFIOEP             As Variant    'получаем массив данных ФИО из ЭП (если нет ФИО - возвращается NULL)
    Property Get GetListFIOPodp         As Variant    'получаем массив данных ФИО из базы подписантов (если нет ФИО - возвращается NULL)
    Property Get GetNameOrg             As String    'получаем наименование ведомства отославшей документ
    Property Get GetKodMedOrg             As String    'получаем код организации отославшей документ (если из подведа - то к примеру 7.501)
    Property Get GetCountListFIOTeg     As Integer    'получаем кол-во ФИО из тега
    Property Get GetCountListFIOEP         As Integer    'получаем кол-во ФИО из ЭП
    Property Get GetCountListFIOPodp    As Integer    'получаем кол-во ФИО из базы подписанты по ведомству отославшей документ
    Property Get isError                 As Boolean    'была/не было ошибки True/False
    Property Get GetErrorText             As String   'получаем текст ошибки
   
    Property Set SetPathCriptoGSS     As String        'передаем путь к ConsoleCriptoGSS
    Property Set SetPathXML         As String        'передаем путь к проверяемому файлу
    Property Set SetServerDBSigned     As String        'передаем имя сервера где находится БД 'Подписанты'
    Property Set SetPathDBSigned     As String        'передаем путь к БД 'Подписанты'
    Property Set SetNotesDocument     As NotesDocument'передаем NotesDocument в котором нужно проверить аттач
    Property Set SetItemName         As string        'передаем наименование итема в котором нужно проверить аттач
       
    Function VerifySignedXML(pathCriptoGSS As String, server_nameDB As String, pathDB As String, pathFile As String) As Boolean
    -ф-ция используется для проверки файла XML находящегося на диске
   
    где: pathCriptoGSS     - путь к consolecriptogss, например "c:\consolecriptogss\consolecriptogss.exe"
         server_nameDB     - название сервера где находится БД 'Подписанты',если текущий сервер - оставлем пустым
         pathDB         - путь к базе 'Подписанты', если база находится по пути "promdoc\SignVerify.nsf" - оставляем пустым
         pathFile         - путь к проверяемому файлу
    если перед вызовом данной ф-ции использовались нужные сеттеры - все либо нужные аргументы оставляем пустыми
       
    Function VerifySignedXMLFromDoc(pathCriptoGSS As String, server_nameDB As String, pathDB As String, doc As Variant, itemname As String) As Boolean
    -ф-ция используется для проверки файла XML находящегося в виде аттача в NotesDocument
   
    где: pathCriptoGSS     - путь к consolecriptogss, например "c:\consolecriptogss\consolecriptogss.exe"
         server_nameDB     - название сервера где находится БД 'Подписанты',если текущий сервер - оставлем пустым
         pathDB         - путь к базе 'Подписанты', если база находится по пути "promdoc\SignVerify.nsf" - оставляем пустым
         doc             - NotesDocument в котором находится проверяемый аттач(если документ был определен через сеттер - указываем Nothing)
         itemname         - название итема в котором находится проверяемый аттач
    если перед вызовом данной ф-ции использовались нужные сеттеры - все либо нужные аргументы оставляем пустыми
                       
       
==================================1 Пример работы с классом(проверяем файл на диске)============================================
   
    Dim verify_p  As New Verify_Signed_XML
   
    verify_p.SetPathXML="c:\XML\podpisant.xml" 'как вариант использую сеттер, а можно передать и прям в ф-ции VerifySignedXML
    If Not verify_p.VerifySignedXML("C:\ConsoleCriptoGSS\ConsoleCriptoGSS.exe", "", "", "") Then
        Messagebox "Была ошибка во время проверки либо документ не прошел успешно проверку"       
    Else
        Messagebox "Документ успешно проверен"
    End If

'далее при необходимости можем использовать методы для получения информации об ошибке, подписантах и т.д.   

    if verify_p.isError then s="Текст ошибки: "+verify_p.GetErrorText+Chr(13) 'если есть ошибка получаем текст ошибки

    s=s+"Код организации: "+verify_p.GetKodMedOrg+Chr(13)
    s=s+"Кол-во подписантов XML в теге: "+Cstr(verify_p.GetCountListTeg)+Chr(13)   

'I способ получения информации о подписантах (проверяем на NULL)
    mas=verify_p.GetListTeg 'получаем массив данных с подписантами в теге
    If Not Isnull(mas) Then
        Forall v In mas
            tmp=tmp+Chr(13)+v.FIO
            tmp=tmp+Chr(13)   
        End Forall
        s=s+"Список из тега:"+tmp+Chr(13)
    End If
   
    s=s+"Кол-во в ЭП: "+Cstr(verify_p.GetCountListEP)+Chr(13)
'II способ получения информации о подписантах (если кол-во подписантов > 0 - получаем список этих подписантов)       
    If verify_p.GetCountListFIOEP>0 Then
        mas=verify_p.GetListFIOEP 'получаем массив данных с подписантами в эл.подписи
        tmp=""
        Forall v In mas
            tmp=tmp+Chr(13)+v.FIO
            tmp=tmp+Chr(13)+v.UINFL
            tmp=tmp+Chr(13)+v.UINUL
            tmp=tmp+Chr(13)+v.UINOIGV
            tmp=tmp+Chr(13)           
        End Forall
        s=s+"Список из ЭП:"+tmp+Chr(13)
    End If
   
    s=s+"Кол-во кому разрешено: "+Cstr(verify_p.GetCountListPodp)+Chr(13)
    If verify_p.GetCountListFIOPodp>0 Then
        mas=verify_p.GetListFIOPodp    'получаем массив данных с подписантами из базы подписанты
        tmp=""
        Forall v In mas
            tmp=tmp+Chr(13)+v.FIO
            tmp=tmp+Chr(13)+v.UINFL
            tmp=tmp+Chr(13)+v.UINUL
            tmp=tmp+Chr(13)+v.UINOIGV
            tmp=tmp+Chr(13)
        End Forall
        s=s+"Список из подписантов:"+tmp
    End If
    Messagebox s
   
==================================2 Пример работы с классом(проверяем аттач в нотес доке)============================================
   
    Dim verify_p  As New Verify_Signed_XML, doc As notesdocument, ws As New NotesUIWorkspace
   
    Set doc = ws.CurrentDocument.Document
   
    verify_p.SetPathCriptoGSS="C:\ConsoleCriptoGSS\ConsoleCriptoGSS.exe"
    Set verify_p.SetNotesDocument=doc
    verify_p.SetItemName="text"
   
    If Not verify_p.VerifySignedXMLFromDoc("", "", "", Nothing, "") Then
        Messagebox "Была ошибка во время проверки либо документ не прошел успешно проверку"       
    Else
        Messagebox "Документ успешно проверен"
    End If
    'далее, как и в 1примере, можем получать нужную нам информацию из класса
%END REM

Public Class Verify_Signed_XML   
    Private m_ListSignSoprovod() As Lico    'список подписавших в теге XML(считается только один, не делаю анализ на ентеры и тому подобное, беру все что есть в теге)
    Private m_ListSignEP() As Lico        'список подписавших в ЭП
    Private m_ListSignPodp() As Lico        'список имеющих право подписи в организации
    Private m_Ubound_idx_SignSoprovod As Integer
    Private m_Ubound_idx_SignEP As Integer
    Private m_Ubound_idx_SignPodp As Integer
    Private m_kod_med As String
    Private m_kod_med_sub As String   
    Private m_name_org As String
   
    Private m_path_criptoGSS As String     'путь к консольной криптоГСС
    Private m_path_XML As String         'путь к проверяемому файлу
    Private m_name_XML As String         'имя проверяемому вложения
    Private m_serverDB_Signed As String 'сервер где находится БД подписанты
    Private m_pathDB_Signed As String     'путь к БД подписанты
   
    Private m_isError As Boolean
    Private m_error_Text As String
   
    Private m_doc As NotesDocument 'нотес документ в котором проверяемый итем с файлом
    Private m_item_Name As String 'название итема с файлом
   
    Public Sub New       
        me.m_path_criptoGSS=""
        me.m_path_XML=""
        me.m_serverDB_Signed=""
        me.m_pathDB_Signed=""
        Set me.m_doc=Nothing
        me.m_item_Name=""
        me.m_name_XML=""
       
        Call me.RestoreNULL       
    End Sub
   
    Public Function VerifySignedXML(pathCriptoGSS As String, server_nameDB As String, pathDB As String, pathFile As String) As Boolean
        On Error GoTo errh
        VerifySignedXML=False
        Call me.RestoreNULL
               
        Dim mas1 As Variant, mas2 As Variant, mas3 As Variant, b_tmp As Boolean, mes As String
        Dim tmp1 As String, tmp2 As String, tmp3 As String, i As Integer
        b_tmp=False
       
        If Not Trim(pathCriptoGSS)=""     Then Me.m_path_criptoGSS=pathCriptoGSS
        If Not Trim(server_nameDB)=""     Then Me.m_serverDB_Signed=server_nameDB
        If Not Trim(pathDB)=""             Then Me.m_pathDB_Signed=pathDB
        If Not Trim(pathFile)=""         Then Me.m_path_XML=pathFile
           
        If Not Proverka Then mes=me.m_error_Text: Error 1000
                
        If Not me.GetSoprovod     Then mes="Ошибка получения списка подписей из тега. "+ me.m_error_Text: Error 1000
        If Not me.GetSignFile     Then mes="Ошибка получения списка ЭП. "+ me.m_error_Text: Error 1000
        If Not me.GetPodpisant     Then mes="Ошибка получения списка людей имеющих право подписывать. "+ me.m_error_Text: Error 1000
       
        Dim mas_tmp As Variant       
        ForAll v1 In me.m_ListSignSoprovod'(v1.FIO=Иванов И.И. или И.И. Иванов или Иванов И. И. или И. И. Иванов)                       
            mas_tmp=Split(UCase(Trim(v1.FIO)), " ")
            If UBound(mas_tmp)=1 Or UBound(mas_tmp)=2 Then
                i=0
                ReDim mas1(1)
                ForAll v In mas_tmp
                    If InStr(v,".")=0 Then'если фамилия (нет точки)
                        mas1(0)=Trim(v)
                    Else
                        If i=0 Then mas1(1)=Trim(v) Else mas1(1)=mas1(1)+Trim(v)
                        i=1
                    End If
                End ForAll               
                mas1(1)=Replace(mas1(1),". ",".")
                tmp1=mas1(0)+" "+mas1(1)               
                tmp1=me.TrimForNoRus(tmp1) 'оставим только кирилические символы, точки и пробел
                If Mid$(tmp1,Len(tmp1),1)<>"." Then tmp1=tmp1+"."    'иногда может встречаться И.О без точки после О
                Print "ФИО из сопровода из тега - //" +tmp1+"//"               
                ForAll v2 In me.m_ListSignEP'(v2.FIO=Иванов Иван Иванович) - из ЭП
                    mas2=Split(Trim(UCase(v2.FIO)), " ")'mas1(0)=ИВАНОВ     mas1(1)=ИВАН    mas1(2)=ИВАНОВИЧ                   
                    tmp2=Trim(mas2(0))+" "+ Trim(Left$(mas2(1), 1)+"."+Left$(mas2(2), 1)+".")
                    tmp2=me.TrimForNoRus(tmp2) 'оставим только кирилические символы, точки и пробел
                    Print "ФИО из ЭП - //" +tmp2+"//"   
                    If tmp1=tmp2 Then
                        ForAll v3 In me.m_ListSignPodp'(v3.FIO=Иванов Иван Иванович)
                            mas3=Split(Trim(UCase(v3.FIO)), " ")
                            tmp3=Trim(mas3(0))+" "+Trim(Left$(mas3(1), 1)+"."+Left$(mas3(2), 1)+".")
                            tmp3=me.TrimForNoRus(tmp3)'оставим только кирилические символы, точки и пробел
                            Print "ФИО из БД 'Подписанты' - //" +tmp3+"//"                           
                            If tmp3=tmp2 Then
                                If v2.UINFL=v3.UINFL And ((v2.UINUL<>"" And v2.UINUL=v3.UINUL) Or (v2.UINOIGV<>"" And v2.UINOIGV=v3.UINOIGV)) Then
                                    b_tmp=True : GoTo end_func
                                End If                                   
                            End If                           
                        End ForAll
                    End If
                End ForAll                                           
            End If
        End ForAll                       
       
end_func:
        If Not b_tmp Then mes="Нет совпадения подписантов.": Error 1000       
        Print "Совпадение подписантов найдено. Проверка пройдена успешно."
        VerifySignedXML=True
        Exit Function
errh:   
        If Not me.m_isError Then mes="Не удалось проверить подписантов. "+mes
        Call me.SetError(Err, mes)
        Exit Function
    End Function

    Public Function VerifySignedXMLFromDoc(pathCriptoGSS As String, server_nameDB As String, pathDB As String, doc As Variant, itemname As String) As Boolean
        On Error GoTo errh
        VerifySignedXMLFromDoc=False
        me.m_name_XML=""
        Call me.RestoreNULL
        Dim db As NotesDatabase, rtitem As NotesRichTextItem, mes As String, obj As Variant
       
        If Not Trim(pathCriptoGSS)=""     Then Me.m_path_criptoGSS=pathCriptoGSS
        If Not Trim(server_nameDB)=""     Then Me.m_serverDB_Signed=server_nameDB
        If Not Trim(pathDB)=""             Then Me.m_pathDB_Signed=pathDB
        If Not doc Is Nothing             Then Set me.m_doc=doc       
        If Not Trim(itemname)=""         Then me.m_item_name=itemname
       
        If me.m_doc Is Nothing             Then mes="Ошибка!!! Не передан NotesDocument": Error 1000
        If Trim(Me.m_item_name)=""         Then mes="Ошибка!!! Не указано название итема содержащего аттач": Error 1000   
       
        If Not me.m_doc.HasEmbedded                 Then  mes="Ошибка!!! В NotesDocument нет аттача": Error 1000
        If Not me.m_doc.HasItem(me.m_item_Name)     Then  mes="Ошибка!!! В NotesDocument нет указанного итема": Error 1000
       
        Set rtitem = me.m_doc.GetFirstItem(me.m_item_Name)
        If rtitem Is Nothing                 Then mes="Ошибка!!! Не могу получить объект итема": Error 1000
        If IsEmpty(rtitem.EmbeddedObjects)     Then mes="Ошибка!!! В указанном итеме нет аттача": Error 1000
       
        Set obj=rtitem.EmbeddedObjects(0)
        If  Not (obj.Type = EMBED_ATTACHMENT) Then mes="Ошибка!!! В указанном итеме объект не является аттачем": Error 1000
        If  Not  LCase(StrRightBack(obj.Source , ".")) = "xml"  Then mes="Ошибка!!! Аттач не является XML файлом": Error 1000
       
        me.m_name_XML=obj.Source
        Me.m_path_XML=me.GetNotesTempDirectory+obj.Source
               
        If Not Proverka Then mes=me.m_error_Text: Error 1000
       
        Call obj.ExtractFile(Me.m_path_XML)
       
        If Not VerifySignedXML(Me.m_path_criptoGSS, Me.m_serverDB_Signed, Me.m_pathDB_Signed, Me.m_path_XML)Then
            mes=Me.m_error_Text
            Kill me.m_path_XML
            Error 1001
        End If
        
        Kill me.m_path_XML
        VerifySignedXMLFromDoc=True
        Exit Function
errh:           
        If Not Err=1001 Then mes="Не удалось проверить подписантов. "+mes       
        Call me.SetError(Err, mes)
        Exit Function
    End Function
   
'геттеры
    Public Property Get GetListTeg As Variant
        On Error GoTo errh
        Dim mes As String
        If me.m_Ubound_idx_SignSoprovod=-1 Then mes="Нет подписей в сопроводе": Error 1000
        GetListTeg=me.m_ListSignSoprovod
        Exit Property
errh:
        GetListTeg=Null
        Call me.SetError(Err, mes)
        Exit Property
    End Property
       
    Public Property Get GetListEP As Variant
        On Error GoTo errh
        Dim mes As String
        If me.m_Ubound_idx_SignEP=-1 Then mes="Нет подписей ЭП": Error 1000
        GetListEP=me.m_ListSignEP
        Exit Property
errh:
        GetListEP=Null
        Call me.SetError(Err, mes)
        Exit Property
    End Property
   
    Public Property Get GetListPodp As Variant
        On Error GoTo errh
        Dim mes As String
        If me.m_Ubound_idx_SignPodp=-1 Then mes="Нет данных ведомству о подписантах": Error 1000
        GetListPodp=me.m_ListSignPodp
        Exit Property
errh:
        GetListPodp=Null
        Call me.SetError(Err, mes)
        Exit Property
    End Property
   
    Public Property Get GetNameXML As String
        GetNameXML=me.m_name_XML       
    End Property
   
    Public Property Get GetNameOrg As String
        GetNameOrg=me.m_name_org       
    End Property   
    Public Property Get GetKodMedOrg As String
        GetKodMedOrg=me.m_kod_med
        If Not me.m_kod_med_sub="" Then GetKodMedOrg=GetKodMedOrg+"."+me.m_kod_med_sub
    End Property   
    Public Property Get GetCountListTeg As Integer
        GetCountListTeg=me.m_Ubound_idx_SignSoprovod+1
    End Property
    Public Property Get GetCountListEP As Integer
        GetCountListEP=me.m_Ubound_idx_SignEP+1
    End Property
    Public Property Get GetCountListPodp As Integer
        GetCountListPodp=me.m_Ubound_idx_SignPodp+1
    End Property       
    Public Property Get isError As Boolean
        isError=me.m_isError
    End Property   
    Public Property Get GetErrorText As String
        GetErrorText=me.m_error_Text
    End Property
'сеттеры******************
    Public Property Set SetPathCriptoGSS As String
        me.m_path_criptoGSS=SetPathCriptoGSS
    End Property
   
    Public Property Set SetPathXML As String
        me.m_path_XML=SetPathXML
    End Property
    Public Property Set SetServerDBSigned As String
        me.m_serverDB_Signed=SetServerDBSigned
    End Property
    Public Property Set SetPathDBSigned As String
        me.m_pathDB_Signed=SetPathDBSigned
    End Property   
    Public Property Set SetNotesDocument As NotesDocument
        Set me.m_doc=SetNotesDocument
    End Property
    Public Property Set SetItemName As String
        me.m_item_name=SetItemName
    End Property   
   
'**********************************************************************************************       
    Private Function GetSoprovod As Boolean'подписанты тег XML
        On Error GoTo errh
        Dim sax As New SAX_Parser, mes As String, i As Integer, mas As Variant, record As Variant
        GetSoprovod=False
        If Not sax.run(Me.m_path_XML) Then Error 1000
       
        me.m_kod_med=sax.GetKodMed
        me.m_kod_med_sub=sax.GetKodMedSub
       
        If sax.GetCountListFIO>0 Then       
            mas=sax.GetListFIO    'получаем тестовый массив               
            For i=0 To sax.GetCountListFIO-1
                Set record=New Lico
                record.FIO=mas(i)
                record.UINFL    =""
                record.UINUL    =""
                record.UINOIGV    =""
                ReDim Preserve me.m_ListSignSoprovod(i)
                Set me.m_ListSignSoprovod(i)=record                               
            Next           
            Me.m_Ubound_idx_SignSoprovod=sax.GetCountListFIO-1
        Else
            mes="Ошибка!!! В документе нет подписантов в теге"
            Error 1000
        End If
        GetSoprovod=True
        Exit Function
errh:       
        If Not sax Is Nothing Then mes=sax.GetErrorText()
        Call me.SetError(Err, mes)
        Exit Function
    End Function   
   
    Private Function GetSignFile As Boolean'подписанты ЭП
        On Error GoTo errh
        Dim verify_class As New Verify_CriptoGSS
        Dim i As Integer, mes As String, record As Variant
        GetSignFile=False
        If Not verify_class.SetAllArg(Me.m_path_criptoGSS, "All", Me.m_path_XML) Then  mes=verify_class.GetTextError: Error 1000
        If Not verify_class.verify Then mes=verify_class.GetTextError: : Error 1000
       
        If verify_class.CountListSertInDoc>0 Then           
            For i=0 To verify_class.CountListSertInDoc-1
                Set record=New Lico
                With verify_class.GetListSertInDoc(i).Certificate
                    record.FIO        =.FIO
                    record.UINFL    =.UINFL
                    record.UINUL    =.UINUL
                    record.UINOIGV    =.UINOIGV   
                End With       
               
                ReDim Preserve me.m_ListSignEP(i)
                Set me.m_ListSignEP(i)=record                                                           
            Next
            Me.m_Ubound_idx_SignEP=verify_class.CountListSertInDoc-1
        Else
            mes="Ошибка!!! В документе нет подписантов ЭП"
            Error 1000       
        End If
        GetSignFile=True   
        Exit Function
errh:           
        Call me.SetError(Err, mes)
        Exit Function
    End Function
   
    Private Function GetPodpisant As Boolean
        On Error GoTo errh
       
        GetPodpisant=False   
       
        Dim mas As Variant, mes As String, key As String, i As Integer
       
        If me.m_kod_med="" Then mes="Ошибка!!! Не получен код ведомства": Error 1000
       
        Dim p_class As New Podpisant
       
        key=me.m_kod_med
        If Not me.m_kod_med_sub="" Then key=key+"."+me.m_kod_med_sub
       
        If Not p_class.RunGetPodpisant(me.m_serverDB_Signed, me.m_pathDB_Signed, key) Then    mes=p_class.GetErrorText : Error 1000
   
        me.m_name_org=p_class.GetNameOrg
       
        If p_class.GetCountListPodp>0 Then       
            mas=p_class.GetListPodp                'получаем уже массив объектов класса Lico   
            For i=0 To p_class.GetCountListPodp-1                   
                ReDim Preserve me.m_ListSignPodp(i)
                Set me.m_ListSignPodp(i)=mas(i)                           
            Next           
            Me.m_Ubound_idx_SignPodp=p_class.GetCountListPodp-1                       
        Else
            mes="Ошибка!!! В документе нет подписантов в теге"
            Error 1000
        End If
        %REM ' можно и так получить список
        mas=p_class.GetListFIOPodp
        If Not IsNull(mas) Then           
            For i=0 To UBound(mas)
                ReDim Preserve me.m_ListSignPodp(i)
                Set me.m_ListSignPodp(i)=mas(i)               
            Next
            me.m_Ubound_idx_SignPodp=p_class.GetCountListFIOPodp-1
        Else
            mes="Не указаны подписанты по данному ведомству"
            Error 1000
        End If   
        %END REM                       
       
        GetPodpisant=True
        Exit Function
errh:           
        Call me.SetError(Err, mes)
        Exit Function
    End Function
   
    Private Function Proverka As Boolean
        On Error GoTo errh
        Proverka=False
        Dim mes As String
        If Trim(Me.m_path_criptoGSS)=""      Then mes="Ошибка!!! Не указан путь к ConsoleCriptoGSS": Error 1000
        'If Trim(Me.m_serverDB_Signed)=""     Then mes="Ошибка!!! Не указан сервер базы '"+db_title+"'": Error 1000
        'If Trim(Me.m_pathDB_Signed)=""      Then mes="Ошибка!!! Не указан путь к базе '"+db_title+"'": Error 1000
        If Trim(Me.m_path_XML)=""             Then mes="Ошибка!!! Не указан путь к проверяемому файлу": Error 1000
        Proverka=True
        Exit Function
errh:           
        Call me.SetError(Err, mes)
        Exit Function
    End Function

    Private Function TrimForNoRus(value As String) As String 'оставляем только кирилицу,пробел и точки
        On Error GoTo errh
        Dim i As Integer, s As String, ch As String, tmp_str As String
        TrimForNoRus=""
        s=""
        For i=1 To Len(value)
            ch=Mid$(value,i,1)
            If Asc(ch)=32 Or Asc(ch)=46 Or Asc(ch)=168 Or Asc(ch)=184 Or (Asc(ch)>=192 And Asc(ch)<=255) Then
                TrimForNoRus=TrimForNoRus+ch
            Else
                s=s+"//Символ '"+ch+"', код ASCII="+CStr(Asc(ch))
            End If
        Next           
        If s<>"" Then Print "в значении '"+value+"' встретились не кирилличесике символы: "+s
        Exit Function
errh:
        Print "в ф-ции TrimForNoRus произошла ошибка № " & Err & " в строке " & Erl
        TrimForNoRus=value
        Exit Function
    End Function
   
    Private Sub RestoreNULL
        me.m_isError=False
        me.m_error_Text=""
        Me.m_Ubound_idx_SignSoprovod=-1       
        Me.m_Ubound_idx_SignEP        =-1
        Me.m_Ubound_idx_SignPodp    =-1
       
        Me.m_kod_med=""
        Me.m_kod_med_sub=""
       
        If IsArray(me.m_ListSignSoprovod)    Then Erase me.m_ListSignSoprovod
        If IsArray(me.m_ListSignEP)         Then Erase me.m_ListSignEP   
        If IsArray(me.m_ListSignPodp)        Then Erase me.m_ListSignPodp
    End Sub
   
    Private Sub SetError(Er As Integer, mes As String)'записываем ошибку
        Me.m_isError=True
        If er>=1000 And er<=1100 Then
            Me.m_error_Text=mes           
        Else
            Me.m_error_Text="Ошибка № " & Er & " в строке " & Erl & Chr(13) & Error(Er)           
        End If       
    End Sub
   
    Private Function GetNotesTempDirectory() As String'Путь для временных файлов
        Dim d As String * 256
        Dim s%
        s% = w32_OSGetSystemTempDirectory(d)
        GetNotesTempDirectory = Left$(d, s%) +"\"
    End Function
End Class

Поделиться