При загрузке данных в Excel с веб-страниц порой оказывается, что некоторая необходимая нам информация (например, адреса электронной почты) представлена в графическом виде (текст на картинке).
Нам же, в таблице Excel, необходимо получить ту же информацию, но в текстовом виде, - т.е. каким-то образом распознать текст, изображенный на картинке.
Для этих целей существуют специальные OCR-программы (например, ABBYY FineReader, CuneiForm и т.д.), а также онлайн-сервисы (платные и бесплатные)
Поскольку нам в макросе надо распознать лишь несколько простеньких изображений, не имеет смысла устанавливать на компьютер специализированную программу OCR, - особенно с учётом того, что она стоит много денег.
Поэтому для нашей задачи мы воспользуемся бесплатным онлайн-сервисом newocr.com
Итак, изначально у нас имеется ссылка вида "http://site.ru/filename.jpeg", по которой доступна для загрузки картинка с необходимым нам текстом.
Воспользуемся функцией newOCR, чтобы получить текст с этой картинки:
Sub testOCR()
link$ = "http://autotransinfo.ru/img/46e0afd12df90e69efdc931c504f24e416135037.jpeg"
Text$ = newOCR(link$)
MsgBox "Результат: " & Text$
End Sub
Код функции newOCR:
Function newOCR(ByVal link As String) As String
On Error Resume Next
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "http://www.newocr.com/"
While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
Set IEdoc = IE.document
IE.document.getElementById("url").value = link ' вставляем ссылку на изображение
IE.document.getElementById("language").value = "eng" ' выбираем язык распознавания
IE.document.getElementById("preview").Click ' нажимаем предпросмотр
While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
Err.Raise 555: Dim n As Long
While Err > 0 And n < 10000 ' ждём, пока не появится кнопка ЩСК
Err.Clear: DoEvents: n = n + 1
IE.document.getElementById("ocr").Click ' жмём кнопку OCR
Wend
While IE.Busy Or (IE.readyState <> 4): DoEvents: Wend
Err.Raise 555: n = 0
While Err > 0 And n < 100000 ' ждём, пока не появится результат распознавания
Err.Clear: DoEvents: n = n + 1
newOCR = IE.document.getElementById("textarea").value ' читаем результат
Wend
IE.Quit
End Function
PS: Функция тестировалась на картинках, содержащих адреса почты.
Пример такой картинки:
Второй вариант функции - с использованием онлайн сервиса sciweavers.org
(кстати, функция onlineOCR работает быстрее предыдущей, но, увы, ошибок распознавания вроде бы больше)
Sub test_onlineOCR()
link$ = "http://autotransinfo.ru/img/46e0afd12df90e69efdc931c504f24e416135037.jpeg"
Text$ = onlineOCR(link$)
Debug.Print "Результат: " & Text$
End Sub
Function onlineOCR(ByVal link As String) As String
On Error Resume Next
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
xmlhttp.Open "POST", "http://www.sciweavers.org/process_form_i2ocr", "False"
xmlhttp.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" ' чтобы избежать кеширования
Dim POST() As Byte, PostData$
PostData = PostData & "i2ocr_options=" & RussianStringToURLEncode("url")
PostData = PostData & "&i2ocr_uploadedfile=" & RussianStringToURLEncode(link)
PostData = PostData & "&i2ocr_url=" & RussianStringToURLEncode(link)
PostData = PostData & "&i2ocr_languages=" & RussianStringToURLEncode("gb")
POST = StrConv(PostData, vbFromUnicode)
xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xmlhttp.send (POST): DoEvents
If Val(xmlhttp.Status) <> 200 Then Exit Function
URL2$ = Split(xmlhttp.responsetext, "$.get(""/")(1)
URL2$ = "http://www.sciweavers.org/" & Split(URL2$, """, function")(0)
xmlhttp.Open "GET", URL2$, "False": xmlhttp.send: DoEvents
If Val(xmlhttp.Status) = 200 Then onlineOCR = xmlhttp.responsetext
Set xmlhttp = Nothing
End Function
Как выяснилось в результате тестирования функции onlineOCR (а тестирование проводилось на сотнях картинок типа вышеприведённой),
она хоть и работает значительно быстрее и стабильнее, но результат распознавания нельзя назвать удовлетворительным.
OnlineOCR путает такие символы, как 1, l, I, | (единица, строчная L, прописная i, вертикальная черта)
В то же время, функция newOCR работает медленно, и порой прекращает работать после нескольких распознаваний.
(требуется доработка кода - судя по всему, обращения выполняются слишком часто, и сервер даёт отказ, предлагая подождать несколько секунд)
Сделал сравнение результатов работы 2 этих онлайн-сервисов OCR:
На скриншоте зеленым помечены правильно распознанные адреса электронной почты, красным - распознанные с ошибками.
Обратите внимание - первый адрес оба сервиса распознали ошибочно (поставили ноль вместо буквы O)
Комментарии
Отправить комментарий