mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

OCR в Excel: макрос распознавания текста с картинки

При загрузке данных в 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:

сравнение работы онлайн-сервисов OCR

На скриншоте зеленым помечены правильно распознанные адреса электронной почты, красным - распознанные с ошибками.
Обратите внимание - первый адрес оба сервиса распознали ошибочно (поставили ноль вместо буквы O)

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Да, код открыт, - если делать макрос под заказ.

Вопрос о заказах макросов. Макрос Вы даёте с открытым кодом?

Касательно ПДФ - можно попробовать получить из него текст и без файнридера (если в файле ПДФ есть текстовый слой, - т.е. можно выделить текст в AdobeReader)
Код дать не смогу, - но можем сделать под заказ (у моего коллеги есть опыт получения текста из PDF)
C FineReader не работал ни разу, - так что тут ничего подсказать не могу.

Большое СПАСИБО за информацию. Подскажите, пожалуйста, как можно организовать подобным способом (т.е. автоматически через VBA) уже установленную FineReader? Имеется ФАЙЛ.pdf. Ассоциирован c AdobeReader. Не могу понять как этот файл сразу открыть в FR не меняя ассоциацию и заставить скинуть текст в VBA (ну или хотя бы просто открыть этот файл в FR). Заранее благодарен!

Добрый день!
В продолжение темы про OCR и потояннство кода - на сайте newOCR есть возможноть наладить распознование через пост запросы, при условии получения ключа они позволяют произоводить одно распознование в минуту, это мне кажется в полне нормально, вот только проблема в реализации формирования самого пост зарпоса через VBA код, т.к. там нужно указать тот самый ключ..И

(Пример на основе Вашего кода на сайт залил)

Sub ПримерОтправкиФайлаНаФайлообменник()
FileName$ = "путь к файлу/OCR.JPG"
URL$ = "http://api.newocr.com/v1/"

If Dir(FileName$, vbNormal) = "" Then ' проверяем наличие файла FileName$
MsgBox "Файл: " & FileName$ & " не найден", vbCritical, "Отправка файла невозможна!"
Exit Sub
End If

СсылкаНаЗагруженныйФайл = UploadFile(URL$, FileName$) ' пытаемся отправить файл

If Len(СсылкаНаЗагруженныйФайл) Then
MsgBox "Ссылка для скачивания: " & СсылкаНаЗагруженныйФайл, vbInformation, _
"Файл успешно загружен на файлообменник zalil.ru"
Else
MsgBox "Файл: " & FileName$, vbCritical, _
"Не удалось отправить файл на файлообменник zalil.ru"
End If
End Sub

Function UploadFile(ByVal DestURL As String, ByVal FileName As String) As String
Dim sFormData As String, d As String: On Error Resume Next

sFormData = GetFile(FileName) 'Get source file As a string.

FormData = "POST /v1/upload?key=" + ключ + " HTTP/1.1" + vbCrLf
FormData = FormData + "Host: api.newocr.com" + vbCrLf
Const Boundary As String = "---------------------------41184676334"

FormData = FormData + "Content-Type: multipart/form-data; boundary=" + Boundary + vbCrLf 'Build source form with file contents
FormData = FormData + "Content-Length: 29278" + vbCrLf + vbCrLf
FormData = FormData + "Content-Disposition: form-data; name=""" + sFormData + """;" + " filename=""" + Dir(FileName) + """" + vbCrLf
FormData = FormData + "Content-Type: image/jpeg" + vbCrLf
FormData = FormData + "(Binary data not shown)" + vbCrLf
FormData = FormData + "-----------------------------41184676334--"
MsgBox FormData

Dim WebBrowser: Set WebBrowser = CreateObject("InternetExplorer.Application") ' WebBrowser.Visible = True
'Send the form data To URL As POST request
Dim bFormData() As Byte: ReDim bFormData(Len(FormData) - 1)
bFormData = StrConv(FormData, vbFromUnicode)

WebBrowser.Navigate DestURL, , , bFormData '"Content-Type: multipart/form-data; boundary=" + Boundary + vbCrLf

Do While WebBrowser.Busy: DoEvents: Loop
UploadFile = WebBrowser.LocationURL: If UploadFile = DestURL Then UploadFile = ""
WebBrowser.Quit
End Function

Function GetFile(FileName As String) As String 'read binary file As a string value
' вспомогательная функция. Возвращает текстовую строку - файл FileName в юникоде
Dim FileContents() As Byte, FileNumber As Integer
ReDim FileContents(FileLen(FileName) - 1)
FileNumber = FreeFile
Open FileName For Binary As FileNumber
Get FileNumber, , FileContents
Close FileNumber
GetFile = StrConv(FileContents, vbUnicode)
End Function

Мы о разных методах работы. Ручками кликая на сайте, конечно подсунешь любой файл, но статья админа совсем не об этом, а об автоматизации этого процесса.

Мне кажется или первый сервис теперь движение мышки проверяет?

В чем проблема загрузки файла на первый сервис?
Зачем нужен сторонний url,когда сервис предлагает закачать любые файлы даже в формате типа pdf

Первый макрос устарел не очень сильно. Я разобрался, вместо
newOCR = ie.document.getElementById("ocr-result").value нужно использовать
newOCR = ie.document.getElementById("ocr-result").innerHtml

жаль не получается подсовывать свой локальный файл так как элемент
<@input type="file" name="userfile" id="userfile"/> имеет значение value только для чтения.
Придется отправлять файл сначала на сторонний УРЛ в сеть, а потом кидать этот УРЛ на форму.

Или есть решение?

Эти макросы очень давно устарели.
Сайты OCR так быстро меняются, что один сайт успели переделать, пока я писал и тестировал макрос)
Потом, когда макросы написал, один сайт переделали через 2 дня, второй - через месяц примерно.
Соответственно, оба макроса почти сразу перестали работать.

Самое сложное в этой задаче, - не код написать, а найти бесплатный, реально работающий, онлайн-сервис OCR

Скрипт немного устарел. Так например элемент страницы с текстом сейчас не
newOCR = IE.document.getElementById("textarea").value а
newOCR = ie.document.getElementById("ocr-result").Value

Заменил название, но результат пуст, хотя в отладке делаю ie.visible=true, (Вашу картинку кстати не распознает, я закидываю другой файл) вижу что сканирование произошло, а в переменную newOCR все равно ничего не попадает. Наверное нельзя вот так "в лоб" обратится к элементу страницы с текстом, нужен какой-то перебор в цикле, но у самого пока не получается.

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
         ____   __   __   ____   _       _   
___ / ___| \ \ / / / ___| | | | |_
/ _ \ \___ \ \ V / | | _ | | | __|
| __/ ___) | | | | |_| | | |___ | |_
\___| |____/ |_| \____| |_____| \__|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.