const CTimeOut = 120 '2 минуты

'при отсутствии значений, для аутентификации передаются реквизиты пользователя, из под которого работает текущий процесс.
const CLogin = ""
const CPassword = ""

dim GAttachDocumentActionRN
dim GAttachDocumentSelectedParamRN
dim GAttachDocumentDocumentParamRN

dim GDefaultFileType

dim GFileSystem

private function XMLDocumentProgID
  if Silent then
    XMLDocumentProgID = "Msxml2.DOMDocument.6.0"
  else
    XMLDocumentProgID = "Msxml2.DOMDocument.4.0"
  end if
end function

private function GetOptionStrValue(Name, Caption, Required)
  StoredProc.StoredProcName = "P_OPTIONS_GET_VALUES"
  StoredProc.ParamByName("sCODE").Value = Name
  StoredProc.ParamByName("nCOMPANY").Value = COMPANY
  StoredProc.ExecProc
  GetOptionStrValue = StoredProc.ParamByName("sSTR_VALUE").Value

  if Required and IsNull(GetOptionStrValue) then
    Err.Raise vbObjectError + 10000, "GetOptionStrValue", "Не задано значение параметра """ & Caption & """."
  end if

  if IsNull(GetOptionStrValue) then
    GetOptionStrValue = ""
  end if
end function

private function GetActionRN(ModuleName, ActionName)
  StoredProc.StoredProcName = "FIND_UAMACTIONS_CODE"
  StoredProc.ParamByName("NFLAG_SMART").Value = "0"
  StoredProc.ParamByName("NFLAG_OPTION").Value = "0"
  StoredProc.ParamByName("NMODULE").Value = Null
  StoredProc.ParamByName("SMODULE").Value = ModuleName
  StoredProc.ParamByName("SCODE").Value = ActionName
  StoredProc.ExecProc
  GetActionRN = StoredProc.ParamByName("NRN").Value
end function

private function GetActionParamRN(ActionRN, ParamName)
  StoredProc.StoredProcName = "FIND_UAMAPARAM_CODE"
  StoredProc.ParamByName("NFLAG_SMART").Value = "0"
  StoredProc.ParamByName("NFLAG_OPTION").Value = "0"
  StoredProc.ParamByName("nPRN").Value = ActionRN
  StoredProc.ParamByName("SCODE").Value = ParamName
  StoredProc.ExecProc
  GetActionParamRN = StoredProc.ParamByName("NRN").Value
end function

private sub ParseURL(ByVal Value, Host, Handler)
  LIsSecure = false

  if StrComp("http://", Left(Value, Len("http://")), vbTextCompare) = 0 then
    Value = Right(Value, Len(Value) - Len("http://"))
  elseif StrComp("https://", Left(Value, Len("https://")), vbTextCompare) = 0 then
    LIsSecure = true
    Value = Right(Value, Len(Value) - Len("https://"))
  end if

  LPos = InStr(Value, "/")
  if LPos <> 0 then
    Host = Left(Value, LPos - 1)
    Handler = Right(Value, Len(Value) - LPos)
  else
    Host = Value
    Handler = ""
  end if

  if LIsSecure then
    Host = "https://" & Host
  end if
end sub

private function StringOfChar(Char, Count)
  StringOfChar = ""
  for I = 0 to Count - 1
    StringOfChar = StringOfChar & Char
  next
end function

private function AppendLeadingZero(Value, Count)
  AppendLeadingZero = Value
  if Len(Value) < Count then
    AppendLeadingZero = StringOfChar("0", Count - Len(Value)) & AppendLeadingZero
  end if
end function

private function FormatDateTime(Value)
  if Len(Value) > 0 then
    Value = CDate(Value)
    FormatDateTime = _
      AppendLeadingZero(Year(Value), 4) & "-" &_
      AppendLeadingZero(Month(Value), 2) & "-" &_
      AppendLeadingZero(Day(Value), 2) & "T" &_
      AppendLeadingZero(Hour(Value), 2) & ":" &_
      AppendLeadingZero(Minute(Value), 2) & ":" &_
      AppendLeadingZero(Second(Value), 2)
  else
    FormatDateTime = ""
  end if
end function

private function BuildGetDocumentsRequest(RegistrationNumber, RegistrationDateFrom, RegistrationDateTo)
  set BuildGetDocumentsRequest = CreateObject(XMLDocumentProgID)
  with BuildGetDocumentsRequest
    set .documentElement = .createElement("soapenv:Envelope")
    .documentElement.setAttribute "xmlns:soapenv", "http://schemas.xmlsoap.org/soap/envelope/"
    .documentElement.setAttribute "xmlns:tem", "http://tempuri.org/"
    .documentElement.appendChild(.createElement("soapenv:Header"))

    set LParams = .documentElement. _
      appendChild(.createElement("soapenv:Body")). _
      appendChild(.createElement("tem:GetDocuments"))

    if Len(RegistrationNumber) > 0 then
      LParams.appendChild(.createElement("tem:registrationNumber"))_
        .appendChild(.createTextNode(RegistrationNumber))
    end if
    if Len(RegistrationDateFrom) > 0 then
      LParams.appendChild(.createElement("tem:registrationDateFrom")).appendChild(_
        .createTextNode(FormatDateTime(RegistrationDateFrom)))
    end if
    if Len(RegistrationDateTo) > 0 then
      LParams.appendChild(.createElement("tem:registrationDateTo")).appendChild(_
        .createTextNode(FormatDateTime(RegistrationDateTo)))
    end if
  end with
end function

private function BuildGetDocumentImageRequest(ID)
  set BuildGetDocumentImageRequest = CreateObject(XMLDocumentProgID)
  with BuildGetDocumentImageRequest
    set .documentElement = .createElement("soapenv:Envelope")
    .documentElement.setAttribute "xmlns:soapenv", "http://schemas.xmlsoap.org/soap/envelope/"
    .documentElement.setAttribute "xmlns:tem", "http://tempuri.org/"
    .documentElement.appendChild(.createElement("soapenv:Header"))

    set LParams = .documentElement. _
      appendChild(.createElement("soapenv:Body")). _
      appendChild(.createElement("tem:GetDocumentImages"))

    LParams.appendChild(.createElement("tem:documentId"))_
      .appendChild(.createTextNode(ID))
    LParams.appendChild(.createElement("tem:loadContent"))_
      .appendChild(.createTextNode("true"))
  end with
end function

private function LoadDocument(Data)
  if Silent then
    DebugString "LoadDocument:" & vbNewLine & Data.ToString("UTF-8")
  end if

  set LoadDocument = CreateObject(XMLDocumentProgID)
  with LoadDocument
    .validateOnParse = false 'xsi namespace: i:nil="true"
    .load Data
    if .parseError.errorCode <> 0 then
      Err.Raise vbObjectError + 10000, "LoadDocument", "Response parse error: " & .parseError.reason
    end if
    .setProperty "SelectionNamespaces", _
      "xmlns:a='http://schemas.datacontract.org/2004/07/Croc.FDA.SEDD.Services.BuilderIntergation'"
  end with
end function

private function PutDocumentToBuffer(Provider, Document)
  StoredProc.StoredProcName = "P_SELECTLIST_GENIDENT"
  StoredProc.ExecProc
  PutDocumentToBuffer = StoredProc.ParamByName("nIDENT").Value

  StoredProc.StoredProcName = "P_FILE_BUFFER_INSERT"
  StoredProc.ParamByName("nIDENT").Value = PutDocumentToBuffer

  LTempFileName = Provider.CreateTempFileName(".xml")
  Document.Save LTempFileName

  StoredProc.ParamByName("cDATA").LoadFromFile LTempFileName, ftOraClob

  GetFileSystem.DeleteFile LTempFileName

  StoredProc.ExecProc
end function

private function GetSelectedDocuments
  LRN = ""
  for I = 0 to GetDocumentCount - 1
    LRN = LRN & GetDocument(I) & ";"
  next
  LRN = Left(LRN, Len(LRN) - 1)
  GetSelectedDocuments = LRN
end function

private function BuildResponseData(Provider, Document)
  LData = ""
  set LItems = Document.selectNodes("//a:Document")
  for each LItem in LItems
    LData = LData & "{"
    set LNodes = LItem.childNodes
    for each LNode in LNodes
      LData = LData & Replace(LNode.nodeName, "a:", "") & ": """ & Provider.JSONEscape(LNode.text) & ""","
    next
    LData = Left(LData, Len(LData) - 1) & "},"
  next
  if Len(LData) > 0 then
    LData = Left(LData, Len(LData) - 1)
  end if

  LBufferRN = PutDocumentToBuffer(Provider, Document)

  BuildResponseData = _
    "{" &_
     "startup: function (){" &_
       "(new parus.dictionaryDialog({" &_
         "title: 'Выбор документа'," &_
         "multiselect: true," &_
         "keyField: 'ObjectID'," &_
         "columns: [{" &_
           "name: 'Регистрационный номер'," &_
           "field: 'RegNumber'," &_
           "width: '121px'" &_
         "}," &_
         "{" &_
           "name: 'Дата регистрации'," &_
           "field: 'RegDate'," &_
           "width: '81px'," &_
           "formatter: function(value){" &_
             "d = dojo.date.stamp.fromISOString(value);" &_
             "return d ? dojo.date.locale.format(d, {selector: 'date', datePattern: 'dd.MM.yyyy'}) : null;" &_
           "}" &_
         "}," &_
         "{" &_
           "name: 'Тип документа'," &_
           "field: 'DocType'," &_
           "width: '150px'" &_
         "}," &_
         "{" &_
           "name: 'Краткое содержимое'," &_
           "field: 'ShortContent'," &_
           "width: '350px'" &_
         "}]," &_
         "gridPersistent: new dojo.data.ItemFileWriteStore({" &_
           "data: {" &_
             "items: [" & LData & "]" &_
           "}" &_
         "})," &_
         "onApply: function(){" &_
           "parus.balance.executeUserApplication(" &_
             "'" & GAttachDocumentActionRN & "','" & GetSelectedDocuments & "','" & UNITCODE & "'," &_
             "{" &_
               "P" & GAttachDocumentSelectedParamRN & ": this.getValue(), " &_
               "P" & GAttachDocumentDocumentParamRN & ": '" & LBufferRN & "'" &_
             "}," &_
             "'" & PARENT_UNITCODE & "','" & PARENT_DOCUMENT & "','" & CATALOG & "');" &_
           "return true;" &_
         "}" &_
       "})).show();" &_
     "}" &_
   "}"
end function

private function GetPostContentTypeAndSoapAction(Action)
  GetPostContentTypeAndSoapAction =_
    "text/xml;charset=UTF-8" & vbNewLine &_
    "SOAPAction: ""http://tempuri.org/IBuilderIntergationService/" & Action & """"
end function

sub AskForDocument
  LURL = GetOptionStrValue("BalanceOnlineWebServiceIntegURL_CROC", "URL взаимодействия с внешним веб-сервисом", True)
  ParseURL LURL, LHost, LHandler

  GAttachDocumentActionRN = GetActionRN("WebServicesIntegrationCROC", "AttachDocuments")
  GAttachDocumentSelectedParamRN = GetActionParamRN(GAttachDocumentActionRN, "SELECTEDDOCUMENTS")
  GAttachDocumentDocumentParamRN = GetActionParamRN(GAttachDocumentActionRN, "SOURCEDOCUMENT")

  set LRequest = BuildGetDocumentsRequest(GetParamValue("RegistrationNumber"), _
    GetParamValue("RegistrationDateFrom"), GetParamValue("RegistrationDateTo"))

  set LProvider = CreateObject("ParusAppServerProvider.Provider")

  LErrorNumber = 0
  LErrorDescription = ""
  On Error Resume Next
    set LResponse = LProvider.DownloadData(LHost, LHandler, CLogin, CPassword, true, _
      LRequest, GetPostContentTypeAndSoapAction("GetDocuments"), false, false, false, CTimeOut)

    LIsTimedOut = false
    if Err.Number = 0 then
      if StrComp(Trim(LResponse.ToString("UTF-8")), "HTTP/1.1 504 Gateway Time-out", vbTextCompare) = 0 then
        LIsTimedOut = true
        LErrorNumber = vbObjectError + 10000
      end if
    else
      LErrorNumber = Err.Number
      LErrorDescription = Err.Description
      LIsTimedOut = (StrComp(Err.Description, "Cannot initiate intercommunication with remote server. Please, check provided address information.", vbTextCompare) = 0) _
        or (StrComp(Err.Description, "Невозможно инициировать взаимодействие с удаленным сервером. Пожалуйста, проверьте информацию об адресе.", vbTextCompare) = 0)
    end if
    if LIsTimedOut then
      LErrorDescription = "Превышено максимальное время ожидания ответа внешнего веб-сервиса." & vbNewLine & _
        "Попробуйте уточнить параметры отбора документов."
    end if
  On Error Goto 0
  if LErrorNumber <> 0 then
    Err.Raise LErrorNumber, "AskForDocument", LErrorDescription
  end if

  set LResponse = LoadDocument(LResponse)

  if Silent then
    Response.data = BuildResponseData(LProvider, LResponse)
    Response.handleAs = "json"
  else
    LFileName = LProvider.CreateTempFileName(".xml")
    LResponse.save LFileName
    MsgBox "Полученный xml документ сохранен в """ & LFileName & """."
  end if
end sub

private function GetNodeValue(ParentNode, Name)
  set LNode = ParentNode.selectSingleNode(Name)
  if not LNode is Nothing then
    GetNodeValue = LNode.text
  else
    GetNodeValue = ""
  end if
end function

private function GetIsoDateValue(Value)
  GetIsoDateValue = Value
  LPos = InStr(GetIsoDateValue, "T")
  if LPos <> 0 then
    GetIsoDateValue = Left(GetIsoDateValue, LPos - 1)
  end if
end function

private function GetFileSystem
  if IsEmpty(GFileSystem) then
    set GFileSystem = CreateObject("Scripting.FileSystemObject")
  end if
  set GetFileSystem = GFileSystem
end function

private function GetFileLinkCatalogRN(Name)
  StoredProc.StoredProcName = "FIND_ACATALOG_NAME_EX"
  StoredProc.ParamByName("NFLAG_SMART").Value = "0"
  StoredProc.ParamByName("NFLAG_OPTION").Value = "0"
  StoredProc.ParamByName("nCOMPANY").Value = COMPANY
  StoredProc.ParamByName("nVERSION").Value = Null
  StoredProc.ParamByName("sUNITCODE").Value = "FileLinks"
  StoredProc.ParamByName("sNAME").Value = Name
  StoredProc.ExecProc
  GetFileLinkCatalogRN = StoredProc.ParamByName("nRN").Value
end function

private function GetNextCode
  Query.SQL.Text = "select GET_FILELINKS_NEXTNUMB(:NCOMPANY, NULL) as Code from dual"
  Query.ParamByName("NCOMPANY").Value = COMPANY
  Query.Open
  GetNextCode = Query.Fields(0).Value
end function

private function GetFileTypeContentType(Extension)
  StoredProc.StoredProcName = "P_FLINKTYPES_GET_PARAM"
  StoredProc.ParamByName("nCOMPANY").Value = COMPANY
  StoredProc.ParamByName("sCODE").Value = Extension
  StoredProc.ExecProc
  GetFileTypeContentType = StoredProc.ParamByName("nCONTENT_TYPE").Value
end function

private sub GetSourceDocumentInfo(SourceDocument, ID, DocType, RegDate, RegNumber, ShortContent)
  set LNode = SourceDocument.selectSingleNode("//a:Document[a:ObjectID='" & ID & "']")
  if LNode is Nothing then
    Err.Raise vbObjectError + 10000, "GetSourceDocumentInfo", "Исходный документ не найден """ & ID & """."
  end if
  DocType = GetNodeValue(LNode, "a:DocType")
  RegDate = GetIsoDateValue(GetNodeValue(LNode, "a:RegDate"))
  RegNumber = GetNodeValue(LNode, "a:RegNumber")
  ShortContent = GetNodeValue(LNode, "a:ShortContent")
end sub

private function AppendFiles(Provider, FileLinksCatalog, ID, SourceDocument, ImageDocument)
  set LData = Provider.createBinaryData

  GetSourceDocumentInfo SourceDocument, ID, LDocType, LRegDate, LRegNumber, LShortContent

  set LItems = ImageDocument.selectNodes("//a:DocumentImage")
  for each LItem in LItems
    LFileName = GetNodeValue(LItem, "a:Name")
    LExtension = UCase(GetFileSystem.GetExtensionName(LFileName))
    LTempFileName = Provider.CreateTempFileName(LExtension)
    LData.fromBase64(GetNodeValue(LItem, "a:Content"))
    LData.save LTempFileName

    if Len(GDefaultFileType) > 0 then
      LFileType = GDefaultFileType
    else
      LFileType = LExtension
    end if

    LContentType = GetFileTypeContentType(LFileType)

    for I = 0 to GetDocumentCount - 1
      StoredProc.StoredProcName = "P_FILELINKS_INSERT_EX"

      StoredProc.ParamByName("nCOMPANY").Value = COMPANY
      StoredProc.ParamByName("nCRN").Value = FileLinksCatalog
      StoredProc.ParamByName("sUNITCODE").Value = UNITCODE

      StoredProc.ParamByName("sFILE_PATH").Value = LFileName
      StoredProc.ParamByName("sFILE_TYPE").Value = LFileType

      if LContentType = 0 then
        StoredProc.ParamByName("bTEMPLATE").LoadFromFile LTempFileName, ftOraBlob
        StoredProc.ParamByName("cTEMPLATE").Value = Null
      else
        StoredProc.ParamByName("bTEMPLATE").Value = Null
        StoredProc.ParamByName("cTEMPLATE").LoadFromFile LTempFileName, ftOraClob
      end if

      StoredProc.ParamByName("sNOTE").Value = Left(_
        "Регистрационный номер: " & LRegNumber & vbNewLine &_
        "Дата регистрации: " & LRegDate & vbNewLine &_
        "Краткое содержимое: " & LShortContent, _
        240) 'NOTE varchar2(240)

      StoredProc.ParamByName("sCODE").Value = GetNextCode
      StoredProc.ParamByName("nTABLE_PRN").Value = GetDocument(I)

      StoredProc.ExecProc
    next

    GetFileSystem.DeleteFile LTempFileName
  next
end function

private function GetSourceDocument(Provider)
  LTempFileName = Provider.CreateTempFileName(".xml")
  set GetSourceDocument = GetParamObject("SourceDocument")
  GetSourceDocument.SaveToFile LTempFileName

  set GetSourceDocument = Provider.CreateBinaryData
  GetSourceDocument.load LTempFileName

  set GetSourceDocument = LoadDocument(GetSourceDocument)
  GetFileSystem.DeleteFile LTempFileName
end function

sub AttachDocuments
  LURL = GetOptionStrValue("BalanceOnlineWebServiceIntegURL_CROC", "URL взаимодействия с внешним веб-сервисом", True)
  ParseURL LURL, LHost, LHandler

  GDefaultFileType = GetOptionStrValue("BalanceOnlineWebServiceIntegFlType_CROC", "", False)

  LFileLinksCatalogRN = GetFileLinkCatalogRN(GetOptionStrValue(_
    "BalanceOnlineWebServiceIntegCatalog_CROC", "Каталог для хранения присоединенных документов при взаимодействия с внешним веб-сервисом", True))

  set LProvider = CreateObject("ParusAppServerProvider.Provider")
  set LSourceDocument = GetSourceDocument(LProvider)

  LIDs = Split(GetParamValue("SelectedDocuments"), ";")
  for each LID in LIDs
    set LResponse = LProvider.DownloadData(LHost, LHandler, CLogin, CPassword, true, _
      BuildGetDocumentImageRequest(LID), GetPostContentTypeAndSoapAction("GetDocumentImages"), false, false, false, CTimeOut)

    AppendFiles LProvider, LFileLinksCatalogRN, LID, LSourceDocument, LoadDocument(LResponse)
  next

  if Silent then
    Message "Загрузка документов завершена."
  else
    MsgBox "Загрузка документов завершена."
  end if
end sub