I'm looping through files and I have a fillable PDF form that I am extracting data from. Everything works except when I extract from a rich text field. I get the data, but it looses its formatting.
My code is below. For example, 'General_Match_Comments' is my rich text field in the PDF, but when it comes into the Access Database, it is missing the formatting such as multi-line
Dim AcroApp As Acrobat.CAcroApp
Dim theForm As Acrobat.CAcroPDDoc
Dim jso As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Set AcroApp = CreateObject("AcroExch.App")
Set theForm = CreateObject("AcroExch.PDDoc")
Set oFolder = oFSO.GetFolder(varfolder)
For Each oFile In oFolder.Files
theForm.Open (oFile)
Set jso = theForm.GetJSObject
Dim rstblEvalHeader As Recordset
Set rstblEvalHeader = CurrentDb.OpenRecordset(Name:="tblEvalHeader", Type:=RecordsetTypeEnum.dbOpenDynaset)
With rstblEvalHeader
.AddNew
' get the information from the form fields Text1 and Text2
!Referee = jso.getField("Referee").Value
!EvalDate_af_date = jso.getField("EvalDate_af_date").Value
!Position = jso.getField("R1R2").Value
!Event_Site = jso.getField("Event_Site").Value
!Partner = jso.getField("Partner").Value
!Level_of_Play = jso.getField("Level_of_Play").Value
!Time_Court = jso.getField("Time_Court").Value
!Teams = jso.getField("Teams").Value
!Observer = jso.getField("Observer").Value
!Match_Scores = jso.getField("Match_Scores").Value
!Match_Difficulty = jso.getField("Match_Difficulty").Value
!General_Match_Comments = jso.getField("General_Match_Comments").Value
!Result = jso.getField("Result").Value
strGUID = !ID
strGUID = Replace(Replace(strGUID, "{guid ", ""), "}}", "}")
!SID = strGUID
.Update
End With
theForm.Close
Next oFile
Related
I am trying to adapt this answer, which I believe is in VB.NET, for use with Outlook VBA.
I made some progress by getting the syntax corrected for VBA, but I do not know how to resolve "Compile error: User-defined type not defined" on the line
Dim CurrentXML As XmlDocument
Tool > References includes Microsoft XML, v6.0 but searching for XmlDocument in Object Browser returns no results.
The complete code is as follows:
Sub Search2()
' https://stackoverflow.com/a/50145011/18573
Dim sFilter As String
Dim CurrentExplorer As Outlook.Explorer
Set CurrentExplorer = Nothing
Dim CurrentView As Outlook.View
Set CurrentView = Nothing
' ERROR ON THE FOLLOWING LINE
Dim CurrentXML As XmlDocument
Set CurrentXML = New XmlDocument
Dim CurrentFilterNodes, CurrentViewNodes As XmlNodeList
Dim CurrentFilterNode, CurrentParentNode As XmlNode
sFilter = "urn:schemas:httpmail:subject LIKE '%Build Error%'"
CurrentExplorer = TryCast(ExplorerObj, Outlook.Explorer)
If (CurrentExplorer Is Not Nothing) Then
CurrentView = CurrentExplorer.CurrentView
If (CurrentView Is Not Nothing) Then
CurrentXML.LoadXML (CurrentView.xml)
CurrentFilterNodes = _
CurrentXML.getElementsByTagName("filter")
If CurrentFilterNodes.Count > 0 Then
For y = 0 To CurrentFilterNodes.Count - 1
CurrentFilterNode = CurrentFilterNodes(y)
If CurrentFilterNode.HasChildNodes Then
For i = CurrentFilterNode.ChildNodes.Count - 1 To 0 Step -1
CurrentFilterNode.RemoveChild (CurrentFilterNode.ChildNodes(i))
Next i
End If
Next y
CurrentFilterNode = CurrentFilterNodes(0)
CurrentFilterNode.appendChild ( _
CurrentXML.createTextNode(sFilter))
Else
CurrentViewNodes = CurrentXML.getElementsByTagName("view")
If CurrentViewNodes Is Not Nothing Then
CurrentParentNode = CurrentViewNodes(0)
CurrentFilterNode = CurrentXML.createElement("filter")
CurrentParentNode.appendChild (CurrentFilterNode)
CurrentFilterNode.appendChild (CurrentXML.createTextNode(sFilter))
End If
End If
CurrentView.xml = CurrentXML.InnerXml
CurrentView.Apply
Marshal.ReleaseComObject (CurrentView)
End If
End Sub
The VBA code for Outlook should look like as follows
Option Explicit
Sub Search2()
' https://stackoverflow.com/a/50145011/18573
' Add reference Microsoft XML, v6.0
Dim sFilter As String
Dim oExplorer As Explorer
Dim oView As View
Dim oXML As DOMDocument60
Dim cFilterNodes As IXMLDOMNodeList
Dim cViewNodes As IXMLDOMNodeList
Dim oFilterNode As IXMLDOMNode
Dim oParentNode As IXMLDOMNode
Dim y As Long
Dim i As Long
sFilter = "urn:schemas:httpmail:subject LIKE '%Build Error%'"
Set oXML = New DOMDocument60
Set oExplorer = ActiveExplorer
If Not oExplorer Is Nothing Then
Set oView = oExplorer.CurrentView
If Not oView Is Nothing Then
oXML.LoadXML oView.XML
Set cFilterNodes = oXML.getElementsByTagName("filter")
If cFilterNodes.Length > 0 Then
For y = 0 To cFilterNodes.Length - 1
Set oFilterNode = cFilterNodes(y)
If oFilterNode.HasChildNodes Then
For i = oFilterNode.ChildNodes.Length - 1 To 0 Step -1
oFilterNode.RemoveChild oFilterNode.ChildNodes(i)
Next
End If
Next
Set oFilterNode = cFilterNodes(0)
oFilterNode.appendChild oXML.createTextNode(sFilter)
Else
Set cViewNodes = oXML.getElementsByTagName("view")
If cViewNodes.Length > 0 Then
Set oParentNode = cViewNodes(0)
Set oFilterNode = oXML.createElement("filter")
oParentNode.appendChild oFilterNode
oFilterNode.appendChild oXML.createTextNode(sFilter)
End If
End If
Else
Set cViewNodes = oXML.getElementsByTagName("view")
If cViewNodes.Length > 0 Then
Set oParentNode = cViewNodes(0)
Set oFilterNode = oXML.createElement("filter")
oParentNode.appendChild oFilterNode
oFilterNode.appendChild oXML.createTextNode(sFilter)
End If
End If
oView.XML = oXML.XML
oView.Apply
End If
End Sub
I have the following JSON response from a webservice method which will return byte[] in PDF format:
JVBERi0xLjQKJeLjz9MKMSAwI......nVq2P63zkirBH1z9aW3pDxn6F7q9TFV==
The return value is a byte() array. I been trying for a few days trying to use the function available in one of the questions posted in "Generating PDF from Base64 string in VBA" to generate PDF from the above Base64 Byte array, but I couldn't.
What I have done is that based on the return byte array from the webservice method, I save it as a byte array variable name b64testByte. Subsequently, I then proceed to call 2 methods in my program, namely encodeBase64 first, and followed by DecodeBase64. The PDF file is generated. However, when I try to open the file, there is an error which reads "Error: the document is damaged and cannot be repaired. Adobe Reader could not open because it is either not a supported file type or because the file has been damaged (for example, it was sent as an email attachment and wasn't correctly decoded)."
Dim b64testByte() As Byte
b64testByte = xmlhttp.responseText
Dim B64String As String
B64String = encodeBase64(b64testByte)
Dim FilePath As String
FilePath = "D:\label.pdf"
Open FilePath For Binary Access Write As #1
Put #1, 1, DecodeBase64(B64String)
Close #1
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
'get dom document
Set objXML = CreateObject("MSXML2.DOMDocument")
'create node with type of base 64 and decode
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
'clean up
Set objNode = Nothing
Set objXML = Nothing
End Function
Private Function encodeBase64(ByRef arrData() As Byte) As String
Dim objXML As Object 'MSXML2.DOMDocument
Dim objNode As Object 'MSXML2.IXMLDOMElement
'get dom document
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
encodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function**
Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
I’m a beginner in Lotus Domino it I have some question , It's possible to change this script to delate only locked users with specified name?
I added something like that:
Dim nam As NotesName
Dim c As integer
Set db = session.currentdatabase
Set nam.OrgUnit1 = (“GD”)
Set view = db.getView("Locked Out Users")
Set nvec.OrgUnit1 = view.Allentries
c = nvec.count
If c > 0 Then
In my case I need delete all group person how has specified dc, for example Robert Kowalski/GD/Company everybody how has in name dc=GD?
There are at least 2 ways to achieve your request.
First you can copy the view "Locked Out Users" and change the selection formula to only include your OU.
The other option is something like
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Sub Initialize
On Error GoTo e
Dim session As New NotesSession, db As NotesDatabase, view As NotesView
Dim nvec As NotesViewEntryCollection
Dim c As integer
Set db = session.currentdatabase
dim doc as notesdocument
dim nextDoc as notesdocument
set doc = view.getfirstdocument()
while not doc is nothing
set nextDoc = view.getnextDocument(doc)
set nam = new notesname(doc.getItemValue("[NAMEITEM]")(0))
if strcompare(nam.orgUnit1,"GD",5)=0 then
call doc.remove(true,false)
end if
set doc = nextDoc
wend
Set view = db.getView("Locked Out Users")
Set nvec = view.Allentries
c = nvec.count
If c > 0 Then
Call nvec.Removeall(true)
' Send notification
Dim sarr(1) As String
sarr(0) = "john.doe#acme.com"
sarr(1) = "foo#acme.com"
Dim mdoc As NotesDocument, rt As notesrichtextitem
Set mdoc = db.createdocument
mdoc.Form = "Memo"
mdoc.Subject = "Removed " + CStr(c) + " Locked out users on mypage"
Set rt = mdoc.Createrichtextitem("Body")
Call rt.Appendtext("Removed " + CStr(c) + " Locked out users")
Call rt.Addnewline(1)
Call rt.Appendtext("Click to open lockout database")
Call rt.Appenddoclink(db,"Lockout")
Call mdoc.Send(False, sarr)
End If
Exit Sub
e:
Print Error,erl
End Sub
Thank You #umeli for Yours responce. I think now
it should work.
I'm having trouble adding an image to a page in OneNote 2013. I can create sections, notebooks and pages with content, but I'm having trouble adding an image to the page.
I call UpdatePageContent and pass in the xml but I get an invalid XML message (hresult 0x80042001) back. Any assistance appreciated. Here is the complete code that I use to create an XML that I'm trying to update the page with:
Sub CreateNewPage(ByVal pageName As String)
Dim OneNote As Microsoft.Office.Interop.OneNote.Application
OneNote = New Microsoft.Office.Interop.OneNote.Application
' Get all of the Notebook nodes.
Dim nodes As MSXML2.IXMLDOMNodeList
nodes = GetFirstOneNoteNotebookNodes(oneNote)
If Not nodes Is Nothing Then
' Get the first OneNote Notebook in the XML document.
Dim node As MSXML2.IXMLDOMNode
node = nodes(0)
Dim noteBookName As String = ""
noteBookName = node.attributes.getNamedItem("name").text
' Get the ID for the Notebook so the code can retrieve
' the list of sections.
Dim notebookID As String
notebookID = node.attributes.getNamedItem("ID").text
' Load the XML for the Sections for the Notebook requested.
Dim sectionsXml As String = ""
oneNote.GetHierarchy(notebookID, Microsoft.Office.Interop.OneNote.HierarchyScope.hsSections, sectionsXml)
Dim secDoc As MSXML2.DOMDocument
secDoc = New MSXML2.DOMDocument
If secDoc.loadXML(sectionsXml) Then
' select the Section nodes
Dim secNodes As MSXML2.IXMLDOMNodeList
secNodes = secDoc.documentElement.selectNodes("//one:Section[#name='Balaji1']")
If Not secNodes Is Nothing Then
' Get the first section.
Dim secNode As MSXML2.IXMLDOMNode
secNode = secNodes(0)
Dim sectionName As String = ""
sectionName = secNode.attributes.getNamedItem("name").text
Dim sectionID As String
sectionID = secNode.attributes.getNamedItem("ID").text
Dim doc As MSXML2.DOMDocument
doc = New MSXML2.DOMDocument
'oneNote.GetHierarchy()
Dim sectionXML As String = ""
Dim newPageID As String = ""
sectionXML = ""
oneNote.GetHierarchy("", Microsoft.Office.Interop.OneNote.HierarchyScope.hsPages, sectionXML)
newPageID = GetPageIDByPageName(pageName, sectionXML)
' Create a new blank Page in the first Section
' using the default format.
If Len(newPageID) = 0 Then
oneNote.CreateNewPage(sectionID, newPageID, Microsoft.Office.Interop.OneNote.NewPageStyle.npsDefault)
End If
' Get the contents of the page.
Dim outXML As String = ""
oneNote.GetPageContent(newPageID, outXML, Microsoft.Office.Interop.OneNote.PageInfo.piAll)
' Load Page's XML into a MSXML2.DOMDocument object.
If doc.loadXML(outXML) Then
' Get Page Node.
Dim pageNode As MSXML2.IXMLDOMNode
pageNode = doc.selectSingleNode("//one:Page")
' Find the Title element.
Dim titleNode As MSXML2.IXMLDOMNode
titleNode = doc.selectSingleNode("//one:Page/one:Title/one:OE/one:T")
' Get the CDataSection where OneNote store's the Title's text.
Dim cdataChild As MSXML2.IXMLDOMNode
cdataChild = titleNode.selectSingleNode("text()")
'change the title will change the pageName
' Change the title in the local XML copy.
cdataChild.text = pageName
' Write the update to OneNote.
oneNote.UpdatePageContent(doc.xml)
Dim newElement As MSXML2.IXMLDOMElement
Dim newNode As MSXML2.IXMLDOMNode
' Create Outline node.
newElement = doc.createElement("one:Outline")
newNode = pageNode.appendChild(newElement)
' Create OEChildren.
newElement = doc.createElement("one:OEChildren")
newNode = newNode.appendChild(newElement)
' Create OE.
newElement = doc.createElement("one:OE")
newNode = newNode.appendChild(newElement)
' Create TE.
newElement = doc.createElement("one:T")
newNode = newNode.appendChild(newElement)
newElement = doc.createElement("one:Image")
newNode = newNode.appendChild(newElement)
' Add the text for the Page's content.
Dim cd As MSXML2.IXMLDOMCDATASection
cd = doc.createCDATASection("YOUR TEXT HERE")
newNode.appendChild(cd)
' Update OneNote with the new content.
oneNote.UpdatePageContent(doc.xml)
' Print out information about the update.
MsgBox("A new page was created in Section '" & sectionName & "' in Notebook '" & noteBookName & "'.")
Debug.Print(doc.xml)
End If
Else
MsgBox("OneNote 2010 Section nodes not found.")
End If
Else
MsgBox("OneNote 2010 Section XML Data failed to load.")
End If
Else
MsgBox("OneNote 2010 XML Data failed to load.")
End If
End Sub
i am using Pdfsharp.dll to convert tiff image to pdf file in vb.net, and it is successfull when i run in my machine, when i use it from other machine, which shows the Error like "Raw string contains invalid character with a value > 255.", please any one help me to fix error,
i using the PdfSharp.dll library and the following code
Dim objDoc As PdfDocument
Dim objPdfPage As PdfPage
Dim objTiffImg As Image
Dim objXImg As XImage
Dim iPageCount As Integer
Dim objXgr As XGraphics
Dim sPdfFile As String = Nothing
Dim objDir As DirectoryInfo
Dim objFile As FileInfo()
Dim objFileInfo As FileInfo
Try
objTiffImageSpliter = New TiffImageSplitter()
objDoc = New PdfDocument
iPageCount = objTiffImageSpliter.GetPageCount(sFileName)
For iCount As Integer = 0 To iPageCount - 1
objPdfPage = New PdfPage
objTiffImg = objTiffImageSpliter.getTiffImage(sFileName, iCount)
objXImg = XImage.FromGdiPlusImage(objTiffImg)
'objPdfPage.Height = objXImg.PointWidth
'objPdfPage.Width = objXImg.PointHeight
objDoc.Pages.Add(objPdfPage)
objXgr = XGraphics.FromPdfPage(objDoc.Pages(iCount))
objXgr.DrawImage(objXImg, 10, 10)
Next
sPdfFile = System.Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) & "\MY_FaxFile\"
If System.IO.Directory.Exists(sPdfFile) Then
objDir = New DirectoryInfo(sPdfFile)
objFile = objDir.GetFiles()
For Each objFileInfo In objFile
objFileInfo.Delete()
Next
sPdfFile &= "MyFax.pdf"
Else
System.IO.Directory.CreateDirectory(sPdfFile)
sPdfFile &= "MyFax.pdf"
End If
objDoc.Save(sPdfFile) ' This Line shows the Error.
objDoc.Close()
Catch ex As Exception
MsgBox(ex.ToString)
sPdfFile = Nothing
End Try
Return sPdfFile
I'm not familiar with this library, but based on your code and error message, I would guess that your App Data folder contains non-ASCII characters and that the PdfSharp library does not support non-ASCII characters in the filename.