I'm trying to create a rudimentary glossary macro for a LibreOffice/OpenOffice .odt file.
It will go to the end of the document and paste a list of selected words(found by regex) as a unique set (no doubles)
Where I'm falling down is that once the text has been copied to the clipboard, I need to assign the contents to a variable so that I can create a set.
In OpenOffice's implementation of BASIC, how does one assign the contents of the clipboard to a new variable?
To be clear: I don't need the Paste function, I need to manipulate the contents of the clipboard as an Object before calling Paste
A rough draft of what I'm trying to do is:
dispatcher.executeDispatch(document, ".uno:Copy", "", 0, Array())
rem -------------- PROBLEM IS BELOW -------
Dim oModuleUICommandDescription As Object, myText$(),aCommand
myText = thisComponent.currentSelection(0)
rem -------------- PROBLEM IS ABOVE -------
rem -------------- Followed by an array comparison to get a unique set
i = FreeFile()
Open "/path/to/my/BASIC.txt" For Output As i
Print #i, myText.string
Close #i
So, as far as I can see the answer is that there isn't a simple built-in way to do this.
However, it is possible by using a custom created function posted here(not mine)
https://wiki.documentfoundation.org/Macros/Writer/005
and using that function to assign contents to the variable.
The upper sub here relies on the function defined below it.
Sub WriteClipboardtoTxtFile()
Dim sText As String
Dim myTextFile As String
Dim i%
findAllTags_Switches()
rem ########### ASSIGNMENT OCCURS JUST BELOW
sText= (getClipboardText)
rem ################ ASSIGNMENT OCCURS JUST ABOVE
sText = Replace (sText," ",Chr(10))
rem Replace white spaces with returns
MsgBox(sText)
i = FreeFile()
Open "/path/to/my/file" For Output As i
Print #i, sText
Close #i
End Sub ' InsertClipboardTexttoVariable
Function getClipboardText() As String
'''Returns a string of the current clipboard text'''
Dim oClip As Object ' com.sun.star.datatransfer.clipboard.SystemClipboard
Dim oConverter As Object ' com.sun.star.script.Converter
Dim oClipContents As Object
Dim oTypes As Object
Dim i%
oClip = createUnoService("com.sun.star.datatransfer.clipboard.SystemClipboard")
oConverter = createUnoService("com.sun.star.script.Converter")
On Error Resume Next
oClipContents = oClip.getContents
oTypes = oClipContents.getTransferDataFlavors
For i = LBound(oTypes) To UBound(oTypes)
If oTypes(i).MimeType = "text/plain;charset=utf-16" Then
Exit For
End If
Next
If (i >= 0) Then
On Error Resume Next
getClipboardText = oConverter.convertToSimpleType _
(oClipContents.getTransferData(oTypes(i)), com.sun.star.uno.TypeClass.STRING)
End If
End Function ' getClipboardText
To use in the OpenOffice macro editors, copy and paste the code in so that the new function can be called.
Related
The single most annoying feature in Excel's built-in VBA editor is—in my opinion—the aggressive autoformatting of the code, which insists on rewriting what I have typed as soon as the cursor leaves the line. It is particularly distressing that the editor collapses all whitespace, thus preventing any meaningful code alignment. For example, if I try to align a sequence of assignments by the equals sign with values aligned by the decimal separator:
price = 10.01
quantity = 3.2
vat = 0.11
the editor inevitably scrambles it by collapsing all spaces:
price = 10.01
quantity = 3.2
vat = 0.11
Is there any way to avoid this kind unwelcome autoformatting?
Assignment cosmetics :-)
There's neither a special VBE property to change the VBE (autoformatting) options directly nor a way to do it programatically. - So afaik VBE irrevocably forces autoformatting upon the user by partial workarounds.
a) Class method
For the sake of the art and just for fun an actually (very) basic class approach to give you a starting idea; assignment arguments are passed as strings allowing any optical formatting - if that's what you really want:
Example call in current module
Sub ExampleCall()
Dim x As New cVars
x.Add "price = 11.11" ' wrong assignment
'...
x.Add "price = 10.01" ' later correction
x.Add "quantity = 1241.01"
x.Add "vat = 0.11"
Debug.Print "The price is $ " & x.Value("price")
End Sub
Class module cVars
Option Explicit
Private dict As Object
Sub Add(ByVal NewValue As Variant)
'split string tokens via equal sign
Dim tmp
tmp = Split(Replace(Replace(NewValue, vbTab, ""), " ", "") & "=", "=")
'Identify key and value item
Dim myKey As String, myVal
myKey = tmp(0)
myVal = tmp(1): If IsNumeric(myVal) Then myVal = Val(myVal)
'Add to dictionary
If dict.exists(myKey) Then
dict(myKey) = myVal
Else
dict.Add myKey, myVal
End If
'Debug.Print "dict(" & myKey & ") =" & dict(myKey)
End Sub
Public Property Get Value(ByVal myVarName As String) As Variant
'get variable value
Value = dict(myVarName)
End Property
Private Sub Class_Initialize()
'set (late bound) dict to memory
If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
Set dict = Nothing
End Sub
Edit #1 as of 3/3 2021
b) Rem Evaluation method
Once again only for the sake of the art a way to read assignments entered into outcommented code lines via, yes via Rem (heaving a deep sigh for this archaic use originating from former Basic times) as it allows to format data with any wanted spaces or tabs and won't be mixed up hopefully with current outcommentings via apostrophe '.
This Test procedure only needs the usual declarations plus some assignment calls as well as the mentioned Rem part. Two simple help procedures get code lines, analyze them via a dictionary class cVars and eventually assign them.
Note that the following example
needs a library reference to Microsoft Visual Basic Extensibility 5.3 and
uses the unchanged class cVars of section a) simply to avoid rewriting it.
Option Explicit
Private Const THISMODULE As String = "Module1" ' << change to current code module name
Sub Test() ' procedure name of example call
'Declare vars
Dim price As Double: Assign "price", price
Dim quantity As Double: Assign "quantity", quantity
Dim vat As Double: Assign "vat", vat
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Enter assignments via Rem(ark)
'(allowing any user defined formatting therein)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Rem price = 10.01
Rem quantity = 1241.01
Rem vat = 0.11
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Debug.Print quantity & " à $" & price & " = " & Format(quantity * price, "$#,##0.00")
End Sub
Help procedure Assign evaluating Rem codelines in procedure Test
Sub Assign(ByVal myVarName As String, ByRef myvar)
Const MyProc As String = "Test"
Dim codelines
getCodelines codelines, THISMODULE, ProcedureName:=MyProc
'Debug.Print Join(codelines, vbNewLine)
Dim x As New cVars ' set class instance to memory
Dim line As Variant, curAssignment
For Each line In codelines
curAssignment = Split(line, "Rem ")(1) ' remove Rem prefix from codelines
If curAssignment Like myVarName & "*" Then
x.Add curAssignment
myvar = x.Value(myVarName)
End If
Next
End Sub
Help procedure getCodelines
Called by above proc Assign. Returns the relevant Rem Codelines from the calling procedure Test. - Of course it would have been possible to filter only one codeline.
Sub getCodelines(ByRef arr, ByVal ModuleName As String, ByVal ProcedureName As String)
Const SEARCH As String = "Rem "
'a) set project
Dim VBProj As Object
Set VBProj = ThisWorkbook.VBProject
If VBProj.Protection = vbext_pp_locked Then Exit Sub ' escape locked projects
'b) set component
Dim VBComp As Object
Set VBComp = VBProj.VBComponents(ModuleName)
Dim pk As vbext_ProcKind
'd) get relevant code lines
With VBComp.CodeModule
'count procedure header lines
Dim HeaderCount As Long: HeaderCount = .ProcBodyLine(ProcedureName, pk) - .ProcStartLine(ProcedureName, pk)
'get procedure code
Dim codelines
codelines = Split(.lines(.ProcBodyLine(ProcedureName, pk), .ProcCountLines(ProcedureName, pk) - HeaderCount), vbNewLine)
'filter code lines containing "Rem" entries
codelines = Filter(codelines, SEARCH, True)
End With
'return elements
arr = codelines
End Sub
Don't forget to integrate the class module CVars from section a)!
I would like to decode a QRcode selected in a worksheet excel but in vba. So I have this piece of code from Zxing library.
Function Decode_QR_Code_From_Byte_Array()
Dim reader As IBarcodeReader
Dim rawRGB(1000) As Byte
Dim res As Result
Set reader = New BarcodeReader
reader.options.PossibleFormats.Add BarcodeFormat_QR_CODE
Rem TODO: load bitmap data to byte array rawRGB
Set res = reader.DecodeImageBytes(rawRGB, 10, 10, BitmapFormat.BitmapFormat_Gray8)
End Function
My main problems are:
How worked with a selected qrcode in the worksheet in VBA ? (macro) Because I don't want to use "from file"
How decode it with the code ?
You do did not answer my clarification questions... I tried making a piece of code dealing with three shapes type. Please, try the next code. It assumes that the QR code shapes have similar names, able to be used to recognize them. I tried the first two characters to be "QR", but it can be changed for your case. If not a pattern, I also suppose that they should be added on a specific column. This can also be used to identify them.
Please, try the next approach:
Sub DecodeQR()
Dim ws As Worksheet, sh As Shape, chQR As ChartObject, QRFile As String
QRFile = ThisWorkbook.Path & "\QRPict.png"
Set ws = ActiveSheet 'any sheet to be processed
'Add a chart helper to export QR picture:
Set chQR = ws.ChartObjects.Add(left:=1, top:=1, width:=100, height:=100)
For Each sh In ActiveSheet.Shapes ' iterate between existing shapes
If left(sh.Name, 2) = "QR" Or left(sh.Name, 2) = "Pi" Then 'process only QR shapes
chQR.width = sh.width: chQR.height = sh.height 'chart dimensions
If sh.Type = 1 Or sh.Type = 11 Or sh.Type = 13 Then 'shapes keeping a picture
ExportQRPict sh, QRFile, chQR 'export picture to be used for decoding
Debug.Print sh.TopLeftCell.Address, Decode_QR_Code_From_File(QRFile) 'decoding
Else
Debug.Print "Unappropriate shape at " & sh.TopLeftCell.Address
End If
End If
Next sh
Kill QRFile: chQR.Delete
End Sub
Private Sub ExportQRPict(QRSh As Shape, QRFile As String, ch As ChartObject, Optional boolPict As Boolean)
QRSh.CopyPicture: ch.Activate: ActiveChart.Paste
ch.Chart.Export fileName:=QRFile, FilterName:="PNG"
End Sub
Function Decode_QR_Code_From_File(pictPath) As String
Dim reader As IBarcodeReader
Dim res As result
Set reader = New BarcodeReader
reader.Options.PossibleFormats.Add BarcodeFormat_QR_CODE
Set res = reader.DecodeImageFile(pictPath)
Decode_QR_Code_From_File = res.text
End Function
Usually, the QR code shapes are placed to the right side of the cell keeping the text to be encoded. If this is the case, or any relation between the shape cell to belong and the cell keeping the text to be encoded exists, the above code can be adapted to check if the decoded text is the same with the reference one.
Is it possible to detect and list all open PDF files from excel Vba? I know I can check for a specific known PDF file and path, however in this case the file name and path will not be known.
Thanks
I was reminded in the comment by Ryan Wildry that I can use AHK for things like this. Here is the code I ended up using:
First I set up a regex pattern in VBA so for how the PDF windows titles appear. Used a couple functions I pulled from the web for previous applications.
Main VBA:
Private Sub Get_PDFs()
Dim pattern As String
Dim ahkParamColl As Collection
Dim windowArr() As String
'regex pattern to match with open Adobe PDF Files
pattern = "^(.+)\.pdf - Adobe Reader$"
'add pattern to AHK parameter collection
Set ahkParamColl = Nothing
Set ahkParamColl = New Collection
ahkParamColl.Add (pattern)
'run window detection AHK Script
Call Functions.Run_AHK("Detect All Open Windows.ahk", ahkParamColl)
'send list to array
windowArr = Split(GetClipBoardText, Chr(10))
End Sub
Function to call AHK:
'these are for AHK scripts to run from Excel
Public Const ahk_ScriptsLoc = """C:\Location of Scripts\" 'starts w/a quote
Public Const ahk_PgmLoc = "C:\Location of AHK Pogram\AHK.exe"
Function Run_AHK(AHK_Script_Name As String, Optional Parameters As Collection)
'Call AHK script from VBA
Dim i As Integer
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim AHKscript As String
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
'set the ahk script string to call
AHKscript = ahk_PgmLoc & " " & ahk_ScriptsLoc & AHK_Script_Name & """ """
'add parameters to script string
If Not Parameters Is Nothing Then
For Each s In Parameters
AHKscript = AHKscript & s & """ """
Next s
End If
'run ahk script
wsh.Run AHKscript, windowStyle, waitOnReturn
End Function
Function to get clipboard text:
Public Function GetClipBoardText()
Dim DataObj As MsForms.DataObject
Set DataObj = New MsForms.DataObject
On Error GoTo Whoa
'~~> Get data from the clipboard.
DataObj.GetFromClipboard
'~~> Get clipboard contents
myString = DataObj.GetText(1)
GetClipBoardText = myString
Exit Function
Whoa:
If Err <> 0 Then MsgBox "Data on clipboard is not text or is empty"
End Function
Main AHK (snagged from Here):
;regex pattern sent from calling application
pattern = %1%
;get all window names and loop through
WinGet windows, List
Loop %windows%
{
id := windows%A_Index%
WinGetTitle wt, ahk_id %id%
;if window matches pattern, add to list
IF (RegexMatch(wt,pattern)>0) then
{
s .= wt . "`n"
}
}
;send list to clipboard
Clipboard := s
So the VBA macro will set up the regex pattern to be sent to the AHK script. I can use this for other document types or naming patterns later if need be. AHK will then be called which loops through each open window, checks if it matches the defined pattern, then appends it to a string. This string is sent to the clipboard, which VBA then reads and splits into an Array for me to use.
I'm sure there is probably a more efficient way out there, but this was a fun way and the only way I could put together.
I am trying to develop a function in VBA that returns the result to the current worksheet. It is intended that the function opens up another spreadsheet, extracts some data, does some processing and returns a value to the worksheet that called the function.
Everything works well when I call the function from the "immediate" window in the VBA editor. However, when I transfer the call to a worksheet the function behavior deviates from the expected when an attempt is made to open the other workbook (AreaBook). The object, AreaBook, remains as a pointer to nothing.
I've tried hard coding the filename; again a call to the function works from the immediate window but not when called from a workbook.
Any ideas?
Public Function pointInWhichArea(FileName As String, SheetName As String, areaID As String, ByVal pointLong As Single, ByVal pointLat As Single) As Variant ', testPointLon As Single, testPointLat As Single) As Variant
Dim a, b, c As Integer
Dim colAreaID, colLat, colLon As Integer
Dim AreaBook As Workbook
Dim AreaSheet As Worksheet
Dim polygonPoints() As pointType
Dim testPoint As pointType
Dim found As Boolean
' extract the point details
testPoint.x = pointLong
testPoint.y = pointLat
' set the workbook and sheet objects
FileName = filePath + FileName ' open the Area definition file
Set AreaBook = Workbooks.Open(FileName) ' <<<< PROBLEM HERE
Set AreaSheet = AreaBook.Sheets(SheetName)
a = 1 ' identify the Polygon ID, latitude and longitude columns column
While AreaSheet.Cells(1, a).Value <> ""
Select Case Worksheets(SheetName).Cells(1, a).Value
Case Is = areaID
colAreaID = a
Case Is = "Latitude"
colLat = a
Case Is = "Longitude"
colLon = a
End Select
a = a + 1
Wend
a = 2 ' loop through all points in the area list
b = a ' remember the beginning of the polygon
found = False
While (AreaSheet.Cells(a, colAreaID).Value <> "" And found = False)
If AreaSheet.Cells(a, colAreaID).Value <> AreaSheet.Cells(a + 1, colAreaID).Value Then ' test for the end of this polygon
c = a ' remember the end of the polygon
ReDim polygonPoints(b To c) As pointType ' array to capture the poylgon
For a = b To c ' loop through each point
polygonPoints(a).x = AreaSheet.Cells(a, colLon).Value ' extract the longitude of the point
polygonPoints(a).y = AreaSheet.Cells(a, colLat).Value ' extract the latitude of the point
Next a
b = a ' remember the beginning of the next polygon
If pointInArea(testPoint, polygonPoints) = True Then ' test if the point is in the current polygon
pointInWhichArea = AreaSheet.Cells(a - 1, colAreaID).Value ' return the area label
found = True
End If
Else
a = a + 1
End If
Wend
AreaBook.Close
End Function
I'm afraid a worksheet function cannot be used to affect other cells or workbooks - you can't add a function to cell A1 and expect the result to appear in cell B2.
In the same way you can't add a function in cell A1 and expect it to open another workbook to get its answer.
That's why it works in the immediate window and not as an Excel function.
You may be able to define a link to the other workbook and then reference that, but you can't get the function to physically open the other workbook.
Worksheet Functions (and user defined variants of these) are limited in terms of what they can and cannot do, here is a small excerpt from a Microsoft article regarding the matter:
https://support.microsoft.com/en-us/kb/170787
A user-defined function called by a formula in a worksheet cell cannot
change the environment of Microsoft Excel. This means that such a
function cannot do any of the following:
Insert, delete, or format cells on the spreadsheet.
Change another cell's value.
Move, rename, delete, or add sheets to a workbook.
Change any of the environment options, such as calculation mode or screen views.
Add names to a workbook.
Set properties or execute most methods.
The page goes on to state that:
Any environmental changes should be made through the use of a Visual Basic subroutine.
So in short, you cannot do what you're attempting to do with a worksheet UDF (User-Defined Function) and will need to change it to a sub routine.
I have some NotesDocument where some RichText fields have both text and inline images. I can get text part of that items but can't retrieve inline images using lotusscript. Could any one please suggest me a way to retrieve inline images from that documents.
LotusScript code:
Sub Click(Source As Button)
Dim session As New NotesSession
Dim db As NotesDatabase
Dim mainDoc As NotesDocument
Dim v As NotesView
Set db = session.CurrentDatabase
Dim fileName As String
Dim fileNum As Integer
fileNum% = Freefile()
fileName$ = "D:\data.txt"
Open FileName$ For Append As fileNum%
Set v = db.GetView("MyView")
Set mainDoc = v.GetFirstDocument
While Not ( mainDoc Is Nothing )
Forall i In mainDoc.Items
If i.Type = RICHTEXT Then
Write #fileNum% , i.Name & ":" & i.text 'how the images??
End If
End Forall
Set mainDoc = v.GetNextDocument( mainDoc )
Wend
End Sub
Thanks.
Midas is the easiest way to do it, but it isn't free. (It's more than worth the money in overall time saved, but if your organisation is anything like the ones I've worked for, the entire cost of the tool is going to be foisted off on the billing unit that owns the current project, rather than have it amortized over the entire org, and they're likely to change their requirements before agreeing to the cost.) There is another approach, and that's to export the database to DXL (Domino XML) using the export option ConvertNotesBitmapToGIF. The images will turn up in the XML as <picture> elements with the data Base64-encoded. If you're operating entirely within the Notes environment, you'll need to create a temporary document with a rich text field used as a NotesMIMEEntity to transform the encoded picture to binary before streaming it to a file (using NotesStream). All of this assumes that you are working with version 6 or higher; if you are on R5 or earlier, Midas or directly accessing the CD records using the C API are the only way to fly.
Seven years later, and I've been pulling my hair out over this one. Rod H's answer is for attachments, but embedded images are another thing entirely.
My best luck came from #andre-guirard's LotusScript Gold Collection code located here: https://www.openntf.org/main.nsf/project.xsp?r=project/LotusScript%20Gold%20Collection However, that doesn't get everything because it doesn't handle documents where the embedded images were embedded the old way. (Notes changed the way it stores embedded images.)
I tried very hard to combine it with AGECOM's information presented here: https://www.agecom.com.au/support/agecomkb.nsf/0/58cbf10f0ab723c9ca25803e006c7de8?OpenDocument by changing Andre's EmbeddedImage object to seamlessly handle both formats by looking to see if the embedded image within a rich text field is really just a pointer to a $FILE field and then, if so, getting a FileItem object, but eventually I exhausted my understanding and options to a degree that I couldn't justify spending my employer's resources (my time) on it.
So if you have embedded images that are all contained in the new way, I think Andre's code will work unmolested. Otherwise, I tried my best but I don't have an answer... I have what is (for me) a dead end, presented in the hopes that you or someone else who stumbles upon it can embarrass me by explaining what I was doing wrong!
Basically, I started with Andre's code and changed it in the following ways...
In DOMUtils, add the following method:
%REM
Function DU_GetMeOrNextSiblingWithAttr
Description: Starting with a particular node, return that node or the next sibling with an attribute that has a particular value.
Does not recurse into the tree; looks only at the node passed and later siblings.
Parameters:
nodeStart: node to start your search with.
targetElement: element name of desired node.
attrName: attribute name you want to check.
attrValue: attribute value of element you're looking for.
flags: string-matching flags to compare attribute, e.g. 1 for case insensitive.
%END REM
Function DU_GetMeOrNextSiblingWithAttr(nodeStart As NotesDOMNode, ByVal targetElement$, ByVal attrName$, ByVal attrValue$, ByVal flags%) As NotesDOMElementNode
Dim node As NotesDOMNode, elTmp As NotesDOMElementNode
Set node = nodeStart
Do Until node.Isnull
If node.Nodetype = DOMNODETYPE_ELEMENT_NODE Then
If node.Nodename = targetElement Then
Set elTmp = node
If StrComp(elTmp.Getattribute(attrName), attrValue, flags) = 0 Then
Set DU_GetMeOrNextSiblingWithAttr = elTmp
Exit Function
End If
End If
End If
Set node = node.Nextsibling
Loop
End Function
Replace FileItem.New with the following code:
%REM
Sub New
Description: Arguments are the parsed DOM node of the element representing a
design element, and the name of the composite item you would like to read,
modify or create.
%END REM
Sub New(parent As FileItemParent, elNote As NotesDOMElementNode, itemName$, fileName$)
Set m_elNote = elNote
SetItem elNote, itemName$, fileName$
Dim node As NotesDOMNode
Set node = m_elNote.Parentnode
While node.Nodetype <> DOMNODETYPE_DOCUMENT_NODE
Set node = node.Parentnode
Wend
Set m_domd = node
parent.RegisterFileItem Me ' make sure the design element knows about us.
' (in case someone gets smart and invokes the constructor directly
' instead of using the nice methods we've provided).
End Sub
%REM
Sub SetItem
<!-- Created Dec 6, 2017 by JSmart523 -->
If fileName$ is blank, returns the XPath equivalent of elNote/ancestor::document/item[#name=itemName$][position()=1]
If fileName$ is not blank, returns the XPath equivalent of elNote/ancestor::document/item[#name=itemName$][object/file/#name=fileName$][position()=1]
Case insensitive. Changes itemName$ and fileName$ to the correct case if found.
Also sets Me.m_elItem to the returned NotesDOMElementNode
Also sets Me.m_elRawData to the file contents
%END REM
Sub SetItem(elNote As NotesDOMElementNode, itemName$, fileName$)
Dim elFile As NotesDOMElementNode
Dim node As NotesDOMNode
'set node to ancestor::document
Set node = elNote
Do Until node.NodeName = "document"
Set node = node.ParentNode
Loop
'If fileName$ = "", get the first ancestor::document/item[#name=itemName$]
'Otherwise, get the first ancestor::document/item[#name=itemName$][/object/file/#name=fileName$]
Set m_elItem = DU_GetChildOfType(node, DOMNODETYPE_ELEMENT_NODE)
QualifyingItem m_elItem, itemName$, m_elRawData, fileName$
m_itemName = itemName$
m_fileName = fileName$
End Sub
%REM
Sub QualifyingItem
<!-- Created Dec 8, 2017 by JSmart523 -->
Starting with incoming elItem node, ensures it's an item we want or changes elItem to the first sibling that qualifies.
%END REM
Sub QualifyingItem(elItem As NotesDOMElementNode, itemName$, elRawData As NotesDOMElementNode, fileName$)
Dim elFile As NotesDOMElementNode
Dim node As NotesDOMNode
Dim elObject As NotesDOMElementNode
If Not elItem Is Nothing Then
'Initially, elItem is just a starting point, not necessarily the item we want.
'If it's an item with the right name, great, otherwise change elItem to the next sibling item with the right name.
Set elItem = DU_GetMeOrNextSiblingWithAttr(elItem, "item", "name", itemName$, 1)
If Not elItem Is Nothing Then
If fileName$ = "" Then
'we have the right item, and aren't looking for a file node, which means we want the rawitemdata node
Set elRawData = DU_getChildNamed("rawitemdata", elItem)
Else
'We are looking for a $FILE item that contains a file.
'There are possibly several $FILE items within a document, one for each file. We've got the right one if ./object/file/#name = fileName$
Do
Set elObject = DU_GetChildNamed("object", elItem)
If Not elObject Is Nothing Then
Set elFile = DU_GetChildWithAttr(elObject, "file", "name", fileName$, 1)
If Not elFile Is Nothing Then
'Yay! We have the right elItem node!
Set elRawData = DU_GetChildNamed("filedata", elFile)
fileName$ = elFile.GetAttribute("name")
Exit Do
End If
End If
Set elItem = DU_GetMeOrNextSiblingWithAttr(elItem.NextSibling, "item", "name", itemName$, 1)
Loop Until elItem Is Nothing
'At this point, either we jumped out of the loop with a valid elItem and elRawData, or elItem is Nothing
End If
End If
End If
If elItem Is Nothing Then
'we didn't find the correct item
'make sure elRawData is changed to Nothing, too.
Set elRawData = Nothing
Else
itemName$ = elItem.GetAttribute("name")
End If
End Sub
Also in FileItem script library, add a new class, FileItemParent
%REM
Class FileItemParent
<!-- Created Dec 5, 2017 by JSmart523 -->
This is a base class for objects that use FileItem objects
%END REM
Class FileItemParent
m_elElRoot As NotesDOMElementNode
m_elFD As NotesDOMElementNode
Public m_fileItem As FileItem
m_fItems List As FileItem ' list of FileItems we've created and returned to caller.
m_iMode As Integer
%REM
Property Get DOMElement
Description: Return the element node representing the design element.
%END REM
Public Property Get DOMElement As NotesDOMElementNode
Set DOMElement = m_elElRoot
End Property
%REM
Sub New
Arguments:
db: the database containing the design element.
elElement: the DOM element corresponding to the design note (e.g. the <note>
element).
domp: The DOM parser object containing elElement.
%END REM
Sub New(elElement As NotesDOMElementNode)
Set m_elElRoot = elElement
End Sub
Sub Delete
On Error Resume Next
ForAll thing In m_fItems
Delete thing
End ForAll
End Sub
%REM
Function HasItem
Description: Determine whether there's an item element in the note DXL with a
given item name.
Note that the presence of an item doesn't guarantee it's formatted as a file
CD record.
%END REM
Function HasItem(ByVal itemName$) As Boolean
HasItem = Not (DU_GetChildWithAttr(m_elElRoot, "item", "name", itemName, 1) Is Nothing)
End Function
%REM
Function RegisterFileItem
Description: For internal use -- lets the FileItem class notify us that it's
referencing our DOM tree so that we can delete the object if we erase the
corresponding item element.
%END REM
Sub RegisterFileItem(x As FileItem)
Set m_fItems(LCase(x.itemName)) = x
If m_FileItem Is Nothing Then
Set m_FileItem = x
End If
End Sub
%REM
Function GetFileItem
Description: Retrieve the FileItem object associated with a CD-record item.
An object will be returned even if the item doesn't exist, which you can
use to create the item via UpdateFile method.
%END REM
Function GetFileItem(itemName$, fileName$) As FileItem
Set GetFileItem = New FileItem(Me, m_elElRoot, itemName, fileName)
End Function
End Class
The FileItemParent class is primarily code taken from Andre's FileResource class so that both FileResource and EmbeddedImage can use it. Change FileResource to extend FileItemParent, removing any duplicated code.
Now we want to change EmbeddedImage so that, even if the embedded image node contains a link to a $FILE item rather than the actual contents, return the actual contents.
So, change EmbeddedImage to extend FileItemParent
Add/replace the following methods to EmbededImage
%REM
Sub InitFileItem
<!-- Created Dec 6, 2017 by JSmart523 -->
Called by New
%END REM
Sub InitFileItem()
Dim buffer As Variant 'byte array
Dim iFileNameLen As Integer
Dim sFileName As String
Dim sItemName As String
Dim stream As NotesStream
If Len(m_b64) < 30000 Then
'If content is short then maybe it's a link to a $FILE item instead of the actual content?
Dim session As New NotesSession
Set stream = session.CreateStream()
Base64ToBinary m_b64, stream
stream.Position = 0
buffer = stream.Read(1)
If buffer(0) = 196 Then
'this is a link to a $FILE, not the actual image contents!
stream.Position = 10
buffer = stream.Read(2)
iFileNameLen = ConvertWordByteArray(buffer)
stream.Position = 24
buffer = stream.Read(iFileNameLen)
sFileName = BytesToString(buffer)
sItemName = "$FILE"
GetFileItem sItemName, sFileName 'sets m_fileItem to a FileItem object
End If
End If
End Sub
%REM
Property Get SuggestedFileName
%END REM
Public Property Get SuggestedFileName As String
If m_fileItem Is Nothing Then
SuggestedFileName = "Embedded-" + ItemName + "." + SuggestedFileType
Else
SuggestedFileName = m_fileItem.FileName
If InStr(SuggestedFileName, ".") = 0 Then
SuggestedFileName = SuggestedFileName + "." + SuggestedFileType
End If
End If
End Property
%REM
Property Get SuggestedFileType
%END REM
Public Property Get SuggestedFileType As String
If ImageType = "notesbitmap" Then
SuggestedFileType = "bmp"
Else
SuggestedFileType = ImageType
End If
End Property
%REM
Sub ReadFileToStream
%END REM
Sub ReadFileToStream(streamOut As NotesStream)
If m_FileItem Is Nothing Then
ReadToStream streamOut
Else
Set m_FileItem.Stream = streamOut
m_FileItem.Load
End If
End Sub
and then change EmbeddedItem.New to, at the end, call InitFileItem so that if it's a link then getting the contents returns the contents rather than the link.
Okay, so far so good as far as I know, but the problem is that CD Records of embedded images stored within $FILE items (i.e. the rich text field's embedded image node simply contains a link rather than the actual image) are/were documented in a way that was, for me, impenetrable, despite AGECOM's code and explanations. I could use the above code and Andre's EmbeddedImageList object to grab every single embedded image but I simply couldn't get a "ConvertOldCDToNew" method working so I couldn't convert the old CD Record format into solid, uncorrupted files! I don't know if I was stripping too many bytes, not stripping the right ones, or maybe I just forgot to carry the two!
I suggest you look at the Genii Software MidasLSX product. They offer a package of LotusScript extensions that make it easier to deal with the complexities of Lotus Notes Rich Text items.
http://www.geniisoft.com/showcase.nsf/MidasHelp
Otherwise, you can experiment with the NotesRichTextNavigator class to gain access to the image in the rich text item (in theory). There is very little documentation on this sort of thing. I couldn't quite tell what an image would appear as using that class, but assuming you navigate through the rich text item and are able to get a handle the image as a NotesEmbeddedObject, I know there's a way to save the object to disk from that class.
Another (crazy) thought is to email the document, and have it received by another program that can more easily process the body of the email. Notes just isn't very helpful with processing its own rich text fields.
Here is an agent I use to detach files from a richtext field on my documents.
Option Public
Dim uidoc As notesuidocument
Dim doc As NotesDocument
Dim db As NotesDatabase
Dim obj As NotesEmbeddedObject
Dim collection As NotesDocumentCollection
Dim rt As Variant
Dim attachNames As Variant
Dim i As Integer, x As Integer
Dim j As Integer
' Agent - Detach Attachments to C drive for later reattachment
' Copies all attachment in richtext field to personal directory.
Sub Initialize
Dim ws As New notesuiworkspace
Dim ses As New NotesSession
Set db = ses.CurrentDatabase
Set collection = db.UnprocessedDocuments
' get first doc in collection
For j = 1 To collection.Count
Set doc = collection.GetNthDocument( j )
' --- create array of filenames of all the attachments in the document
i = 0
Redim attachNames(i)
Forall x In doc.items
If x.name = "$FILE" Then
attachNames(i) = x.values(0)
i = i + 1
Redim Preserve attachNames(i)
End If
End Forall
If i > 0 Then
Redim Preserve attachNames(i-1)
End If
' --- for all of the filenames in attachNames, if it exists in the rich text field, detatch them
If doc.hasItem("richtextfieldname") Then
Set rt = doc.GetFirstItem("richtextfieldname")
End If
If attachNames(0) <> "" Then
Forall x In attachNames
Set obj = rt.GetEmbeddedObject( x )
If Not( obj Is Nothing ) Then
Call obj.ExtractFile( "C:\path\" & Cstr(x) )
End If
End Forall
End If
Call doc.save(True, False)
Next
End Sub