Помогите, пожалуйста! Проблемы: 1) на сайте Минфина висит pdf файл со списком банков: Перечень банков Было бы здорово иметь макрос, который формирует на листе книги столбцы как в указанном файле. Данный список потребуется иногда обновлять. 2) возможно ли написать второй макрос, который бы брал наименование банка из листи книги из пункта№1, вбивал в input-поле "Наименование банка-гаранта" на другом сайте: Наименование банка-гаранта , где поиск выдает информацию по банку: в самом верху страницы-ответа есть поле "Всего записей: 81", необходимо выцепитьэтот номер (здесь 81) и вставить в книгу в строку соответствующего банка. Преграда тут еще в том, что для поиска на сайте: Наименование банка-гаранта необходимо, чтобы название в input-поле выбиралось из справочника. Для этого наименование банка из пункта один для вставки в input-поле должно быть укорочено до символов в кавычках (насколько я понимаю).
Заранее спасибо за Ваше время и внимание!
Помогите, пожалуйста! Проблемы: 1) на сайте Минфина висит pdf файл со списком банков: Перечень банков Было бы здорово иметь макрос, который формирует на листе книги столбцы как в указанном файле. Данный список потребуется иногда обновлять. 2) возможно ли написать второй макрос, который бы брал наименование банка из листи книги из пункта№1, вбивал в input-поле "Наименование банка-гаранта" на другом сайте: Наименование банка-гаранта , где поиск выдает информацию по банку: в самом верху страницы-ответа есть поле "Всего записей: 81", необходимо выцепитьэтот номер (здесь 81) и вставить в книгу в строку соответствующего банка. Преграда тут еще в том, что для поиска на сайте: Наименование банка-гаранта необходимо, чтобы название в input-поле выбиралось из справочника. Для этого наименование банка из пункта один для вставки в input-поле должно быть укорочено до символов в кавычках (насколько я понимаю).
В текстовике 2 шага обмена с сервером. Для обмена используйте объект MSXML2.XMLHTTP. Получите конечную ссылку,вставляйте в браузер. Но можно получить при помощи MSXML2.XMLHTTP текст страницы и регулярками распарсить
В текстовике 2 шага обмена с сервером. Для обмена используйте объект MSXML2.XMLHTTP. Получите конечную ссылку,вставляйте в браузер. Но можно получить при помощи MSXML2.XMLHTTP текст страницы и регулярками распарситьdoober
doober, Спасибо за помощь, однако у меня не получилось пока. Правильно ли я понял, что через вызов функции можно получить текст, который нужно распарсить и полученное "наименование по справочнику" снова вставить в цикл поиска? Не подскажите, как получить такой txt как у Вас прикреплен?
doober, Спасибо за помощь, однако у меня не получилось пока. Правильно ли я понял, что через вызов функции можно получить текст, который нужно распарсить и полученное "наименование по справочнику" снова вставить в цикл поиска? Не подскажите, как получить такой txt как у Вас прикреплен?rosko
doober, Спасибо) Скажите, пожалуйста, зачем добавленные функции, в частности "Readjson(s)", если они работают на ссылках из сообщения №3? Очевидно, я просто не способен понять. Тем не менее, полностью разобрал Ваши дополнения. Поправьте, пожалуйста, если неправ: макрос zakupki() вызывает функцию RussianStringToURLEncode, которая кодирует русскоязычное наименование в понятное сайту. Далее это закодированное наименование передается в функцию GetHTTPResponse, которая возвращает ответ сайта (Json). Далее Json передается функции Readjson (вот тут тупик понимания: мы получаем Url, а ведь можно распарсить Pattern и взять наименование "по справочнику", а уже дальше выполнить изначальный макрос из сообщения №1, нет?)
doober, Спасибо) Скажите, пожалуйста, зачем добавленные функции, в частности "Readjson(s)", если они работают на ссылках из сообщения №3? Очевидно, я просто не способен понять. Тем не менее, полностью разобрал Ваши дополнения. Поправьте, пожалуйста, если неправ: макрос zakupki() вызывает функцию RussianStringToURLEncode, которая кодирует русскоязычное наименование в понятное сайту. Далее это закодированное наименование передается в функцию GetHTTPResponse, которая возвращает ответ сайта (Json). Далее Json передается функции Readjson (вот тут тупик понимания: мы получаем Url, а ведь можно распарсить Pattern и взять наименование "по справочнику", а уже дальше выполнить изначальный макрос из сообщения №1, нет?)rosko
rosko,вы все правильно поняли. Для того.что бы получить необходимую страницу с данными(ссылку на нее),необходимо на сервер передать некоторые параметры.Банки хранятся в базе сайта под числовыми ID,наименование второстепенно. Когда вы в справочнике выбираете банк,то скрипт в переменную пишет ИД,вы видите только наименование. Я до конца не знаю вашей задачи,но все можно взять без браузера Посмотрите в сторону работы с закупками по FTP.Все эти данные там есть. PS:Не люблю работать через браузер
rosko,вы все правильно поняли. Для того.что бы получить необходимую страницу с данными(ссылку на нее),необходимо на сервер передать некоторые параметры.Банки хранятся в базе сайта под числовыми ID,наименование второстепенно. Когда вы в справочнике выбираете банк,то скрипт в переменную пишет ИД,вы видите только наименование. Я до конца не знаю вашей задачи,но все можно взять без браузера Посмотрите в сторону работы с закупками по FTP.Все эти данные там есть. PS:Не люблю работать через браузерdoober
doober, замечательно, что я не ошибался) задача в том, чтобы пройти это заполнение по справочнику, щелкнуть поиск и выцепить код страницы-ответа поиска. С последней просто взять число гарантий, выданных соответствующим банком. Я пробовал в нижеуказанной функции распарсить Pattern: [vba]
Код
Function Readjson(ByVal url As String) As String bRes = False Set objRegExp = CreateObject("VBScript.RegExp") objRegExp.Global = True objRegExp.IgnoreCase = True objRegExp.Pattern = "name"":""(.+?)"",""fz94id"":(\d+),(.+?)""cpz"":""(\d+)""," bRes = objRegExp.test(url) If bRes Then Set objMatches = objRegExp.Execute(url) For i = 0 To objMatches.Count - 1 Set objMatch = objMatches.Item(i) Next End If bbname = objMatches.Item(1) Readjson = url End Function
[/vba] Однако ругается на строку: (ошибка invalid procedure call or argument) [vba]
Код
bbname = objMatches.Item(1)
[/vba]
doober, замечательно, что я не ошибался) задача в том, чтобы пройти это заполнение по справочнику, щелкнуть поиск и выцепить код страницы-ответа поиска. С последней просто взять число гарантий, выданных соответствующим банком. Я пробовал в нижеуказанной функции распарсить Pattern: [vba]
Код
Function Readjson(ByVal url As String) As String bRes = False Set objRegExp = CreateObject("VBScript.RegExp") objRegExp.Global = True objRegExp.IgnoreCase = True objRegExp.Pattern = "name"":""(.+?)"",""fz94id"":(\d+),(.+?)""cpz"":""(\d+)""," bRes = objRegExp.test(url) If bRes Then Set objMatches = objRegExp.Execute(url) For i = 0 To objMatches.Count - 1 Set objMatch = objMatches.Item(i) Next End If bbname = objMatches.Item(1) Readjson = url End Function
[/vba] Однако ругается на строку: (ошибка invalid procedure call or argument) [vba]
последний вопрос по этой теме( если число "всего записей: .." выглядит так : "Всего записей: более 2100" - как у Уралсиба можно ли это учесть, ибо выдает 1 на лист
последний вопрос по этой теме( если число "всего записей: .." выглядит так : "Всего записей: более 2100" - как у Уралсиба можно ли это учесть, ибо выдает 1 на листrosko
doober, да вот даже сторонние программы запрещены все ссылки макроса доступные и работают, если их вызывать не пойму, в чем преграда( прокси попробую прописать
doober, да вот даже сторонние программы запрещены все ссылки макроса доступные и работают, если их вызывать не пойму, в чем преграда( прокси попробую прописатьrosko
doober, при пошаговой отладке код останавливается в данной функции: [vba]
Код
Function GetHTTPResponse(ByVal sURL As String, oXMLHTTP) As String 'On Error Resume Next Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") With oXMLHTTP .Open "GET", sURL, False .send GetHTTPResponse = .responseText End With ' Set oXMLHTTP = Nothing End Function
[/vba] а именно,после строки [vba]
Код
.send
[/vba]: Если взять переменную sUrl из строки выше обрыва, вставить в watch window и запустить ответную ссылку в браузер, то вроде работает
doober, при пошаговой отладке код останавливается в данной функции: [vba]
Код
Function GetHTTPResponse(ByVal sURL As String, oXMLHTTP) As String 'On Error Resume Next Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") With oXMLHTTP .Open "GET", sURL, False .send GetHTTPResponse = .responseText End With ' Set oXMLHTTP = Nothing End Function
[/vba] а именно,после строки [vba]
Код
.send
[/vba]: Если взять переменную sUrl из строки выше обрыва, вставить в watch window и запустить ответную ссылку в браузер, то вроде работаетrosko
Сообщение отредактировал rosko - Пятница, 14.08.2015, 14:09
rosko, по первому вопросу из 1 поста: зачем pdf, если у минфина есть опендата 7710168360-BanksID? в файле сделал несколько вариантов получения списка банков + на основе кода doober сделал еще 1 вариант получения закупок, если при первом запросе (выбор из справочника) возвращается >1 значения, выпадает форма для выбора нужного, выбор двойным тыком на форме контрол MSFlexgird, если у вас он не установлен, работать не будет, в архиве msflxgrd_ocx.zip нужные файлы, копируем в system32 (если x64 - в syswow64) и запускаем install_msflxgrd
rosko, по первому вопросу из 1 поста: зачем pdf, если у минфина есть опендата 7710168360-BanksID? в файле сделал несколько вариантов получения списка банков + на основе кода doober сделал еще 1 вариант получения закупок, если при первом запросе (выбор из справочника) возвращается >1 значения, выпадает форма для выбора нужного, выбор двойным тыком на форме контрол MSFlexgird, если у вас он не установлен, работать не будет, в архиве msflxgrd_ocx.zip нужные файлы, копируем в system32 (если x64 - в syswow64) и запускаем install_msflxgrdkrosav4ig
Sub banksID_JSON_REGEX() With CreateObject("msxml2.xmlhttp") .Open "get", "http://skad.minfin.ru:8081/OpenDataAPI/api/json/dataset/7710168360-BanksID/version/0/content", 0 .send Dim s$: s = .responsetext End With With CreateObject("VBScript.RegExp") .Global = True .Pattern = "([^\\])""+|\\": s = .Replace(s, "$1") .Pattern = ",?f\d:": s = .Replace(s, Chr(9) & "@") .Pattern = "\[\{|},{|\}\]": s = .Replace(s, vbLf) .Pattern = "([\n\r])+\t?|": s = .Replace(s, "$1") .Pattern = "(\d{4}-\d{2}-\d{2})T(\d{2})": s = .Replace(s, "$1 $2") End With With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText Mid(s, 2, Len(s) - 2): .PutInClipboard End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("Json+RegEx").ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete .Parent.Activate: .HeaderRowRange(2, 1).Activate .Parent.PasteSpecial Format:="Текст" .HeaderRowRange = Array("ikb", "name", "ikbstatus", "statusdate") .DataBodyRange.Replace "@", Empty, xlPart End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 End Sub Sub banksID_JSON_SC() Dim s$ With CreateObject("msxml2.xmlhttp") .Open "get", "http://skad.minfin.ru:8081/OpenDataAPI/api/json/dataset/7710168360-BanksID/version/0/content", 0 .send s = .responsetext End With With CreateObject("ScriptControl") .Language = "JScript" .AddCode "function getSentenceCount(){return obj.length;}" .AddCode "function getSentence(i){return obj[i];}" .Eval "var obj=(" & s & ")" Dim n&: n = .Run("getSentenceCount") - 1 Dim i& Dim arr ReDim arr(0 To n, 0 To 3) For i = 0 To n With .Run("getSentence", i) arr(i, 0) = .f1: arr(i, 1) = .f2 arr(i, 2) = .f3: arr(i, 3) = Replace(.f4, "T", " ") End With Next i End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("Json+ScriptControl").ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete .HeaderRowRange(2, 1).Resize(n + 1, 4).Value = arr End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 End Sub Sub banksID_xml() With Sheets("xml") .QueryTables(1).Refresh 0 .Parent.XmlMaps("Banks_карта").Import URL:=.[G16] End With End Sub Sub banksID_Web() Application.EnableEvents = 0 Sheets("Web").QueryTables(1).Refresh 0 Application.EnableEvents = 1 End Sub Sub banksID_JSON_PQ() ThisWorkbook.Connections("Power Query - Запрос1").Refresh End Sub
[/vba]
[vba]
Код
Public FG As MSFlexGridLib.MSFlexGrid, n&, r& Dim bank$, sc As Object, oXMLHTTP As Object Sub init() Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") Set sc = CreateObject("ScriptControl") With sc .Language = "JScript" .AddCode "function getSentenceCount(){return obj.result.length;}" .AddCode "function getSentence(i){return obj.result[i];}" .AddCode "function encode(str) {return encodeURIComponent(str);}" End With End Sub Function RussianStringToURLEncode(ByVal bank_name As String) As String RussianStringToURLEncode = sc.Run("encode", bank_name) End Function Function GetHTTPResponse(ByVal sURL As String) As String On Error Resume Next With oXMLHTTP .Open "GET", sURL, False .send GetHTTPResponse = .responsetext End With End Function Function Readjson(s) As String Dim URL As String, itm As Object, k&, str$ ',name With sc .Eval "var obj=(" & s & ")" n = .Run("getSentenceCount") If n > 1 Then UserForm1.Hide FG.TextMatrix(0, 0) = bank Do FG.TextMatrix(k + 1, 0) = .Run("getSentence", k).name k = k + 1 Loop While k < n UserForm1.Show Set FG = Nothing End If If n Then With .Run("getSentence", r) URL = "http://zakupki.gov.ru/epz/bankguarantee/extendedsearch/search.html?bankSearchItem.title=" & _ RussianStringToURLEncode(.name) & "&bankSearchItem.code=" & .cpz & "&bankSearchItem.fz94id=" _ & .fz94id & "&bankSearchItem.fz223id=" & .fz223id End With End If End With Readjson = URL End Function Function zakupki(банк As String) Application.Volatile 0 Dim json As String, URL As String bank = банк Call init With CreateObject("VBScript.RegExp") .Global = True .Pattern = "[^\""]*\""(.*)\""[^\""]*" банк = RussianStringToURLEncode(IIf(.test(банк), .Replace(банк, "$1"), банк)) End With json = GetHTTPResponse("http://zakupki.gov.ru/epz/organization/chooseOrganization/autocompleteReturnsCodes.html?term=" & банк & "&placeOfSearch=&organizationType=BANKS") URL = Readjson(json) zakupki = Readtotal(GetHTTPResponse(URL)) Set oXMLHTTP = Nothing Set sc = Nothing End Function Function Readtotal(ByVal s As String) As Integer Dim arr If Len(s) Then With CreateObject("htmlfile") .write Replace(s, "class", "id") arr = Split(Replace(Replace(.getElementByid("allRecords").innerhtml, "<", " "), "-", " "), " ") With Application Readtotal = .Max(.IfError(.Round(arr, 0), 0)) End With End With End If End Function
[/vba]
[vba]
Код
Sub banksID_JSON_REGEX() With CreateObject("msxml2.xmlhttp") .Open "get", "http://skad.minfin.ru:8081/OpenDataAPI/api/json/dataset/7710168360-BanksID/version/0/content", 0 .send Dim s$: s = .responsetext End With With CreateObject("VBScript.RegExp") .Global = True .Pattern = "([^\\])""+|\\": s = .Replace(s, "$1") .Pattern = ",?f\d:": s = .Replace(s, Chr(9) & "@") .Pattern = "\[\{|},{|\}\]": s = .Replace(s, vbLf) .Pattern = "([\n\r])+\t?|": s = .Replace(s, "$1") .Pattern = "(\d{4}-\d{2}-\d{2})T(\d{2})": s = .Replace(s, "$1 $2") End With With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") .SetText Mid(s, 2, Len(s) - 2): .PutInClipboard End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("Json+RegEx").ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete .Parent.Activate: .HeaderRowRange(2, 1).Activate .Parent.PasteSpecial Format:="Текст" .HeaderRowRange = Array("ikb", "name", "ikbstatus", "statusdate") .DataBodyRange.Replace "@", Empty, xlPart End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 End Sub Sub banksID_JSON_SC() Dim s$ With CreateObject("msxml2.xmlhttp") .Open "get", "http://skad.minfin.ru:8081/OpenDataAPI/api/json/dataset/7710168360-BanksID/version/0/content", 0 .send s = .responsetext End With With CreateObject("ScriptControl") .Language = "JScript" .AddCode "function getSentenceCount(){return obj.length;}" .AddCode "function getSentence(i){return obj[i];}" .Eval "var obj=(" & s & ")" Dim n&: n = .Run("getSentenceCount") - 1 Dim i& Dim arr ReDim arr(0 To n, 0 To 3) For i = 0 To n With .Run("getSentence", i) arr(i, 0) = .f1: arr(i, 1) = .f2 arr(i, 2) = .f3: arr(i, 3) = Replace(.f4, "T", " ") End With Next i End With Application.ScreenUpdating = 0: Application.EnableEvents = 0 With Sheets("Json+ScriptControl").ListObjects(1) If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete .HeaderRowRange(2, 1).Resize(n + 1, 4).Value = arr End With Application.ScreenUpdating = 1: Application.EnableEvents = 1 End Sub Sub banksID_xml() With Sheets("xml") .QueryTables(1).Refresh 0 .Parent.XmlMaps("Banks_карта").Import URL:=.[G16] End With End Sub Sub banksID_Web() Application.EnableEvents = 0 Sheets("Web").QueryTables(1).Refresh 0 Application.EnableEvents = 1 End Sub Sub banksID_JSON_PQ() ThisWorkbook.Connections("Power Query - Запрос1").Refresh End Sub
[/vba]
[vba]
Код
Public FG As MSFlexGridLib.MSFlexGrid, n&, r& Dim bank$, sc As Object, oXMLHTTP As Object Sub init() Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") Set sc = CreateObject("ScriptControl") With sc .Language = "JScript" .AddCode "function getSentenceCount(){return obj.result.length;}" .AddCode "function getSentence(i){return obj.result[i];}" .AddCode "function encode(str) {return encodeURIComponent(str);}" End With End Sub Function RussianStringToURLEncode(ByVal bank_name As String) As String RussianStringToURLEncode = sc.Run("encode", bank_name) End Function Function GetHTTPResponse(ByVal sURL As String) As String On Error Resume Next With oXMLHTTP .Open "GET", sURL, False .send GetHTTPResponse = .responsetext End With End Function Function Readjson(s) As String Dim URL As String, itm As Object, k&, str$ ',name With sc .Eval "var obj=(" & s & ")" n = .Run("getSentenceCount") If n > 1 Then UserForm1.Hide FG.TextMatrix(0, 0) = bank Do FG.TextMatrix(k + 1, 0) = .Run("getSentence", k).name k = k + 1 Loop While k < n UserForm1.Show Set FG = Nothing End If If n Then With .Run("getSentence", r) URL = "http://zakupki.gov.ru/epz/bankguarantee/extendedsearch/search.html?bankSearchItem.title=" & _ RussianStringToURLEncode(.name) & "&bankSearchItem.code=" & .cpz & "&bankSearchItem.fz94id=" _ & .fz94id & "&bankSearchItem.fz223id=" & .fz223id End With End If End With Readjson = URL End Function Function zakupki(банк As String) Application.Volatile 0 Dim json As String, URL As String bank = банк Call init With CreateObject("VBScript.RegExp") .Global = True .Pattern = "[^\""]*\""(.*)\""[^\""]*" банк = RussianStringToURLEncode(IIf(.test(банк), .Replace(банк, "$1"), банк)) End With json = GetHTTPResponse("http://zakupki.gov.ru/epz/organization/chooseOrganization/autocompleteReturnsCodes.html?term=" & банк & "&placeOfSearch=&organizationType=BANKS") URL = Readjson(json) zakupki = Readtotal(GetHTTPResponse(URL)) Set oXMLHTTP = Nothing Set sc = Nothing End Function Function Readtotal(ByVal s As String) As Integer Dim arr If Len(s) Then With CreateObject("htmlfile") .write Replace(s, "class", "id") arr = Split(Replace(Replace(.getElementByid("allRecords").innerhtml, "<", " "), "-", " "), " ") With Application Readtotal = .Max(.IfError(.Round(arr, 0), 0)) End With End With End If End Function