I wish to OCR a few JPEGs (I can convert on the fly with iview).
I get:
Method 'OCR' of object 'IImage' failed
My code isn't perfect yet as I am focused on getting the .ocr method to function.
The images are photos and contain only a few characters. I could use a barcode reader, but those are hard to find free.
Public Function OCRtest(strTempImg)
pXname = "ocrTest"
On Error GoTo err_hand
Dim miDoc As Object
Dim miWord As MODI.Word
Dim strWordInfo As String
Set miDoc = CreateObject("MODI.Document")
miDoc.Create strTempImg
' Perform OCR.
miDoc.Images(0).ocr
' Retrieve and display word information.
Set miWord = miDoc.Images(0).Layout.Words(2)
strWordInfo = _
"Id: " & miWord.id & vbCrLf & _
"Line Id: " & miWord.LineId & vbCrLf & _
"Region Id: " & miWord.RegionId & vbCrLf & _
"Font Id: " & miWord.FontId & vbCrLf & _
"Recognition confidence: " & _
miWord.RecognitionConfidence & vbCrLf & _
"Text: " & miWord.Text
Set miWord = Nothing
Set miDoc = Nothing
OCRtest = strWordInfo
Return
Exit Function
err_hand:
Call CStatus(Error, 504, Err.Number, Err.description, strTempImg)
End Function
If you use MS Office 2010, you need install MODI firstly.
Then, you need to add reference to: Microsoft Office Document Imaging 1x.0 Type Library and you'll be able to use this code:
Sub OCRReader()
Dim doc1 As MODI.Document
Dim inputFile As String
Dim strRecText As String
Dim imageCounter As Integer
inputFile = Application.GetOpenFilename
strRecText = ""
Set doc1 = New MODI.Document
doc1.Create (inputFile)
doc1.OCR ' this will ocr all pages of a multi-page tiff file
For imageCounter = 0 To (doc1.Images.Count - 1) ' work your way through each page of results
strRecText = strRecText & doc1.Images(imageCounter).Layout.Text ' this puts the ocr results into a string
Next
fnum = FreeFile()
Open "C:\Test\testmodi.txt" For Output As fnum
Print #fnum, strRecText
Close #fnum
doc1.Close
End Sub
Above code comes from: https://www.mrexcel.com/forum/excel-questions/358499-read-data-tiff-file-using-modi-ocr-vba.html
Related
I try to find a folder in an Outlook account (I use Multiple accounts) using VBA and Redemption by using the FIND method but I cannot get it to work. On the Redemption webpage there is a reference made to an example and this may help but unfortunately the example isn't there.
Here's my code so far:
Public Function FindFolderRDO(strCrit As String) As String
If Not TempVars![appdebug] Then On Error GoTo Err_Proc
Dim objRdoSession As Redemption.RDOSession
Dim objRdoFolder As RDOFolder
Dim strFoundFolder As String
Dim objFoundFolder As RDOFolder
Dim strFolderName As String
Set objRdoSession = CreateObject("Redemption.RDOSession")
objRdoSession.Logon
objRdoSession.MAPIOBJECT = Outlook.Session.MAPIOBJECT
strFolderName = "\\[mailbox name]\[foldername]\[foldername]" 'actual names removed
Set objRdoFolder = objRdoSession.GetFolderFromPath(strFolderName)
Debug.Print objRdoFolder.Parent.Name 'Prints the folder name
Set objFoundFolder = objRdoFolder.Folders.Find("LIKE 'strCrit%' ") 'Does not work
Debug.Print objFoundFolder.Name
strFoundFOlder = objRdoFolder.Folders.Find("LIKE 'strCrit%' ") 'Does not work
Debug.Print strFoundFOlder
Exit_Proc:
On Error Resume Next
Set objRdoFolder = Nothing
Set objRdoSession = Nothing
Set objFoundFolder = Nothing
Exit Function
Err_Proc:
Select Case Err.Number
Case Else
MsgBox "Error: " & CStr(Err.Number) & vbCrLf & _
"Desc: " & Err.Description & vbCrLf & vbCrLf & _
"Source: " & Err.Source & vbCrLf & _
"Library: " & Application.CurrentProject.Name & vbCrLf & _
"Module: Mod_RDO" & vbCrLf & _
"Function: FindFolderRDO" & vbCrLf, _
vbCritical, "Error"
End Select
Resume Exit_Proc
End Function
Purpose of this function is to find a subfolder (can be up to 4 dimensions deep) having an unique case number of 6 numbers (for example "200332") on the first 6 positions. This function should provide NULL if not found or the full path and the name of the found folder.
I can create the full path with a seperate function (calling the parent folder until top level) but maybe there is a procedure in Redemption such as "fullpath" which I overlooked.
Eventually I want to use this function to delete, move or rename the mailbox folder.
My main question is how to use the "Find(Filter)" method. But any reply on the full path is welcome as well.
Thx! Art.
You are you trying to find a suborder with a name that starts with "strCrit"?
You are almost there:
Set objFoundFolder = objRdoFolder.Folders.Find("Name LIKE 'strCrit%' ")
I have a code that returns various properties for mail items. I'm trying to add the "task status" to my report.
I get a run-time error '438' "Object doesn't support this property or method". I'm trying to extract whether the little flag in Outlook is completed (aka checked).
Here is what I have so far:
For Each currentTask In currentItem.Tasks
Debug.Print currentTask.Status
Report = Report & currentTask.Status
Next
It is part of this larger sub:
Private Sub GetAllEmailsInFolder(CurrentFolder As Outlook.Folder, Report As String)
Dim currentItem
Dim attachment As attachment
Dim currentMail As MailItem
Dim currenTask As TaskItem
Report = Report & "Folder Name: " & CurrentFolder.Name & " (Store: " & CurrentFolder.Store.DisplayName & ")" & " (Date of report: " _
& Date & ")" & vbCrLf & "Subject Name|Categories|Attachment Count|Task Status|Attachment Name(s)" & vbCrLf
For Each currentItem In CurrentFolder.Items
Report = Report & currentItem.Subject & "|"
Report = Report & currentItem.Categories & "|"
Report = Report & currentItem.Attachments.Count & "|"
'need help here
For Each currentTask In currentItem.Tasks
Debug.Print currentTask.Status
Report = Report & currentTask.Status
Next
'
For Each attachment In currentItem.Attachments
Debug.Print attachment.FileName
Report = Report & attachment.FileName & ","
Next
Report = Report & vbCrLf
Next
End Sub
A mailitem has a .FlagStatus property.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Private Sub GetAllEmailsInFolder(CurrentFolder As outlook.Folder, Report As String)
' Code for flags not reliable in IMAP accounts
Dim currentItem As Object
Dim attachment As attachment
Dim currentMail As MailItem
'Dim currenTask As TaskItem ' <--- missing Option Explicit?
Dim currentTask As TaskItem
Dim currentFolderItems As Items
Report = Report & "Folder Name: " & CurrentFolder.Name & " (Store: " & CurrentFolder.Store.DisplayName & ")" & " (Date of report: " _
& Date & ")" & vbCrLf & "Subject Name|Categories|Attachment Count|Task Status|Attachment Name(s)" & vbCrLf
Set currentFolderItems = CurrentFolder.Items
For Each currentItem In currentFolderItems
If currentItem.Class = olMail Then
Set currentMail = currentItem
With currentMail
Debug.Print .Subject
Report = Report & .Subject & "|"
Report = Report & .categories & "|"
Report = Report & .Attachments.Count & "|"
' No longer in current documentation
' https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2010/bb644164(v=office.14)
' Still could be good for decades
' 0 - olNoFlag
' 1 - olFlagComplete
' 2 - olFlagMarked
Debug.Print ".FlagStatus.: " & .FlagStatus
'https://learn.microsoft.com/en-us/office/vba/api/outlook.mailitem.flagrequest
Debug.Print ".FlagRequest: " & .FlagRequest
Report = Report & .FlagStatus
For Each attachment In .Attachments
Debug.Print attachment.Filename
Report = Report & attachment.Filename & ","
Next
End With
Report = Report & vbCrLf
Debug.Print Report
ElseIf currentItem.Class = olTask Then
Set currentTask = currentItem
With currentTask
Report = Report & .Subject & "|"
Report = Report & .categories & "|"
Report = Report & .Attachments.Count & "|"
Debug.Print ".Status.....: " & .Status
Report = Report & .Status
For Each attachment In .Attachments
Debug.Print attachment.Filename
Report = Report & attachment.Filename & ","
Next
End With
Report = Report & vbCrLf
Debug.Print Report
Else
Debug.Print "neither a mailitem nor a taskitem"
End If
Set currentItem = Nothing
Set currentTask = Nothing
Set currentMail = Nothing
Next
End Sub
Private Sub test()
Dim currFolder As Folder
Dim reportStr As String
Set currFolder = ActiveExplorer.CurrentFolder
reportStr = "FlagStaus on mailitems: "
GetAllEmailsInFolder currFolder, reportStr
End Sub
Use MailItem.FlagDueBy / FlagIcon / FlagRequest / FlagStatus / IsMarkedAsTask / TaskCompletedDate / TaskDueDate / TaskStartDate / TaskSubject / ToDoTaskOrdinal properties.
In absence of a better solution, you can use the PropertyAccessor for this purpose.
I cannot provide you with a code snippet right now, but you have ilustrative examples on the reference page [1].
The property tag that you are looking for is 0x8025, with DASL http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81010003.
You can use OutlookSpy to determine property tags of actual properties (thanks to [2] for this tip).
[1] https://learn.microsoft.com/en-us/office/vba/api/outlook.propertyaccessor
[2] How can I get task-specific properties from a MailItem
Edit 1
Private Function GetStatus(objItem As Object) As OlTaskStatus
Dim oPA As Outlook.PropertyAccessor
' MAPI-level access required to get the "status" property of a Mail Item object.
Set oPA = objItem.PropertyAccessor
GetStatus = oPA.GetProperty("http://schemas.microsoft.com/mapi/id/{00062003-0000-0000-C000-000000000046}/81010003")
Set oPA = Nothing
End Function
I exported a PDF with form fields in FDF and wrote a sub to output another FDF verbatim, with cell values for the form field values. If I edit the FDF in a text editor and change the values, Acrobat can read the file just fine, but the file output with VBA throws an error:
Adobe could not open whatever.fdf because it is either not a supported file type or because the file has been damaged
I've tried two different types of line breaks, I've tried a similar sub with xfdf formatting which is slightly different with the same results.
Sub something()
Dim sht As Worksheet
Set sht = Sheets("owssvr")
Dim lastrow As Integer
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
Dim x As Integer
For x = 2 To lastrow
Set Fileout = fso.CreateTextFile("C:\Users\blabla\" & x & ".fdf", True, True)
Fileout.Write "%FDF-1.2" & vbCrLf & _
"%âãÏÓ" & vbCrLf & _
"1 0 obj" & vbCrLf & _
"<</FDF<</F(MyDocument.pdf)/Fields[<</T(Adobe Form Field)/V(" & sht.Range("U" & x) & ")>>]/ID[<4ED54800AC4A3D41ABE4F4C7B12A3D23><609E705B7532334B8F914CFF4C09F2A0>]/UF(MyDocument.pdf)>>/Type/Catalog>>" & vbCrLf & _
"endobj" & vbCrLf & _
"trailer" & vbCrLf & _
"<</Root 1 0 R>>" & vbCrLf & _
"%%EOF" & vbCrLf
Fileout.Close
Next x
End Sub
Simply leave out the line: "%âãÏÓ" & vbCrLf & _". /ID and /UF keys not really needed.
Something like this should work:
Fileout.Write "%FDF-1.2" & vbCrLf & _
"1 0 obj<</FDF<<" & vbCrLf & _
"/F(MyDocument.pdf)" & vbCrLf & _
"/Fields" & vbCrLf & _
"[<</T(Adobe Form Field)/V(xyValue)>>]" & vbCrLf & _
">>>>" & vbCrLf & _
"endobj" & vbCrLf & _
"trailer" & vbCrLf & _
"<</Root 1 0 R>>" & vbCrLf & _
"%%EOF" & vbCrLf
You will find that in the Acrobat IAC documentation. Here a quick vbs(vba) example. Where you need only 2 lines from that: jso.getField and f.value =... Good luck.
'//-> Set a value for a form field via JSO
'//-> Settings
FileNm = "d:\TestInput.pdf"
FieldNm= "Input1"
FieldValue= "50"
'//-> let's start
Set App = CreateObject("Acroexch.app")
app.show
Set AVDoc = CreateObject("AcroExch.AVDoc")
'//-> open the file and put the value in
If AVDoc.Open(FileNM,"") Then
Set PDDoc = AVDoc.GetPDDoc()
Set jso = PDDoc.GetJSObject
'//-> Get the field and put a value in
set f = jso.getField(FieldNm)
f.value = FieldValue
end if
As much as I want to leave this open in hopes somebody figures out WHY VBA is screwing up the unicode, my problem can be solved without invoking fso at all and just using FreeFile and string replace on an original FDF
Sub blabla()
Dim objAcroApp As Acrobat.AcroApp
Dim objAcroAVDoc As Acrobat.AcroAVDoc
Dim objAcroPDDoc As Acrobat.AcroPDDoc
Dim jsObj As Object
Dim boResult As Boolean
Dim oldPDF As String
Dim NewFilePath As String
Dim sTemp As String
Dim iFileNum As Integer
Dim oldFDF As String
Dim i As Integer
Dim lastRow As Integer
Dim sht As Worksheet
Set sht = Sheets("owssvr")
With sht
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 2 To lastRow
oldPDF = "\mydoc.pdf"
oldFDF = "\mydoc_data.fdf"
newPDF = "\" & i & ".pdf"
iFileNum = FreeFile
Open oldFDF For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & vbCrLf
Loop
Close iFileNum
sTemp = Replace(sTemp, "<</T(some form field)/V( )>>", "<</T(some form field)/V(" & sht.Range("E" & i) & ")>>")
iFileNum = FreeFile
oldFDF = "\" & i & ".fdf"
Open oldFDF For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
Set objAcroApp = CreateObject("AcroExch.App")
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
boResult = objAcroAVDoc.Open(oldPDF, "")
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
Set jsObj = objAcroPDDoc.GetJSObject
jsObj.ImportAnFDF oldFDF
jsObj.SaveAs newPDF
boResult = objAcroAVDoc.Close(True)
boResult = objAcroApp.Exit
Next i
End Sub
I have been using InternetExplorer.application with Excel VBA for quite a while with few issues. One problem I have is downloading a file from website. I can get as far as having the "Open/Save As" buttons appear but that is where I am stuck.
I've tried using URLDownloadToFile and it does not seem to work through the same session as the InternetExplorer.application objects that I have. It usually returns the HTML text for a webpage stating that authentication is required. If I have multiple browsers open and some of the old ones are already authenticated then it will download the file most of the time.
Is there a way to download the file using the InternetExplorer.application object itself? If not, is there some way I can associate the URLDownloadtofile function with the object that is already authenticated and logged into the website?
EDIT:
The code I've been using is:
IE2.navigate ("https://...")
strURL = "https://..."
strPath = "c:\..."
Ret = URLDownloadToFile(0, strURL, strPath, 0, 0)
I've also tried:
Do While IE2.Readystate <> 4
DoEvents
Loop
SendKeys "%S"
IE2.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
And:
Dim Report As Variant
Report = Application.GetSaveAsFilename("c:\...", "Excel Files (*.xls), *.xls")
No success in any of these, except for the first one which sometimes saves the actual file, but sometimes saves the website that states the authentication error.
Thanks,
Dave
I have managed to solve similar issue with some JavaScript.
The first step is to make JavaScript download the content of the file into a binary array (it doesn't require another authentication once the user is already authenticated).
Then, I needed to pass this binary array back to VBA. I didn't know the other way, so I print the content of this array into a temporary DIV element (with JavaScript) as a string and then read it with VBA and convert it back to binary array.
Finally, I re-created the file from the given binary array by using ADODB.Stream class.
The time required to download a single file grows geometrically with the size of this file. Therefore, this method is not suitable for large files (> 3MB), since it tooks more than 5 minutes then to download a single file.
Below is the code to do that:
'Parameters:
' * ie - reference to the instance of Internet Explorer, where the user is already authenticated.
' * sourceUrl - URL to the file to be downloaded.
' * destinationPath - where the file should be saved.
'Be aware that the extension of the file given in [destinationPath] parameter must be
'consistent with the format of file being downloaded. Otherwise the function below will
'crash on the line: [.SaveToFile destinationPath, 2]
Public Function saveFile(ie As Object, sourceUrl As String, destinationPath As String)
Dim binData() As Byte
Dim stream As Object
'------------------------------------------------------------------------------------
binData = getDataAsBinaryArray(ie, sourceUrl)
Set stream = VBA.CreateObject("ADODB.Stream")
With stream
.Type = 1
.Open
.write binData
.SaveToFile destinationPath, 2
End With
End Function
Private Function getDataAsBinaryArray(Window As Object, Path As String) As Byte()
Const TEMP_DIV_ID As String = "div_binary_transfer"
'---------------------------------------------------------------------------------------------
Dim strArray() As String
Dim resultDiv As Object
Dim binAsString As String
Dim offset As Integer
Dim i As Long
Dim binArray() As Byte
'---------------------------------------------------------------------------------------------
'Execute JavaScript code created automatically by function [createJsScript] in
'the given Internet Explorer window.
Call Window.Document.parentWindow.execScript(createJsScript(TEMP_DIV_ID, Path), "JavaScript")
'Find the DIV with the given id, read its content to variable [binAsString]
'and then convert it to array strArray - it is declared as String()
'in order to make it possible to use function [VBA.Split].
Set resultDiv = Window.Document.GetElementById(TEMP_DIV_ID)
binAsString = VBA.Left(resultDiv.innerhtml, VBA.Len(resultDiv.innerhtml) - 1)
strArray = VBA.Split(binAsString, ";")
'Convert the strings from the [strArray] back to bytes.
offset = LBound(strArray)
ReDim binArray(0 To (UBound(strArray) - LBound(strArray)))
For i = LBound(binArray) To UBound(binArray)
binArray(i) = VBA.CByte(strArray(i + offset))
Next i
getDataAsBinaryArray = binArray
End Function
'Function to generate JavaScript code doing three tasks:
' - downloading the file with given URL into binary array,
' - creating temporary DIV with id equal to [divId] parameter,
' - writing the content of binary array into this DIV.
Private Function createJsScript(divId As String, url As String) As String
createJsScript = "(function saveBinaryData(){" & vbCrLf & _
"//Create div for holding binary array." & vbCrLf & _
"var d = document.createElement('div');" & vbCrLf & _
"d.id = '" & divId & "';" & vbCrLf & _
"d.style.visibility = 'hidden';" & vbCrLf & _
"document.body.appendChild(d);" & vbCrLf & _
"var req = null;" & vbCrLf & _
"try { req = new XMLHttpRequest(); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Msxml2.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"if (!req) try { req = new ActiveXObject('Microsoft.XMLHTTP'); } catch(e) {}" & vbCrLf & _
"req.open('GET', '" & url & "', false);" & vbCrLf & _
"req.overrideMimeType('text/plain; charset=x-user-defined');" & vbCrLf & _
"req.send(null);" & vbCrLf & _
"var filestream = req.responseText;" & vbCrLf & _
"var binStream = '';" & vbCrLf & _
"var abyte;" & vbCrLf & _
"for (i = 0; i < filestream.length; i++){" & vbCrLf & _
" abyte = filestream.charCodeAt(i) & 0xff;" & vbCrLf & _
" binStream += (abyte + ';');" & vbCrLf & _
"}" & vbCrLf & _
"d.innerHTML = binStream;" & vbCrLf & _
"})();"
End Function
How about something like this?
Public Sub OpenWebXLS()
' *************************************************
' Define Workbook and Worksheet Variables
' *************************************************
Dim wkbMyWorkbook As Workbook
Dim wkbWebWorkbook As Workbook
Dim wksWebWorkSheet As Worksheet
Set wkbMyWorkbook = ActiveWorkbook
' *************************************************
' Open The Web Workbook
' *************************************************
Workbooks.Open ("http://www.sportsbookreviewsonline.com/scoresoddsarchives/nba/nba%20odds%202015-16.xlsx")
' *************************************************
' Set the Web Workbook and Worksheet Variables
' *************************************************
Set wkbWebWorkbook = ActiveWorkbook
Set wksWebWorkSheet = ActiveSheet
' *************************************************
' Copy The Web Worksheet To My Workbook and Rename
' *************************************************
wksWebWorkSheet.Copy After:=wkbMyWorkbook.Sheets(Sheets.Count)
wkbMyWorkbook.Sheets(ActiveSheet.Name).Name = "MyNewWebSheet"
' *************************************************
' Close the Web Workbook
' *************************************************
wkbMyWorkbook.Activate
wkbWebWorkbook.Close
End Sub
I've been struggling with the below issue for a while now and couldn't find the solution yet.
There is an iShare page with an XML file that I want to download using VBA code, then later process the XML file and save into MS Access database.
I've been using the below code for about 4 years now, it worked perfectly without any issues. But suddenly it stopped working this week.
Any ideas why?
the code:
Private Function GetRequests() As Boolean
On Error GoTo ErrHandler
Dim oDoc As MSXML2.DOMDocument
Dim Url As String
Dim sFileName As String
Set oDoc = New MSXML2.DOMDocument
oDoc.async = False
Url = cUrlDatabase & "/" & cApplicationName & "/In/" & cReqXmlFile
UpdateStatus "Loading " & cReqXmlFile
If Not oDoc.Load(Url) Then
c_sLastError = "Could not load XML " & Url
GoTo EndProc
End If
sFileName = sPath & "\Data\requests.xml"
oDoc.Save sFileName
GetRequests = True
End Function
The code fails at the oDoc.Load(Url) part, it comes back false.
Here's an example of how to gather error details:
Dim xDoc As MSXML.DOMDocument
Set xDoc = New MSXML.DOMDocument
If xDoc.Load("C:\My Documents\cds.xml") Then
' The document loaded successfully.
' Now do something intersting.
Else
' The document failed to load.
Dim strErrText As String
Dim xPE As MSXML.IXMLDOMParseError
' Obtain the ParseError object
Set xPE = xDoc.parseError
With xPE
strErrText = "Your XML Document failed to load" & _
"due the following error." & vbCrLf & _
"Error #: " & .errorCode & ": " & xPE.reason & _
"Line #: " & .Line & vbCrLf & _
"Line Position: " & .linepos & vbCrLf & _
"Position In File: " & .filepos & vbCrLf & _
"Source Text: " & .srcText & vbCrLf & _
"Document URL: " & .url
End With
MsgBox strErrText, vbExclamation End If
Set xPE = Nothing
End If
Example taken from here.
For other people finding this post:
The xml parser by now has implemented different error types (see here).
You would have to use the following code
Set objXML = CreateObject("Msxml2.DOMDocument.6.0")
ObjXML.async=true
objXML.load "/path/to/xml"
If objXML.parseError.errorCode <> 0 Then
MsgBox "Error was " + objXML.parseError.reason
End If
This should help you debug your .xml file.
For anyone else struggling with this, I found this error to be caused by text encoded in a format which could not be parsed in VBA (some weird E symbol). The objXML was nothing after the .load. I'm sure there are many possible causes, but I'll share what I found in case this helps someone. Thanks to the guys above for the error handling routines.