Background:
I'm trying to create a quiz using powerpoint where there are four buttons on each slide (Correct Answer, Wrong Answer, Wrong Answer, Wrong Answer). Depending which is selected, the user is redirected to a different slide. And to make things more difficult for the players, I'm wanting to randomise the location of the answer buttons e.g. randomly swap the correct answer location, with the wrong answer location etc.
Presentation and Spreadsheet files on OneDrive
Target:
I'm trying to use vba through excel to first find the top and left co-ordinates for each shape, on each slide. And then loop through the presentation a second time, to randomise the placement of my answer buttons (randomly swap them around).
Clarification:
Each of my answer buttons are made up of two parts, a transparent rectangle shape (which has an action link to a particular slide depending whether or not the user selected the correct or wrong answer) as well as a text field (with a red background) which says either wrong or correct answer.
Problem:
I'm currently having problems storing the top and left co-ordinates for each shape, on each slide. So I can then loop through each slide and randomise the placement of my potential answer buttons.
So Far
I'm able to access and store the top and left locations of each shape locally, but I'm not able to store them in my nested classes. Instead when I attempt to pass through the array of shapes found on a particular slide to one of my classes, each time I attempt to access this passed through array, it shows as empty even though I know values are being passed through.
Any suggestions would be fantastic
My Code:
Module 1
Option Explicit
Sub CreateQuiz()
Dim oPPApp As Object, oPPPrsn As Object, oPPSlide As Object
Dim oPPShape As Object
Dim FlName As String
'~~> Change this to the relevant file
FlName = ThisWorkbook.Path & "/Quiz.pptm"
'~~> Establish an PowerPoint application object
On Error Resume Next
Set oPPApp = GetObject(, "PowerPoint.Application")
If Err.Number <> 0 Then
Set oPPApp = CreateObject("PowerPoint.Application")
End If
oPPApp.Visible = False
Set oPPPrsn = oPPApp.Presentations.Open(FlName, True)
Dim currentPresentation As New Presentation
Dim numSlides As Integer
numSlides = 0
For Each oPPSlide In oPPPrsn.Slides
Dim currentSlide As New shapesOnSlide
Dim numShapes As Integer
numShapes = 0
For Each oPPShape In oPPSlide.shapes
Dim currentShape As New shapeDetails
currentShape.slideNumber = oPPSlide.slideNumber
currentShape.name = oPPShape.name
currentShape.left = oPPShape.left
currentShape.top = oPPShape.top
currentSlide.size = numShapes
currentSlide.aShape = currentShape
numShapes = numShapes + 1
Next
currentPresentation.Slide(numSlides) = currentSlide
numSlides = numSlides + 1
Next
currentPresentation.printAll
End Sub
ShapeDetails Class
Private ElementSlideNumber As Integer
Private ElementName As String
Private ElementLeft As Double
Private ElementTop As Double
Public Property Get slideNumber() As Integer
slideNumber = ElementSlideNumber
End Property
Public Property Let slideNumber(value As Integer)
ElementSlideNumber = value
End Property
Public Property Get name() As String
name = ElementName
End Property
Public Property Let name(value As String)
ElementName = value
End Property
Public Property Get left() As Double
left = ElementLeft
End Property
Public Property Let left(value As Double)
ElementLeft = value
End Property
Public Property Get top() As Double
top = ElementTop
End Property
Public Property Let top(value As Double)
ElementTop = value
End Property
Public Sub PrintVars()
Debug.Print "Slide: " & slideNumber & " Position: " & left & "," & top & ", Slide Name: " & name
End Sub
shapesonSlide Class
Private allShapes(99999) As Variant
Private collectionSize As Integer
Public Property Get size() As Integer
size = collectionSize
End Property
Public Property Let size(value As Integer)
collectionSize = value
End Property
Public Property Get aShape() As Variant
shapes = allShapes(collectionSize)
End Property
Public Property Let aShape(value As Variant)
allShapes(collectionSize) = value
End Property
Public Property Get everyShape() As Variant
everyShape = allShapes()
End Property
Public Property Let everyShape(value As Variant)
everyShape = value
End Property
Sub compareSizes(newIndex As Integer)
If (newIndex > collectionSize) Then
collectionSize = newIndex
End If
End Sub
Public Sub printSize()
Debug.Print collectionSize
End Sub
Presentation Class
Private allSlides() As shapesOnSlide
Private Sub Class_Initialize()
ReDim allSlides(0)
End Sub
Public Property Get Slides() As shapesOnSlide()
Slides = allSlides
End Property
Public Property Get Slide(index As Integer) As shapesOnSlide
Slide = allSlides(index)
End Property
Public Property Let Slide(index As Integer, currentSlide As shapesOnSlide)
If index > UBound(allSlides) Then ReDim Preserve allSlides(index)
allSlides(index) = currentSlide
End Property
Public Sub printAll()
For Each currentSlide In allSlides
For Each currentShape In currentSlide.everyShape
Debug.Print currentShape.name
Next
Next
End Sub
I am trying to implement a Model-View-Presenter Userinterface in VBA excel. In order to do this I have been writing different Model classes. Here an Example:
Option Explicit
Private Type TModel
FilterCol As Collection
N As Integer
End Type
Private this As TModel
Public Property Get FilterCol() As Collection
Set FilterCol = this.FilterCol
End Property
Public Property Let FilterCol(ByVal value As Collection)
Set this.FilterCol = value
End Property
Public Property Get N() As Integer
Set N = this.N
End Property
Public Property Let N(ByVal value As Integer)
Set this.N = value
End Property
This class called "FilterModel" is a collection of MSFormObjects. In order to use the collection properly I need to new it. So the code where I use it would look a little like this:
Sub testFilter()
Dim Filterm As FilterModel
Dim DefaultFilterLine As New FilterLine
Set Filterm = New FilterModel
Filterm.FilterCol = New Collection
'Set DefaultFilter
Filterm.FilterCol.Add DefaultFilterLine
'DoStuff
With New frmFilter
Set .Model = Filterm
.Show
End With
End Sub
If I don't new the Property FilterCol before I add something, in this case the defaultfilter, it doesn't work. So here is my Question:
Is there a way to overwrite the new statement for my new class in order to have it also new up the collection FilterCol. My research got me as far as I now know that this would be called a constructor.
But how would one properly implement a constructor for a VBA class?
Somthing like:
Private Sub Class_Initialize()
Set this.FilterCol = New Collection
N = 0
End Sub
If I do this then I get an error in the "Property Let N(Byval Value as integer)" Line. The error message reads "object required".
Here is a working solution. I suggest going through the code line-by-line using F8 to understand what is happening there. Debug.print prints values into the Immediate window.
Here is the FilterModel class:
''' FilterModel class
Option Explicit
Private pFilterCol As Collection
Private pN As Integer
Public Property Get FilterCol() As Collection
Set FilterCol = pFilterCol
End Property
Public Property Let FilterCol(ByVal value As Collection)
Set pFilterCol = value
End Property
Public Property Get N() As Integer
N = pN
End Property
Public Property Let N(ByVal value As Integer)
pN = value
End Property
Private Sub Class_Initialize()
Set pFilterCol = New Collection
pN = 0
End Sub
and here is module code to test it:
''' random module
Option Explicit
Sub testFilter()
Dim Filterm As FilterModel
Set Filterm = New FilterModel
Filterm.FilterCol = New Collection
''' default values (specified in Class_Initialize())
Debug.Print Filterm.N
Debug.Print Filterm.FilterCol.Count
''' set the values through Property Let
Filterm.FilterCol.Add "whatever"
Filterm.FilterCol.Add "whenever"
Filterm.N = 6
''' print the new values (through Property Get)
Debug.Print Filterm.N
Debug.Print Filterm.FilterCol.Count
Debug.Print Filterm.FilterCol(1)
Debug.Print Filterm.FilterCol(2)
End Sub
I am a new to vba and have a task to do at hand. I have written some unction but could not debug it properly. I have following string in xml format:
<!--?xml version=""1.0"" encoding=""UTF-8""?-->
<credentials>
<mid>P</mid>
<mpid>Q</mpid>
<accid>R</accid>
<accesskey>S</accesskey>
<secretkey>T</secretkey>
</credentials>
and am trying to extract value corresponding to tag mid, mpid, accid etc.
Here is the subroutine I wrote:
Private Sub ExtractMWSCredentials(Text As String
Set xmldoc = Nothing
DoEvents
Set xmldoc = Get_XML_DOMDocument_Object()
xmldoc.LoadXML (Trim(Text))
Set mId = xmldoc.getElementsByTagName("mid").Item(0).Text
Set mpId = xmldoc.getElementsByTagName("mpid").Item(0).Text
Set accid = xmldoc.getElementsByTagName("accid").Item(0).Text
Set accesskey = xmldoc.getElementsByTagName("accesskey").Item(0).Text
End Sub
Everything is coming out to be empty. Any help appreciated.
I can't even get that code to compile. You don't use the Set keyword to store a non-object value like Text. You could code, for instance,
Set omId = xmldoc.getElementsByTagName("mid").Item(0)
Debug.Print omId.Text
Also, mId is a reserved word so it can't be a variable name. Here's one way you could do it.
Public Sub Extract()
Dim xDoc As MSXML2.DOMDocument60
Dim sMid As String, sMpid As String
Dim sAccid As String, sAccessKey As String
Set xDoc = New MSXML2.DOMDocument60
xDoc.LoadXML "<!--?xml version=""1.0"" encoding=""UTF-8""?-->" & _
"<credentials><mid>P</mid><mpid>Q</mpid><accid>R</accid>" & _
"<accesskey>S</accesskey><secretkey>T</secretkey></credentials>"
sMid = xDoc.getElementsByTagName("mid").Item(0).Text
sMpid = xDoc.getElementsByTagName("mpid").Item(0).Text
sAccid = xDoc.getElementsByTagName("accid").Item(0).Text
sAccessKey = xDoc.getElementsByTagName("accesskey").Item(0).Text
Debug.Print sMid, sMpid, sAccid, sAccessKey
End Sub
I don't use Set because I'm not storing the Item() in a variable, I'm storing the Item().Text in a variable.
I am trying to set up a custom object model using an example I found in an answered question here on stackoverflow.
VBA Classes - How to have a class hold additional classes
Here is the code I have created based on the answer.
Standard Module
Sub test()
Dim i As Long
Dim j As Long
'code to populate some objects
Dim AssemList As Collection
Dim Assem As cAssem
Dim SubAssemList As Collection
Dim SubAssem As cSubAssem
Set AssemList = New Collection
For i = 1 To 3
Set SubAssemList = New Collection
Set Assem = New cAssem
Assem.Description = "Assem " & i
For j = 1 To 3
Set SubAssem = New cSubAssem
SubAssem.Name = "SubAssem" & j
SubAssemList.Add SubAssem
Next j
Set Assem.SubAssemAdd = SubAssemList '<------ Object variable or With Block not Set
AssemList.Add Assem
Next i
Set SubAssemList = Nothing
'write the data backout again
For Each clock In AssemList
Debug.Print Assem.Description
Set SubAssemList = Assem.SubAssems
For Each SubAssem In SubAssemList
Debug.Print SubAssem.Name
Next
Next
End Sub
cAssem Class
Private pDescription As String
Private pSubAssemList As Collection
Private Sub Class_Initialize()
Set pSubAssems = New Collection
End Sub
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(ByVal sDescription As String)
pDescription = sDescription
End Property
Public Property Get SubAssems() As Collection
Set SubAssems = pSubAssemList
End Property
Public Property Set SubAssemAdd(AssemCollection As Collection)
For Each AssemName In AssemCollection
pSubAssemList.Add AssemName ' <------- This is the line that is triggering the error
Next
End Property
cSubAssem Class
Private pSubAssemName As String
Public Property Get Name() As String
Name = pSubAssemName
End Property
Public Property Let Name(ByVal sName As String)
pSubAssemName = sName
End Property
I have not changed anything in the code except class names and variable names and from my limited point of view I cannot understand the cause of the error.
I am just starting to really dig into objects and Class Modules in VBA so I appreciate any knowledge this community could pass my way.
Many Thanks
You have a typo in your sub class initializer:
Private Sub Class_Initialize()
Set pSubAssems = New Collection
End Sub
should read:
Private Sub Class_Initialize()
Set pSubAssemList = New Collection
End Sub
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