I have following code in an lotusscript agent that removes attachments from NotesDocuments. But NotesDocument.save() causes loss of rich text formatting (font, color). Is there any way to retain the formatting?
Sub removeAttachments_v2(doc As NotesDocument)
Dim session As NotesSession
Dim rtitem As Variant
Dim filename As String
Dim ans As Variant
Set session = New NotesSession
Dim richstyle As NotesRichTextStyle
Set richstyle = session.CreateRichTextStyle
richstyle.NotesColor = COLOR_BLUE
If doc.HasEmbedded Then
Set rtitem = doc.getfirstitem("Body")
If (rtitem.type = RICHTEXT) Then
ForAll object In rtitem.EmbeddedObjects
If (object.Type = EMBED_ATTACHMENT) Then
filename = object.source
Call object.remove
Call rtitem.AddNewLine( 2 )
Call rtitem.AppendStyle(richstyle)
Call rtitem.AppendText( "Attachemnt removed: " & filename )
Call doc.Save( True, True , True )
End If
End ForAll
End If
End If
End sub
Edit1: Initialize function
Sub Initialize
Dim db As New NotesDatabase("","")
Dim col As NotesDocumentCollection
Dim doc As NotesDocument
Call db.Open("", "C:\this\is\db\dir\test.nsf")
Set col = db.Alldocuments
Set doc = col.Getfirstdocument()
While Not ( doc Is Nothing )
Call RemoveAttachments_v2(doc)
Call doc.Save(False, False, False)
Set doc = col.GetNextDocument( doc )
Wend
End Sub
Despite of the fact, that you save the document for every attachment I cannot find any reason, why this should happen. I just copied your code in an agent, and it removes the attachments as desired and appends the text in blue...
No formatting is lost...
The error has to be somewhere else in your code, probably in the calling function.
OLD ANSWER (wrong due to own tests, just kept here as history):
The Problem here most probably is: you defined rtitem as Variant. And
getfirstitem gets you a NotesItem instead of a NotesRichtextItem, so
when saving, it is converted to a "plain Text" item.
Most probably you used Variant instead of NotesRichtextItem, because
there are Mime- mails where defining the variable as NotesRichtextItem
will cause an "Type Missmatch" or similar error. As long as you do not
write anything back this is OK.
As Mime Mails need complete different handling to achieve your goal,
you should first fix the code for pure NotesRichtextItems by using the
right type, and then write another code- branch for handling Mime-
items
Related
Using DocumentFormat.OpenXML, I am trying to add a custom property to a Word document and then later read the property. The following code "appears" to do just that:
Dim os As OpenSettings = New OpenSettings() With {
.AutoSave = False
}
Dim propVal As String = "Test Value"
Using doc As WordprocessingDocument = WordprocessingDocument.Open(filename, True, os)
Dim cPart As CustomFilePropertiesPart = doc.CustomFilePropertiesPart
If cPart Is Nothing Then
cPart = doc.AddCustomFilePropertiesPart
cPart.Properties = New DocumentFormat.OpenXml.CustomProperties.Properties()
End If
Dim cPart As CustomFilePropertiesPart = doc.CustomFilePropertiesPart
Dim cProps As Properties = cPart.Properties
For Each prop As CustomDocumentProperty In cProps
If prop.Name = "TranscriptID" Then
prop.Remove()
Exit For
End If
Next
Dim newProp As CustomDocumentProperty = New CustomDocumentProperty() With {
.Name = "TranscriptID"
}
newProp.VTBString = New VTBString(propVal)
newProp.FormatId = "{D5CDD505-2E9C-101B-9397-08002B2CF9AE}"
cProps.AppendChild(newProp)
Dim pid As Integer = 2
For Each item As CustomDocumentProperty In cProps
item.PropertyId = pid
pid += 1
Next
cProps.Save()
End Using
This code is modeled after code found here:
https://learn.microsoft.com/en-us/office/open-xml/how-to-set-a-custom-property-in-a-word-processing-document
It appears to work in this scenario:
Execute code from above.
Execute code from above again.
At #2 I expect to find the CustomFilePropertiesPart and the property value and my expectation is met.
The problem appears in this scenario:
Execute code from above.
Open document using Microsoft Word, save and close.
Execute code from above again.
What happens in this scenario is that the CustomFilePropertiesPart is missing, whereas it should be found. It is as if Microsoft Word does not successfully read this object, so when the document is save, the object is lost. This suggests to me that there is something that there is something wrong with my code. If you can see what it is, or if you have a comparable working example that I could compare it with, I would appreciate hearing from you. I feel like I correctly followed the Microsoft example, but obviously I did not and I am having trouble seeing where I departed. Thanks.
OK, I found this wonderful tool called the Office Productivity Tool. It has a code generation feature, so I was able to compare what I was doing with what Word does. Basically the problem was with setting the property value. This snippet does the trick:
Dim cProps As Properties = cPart.Properties
Dim val As DocumentFormat.OpenXml.VariantTypes.VTLPWSTR = New DocumentFormat.OpenXml.VariantTypes.VTLPWSTR
val.Text = tr.ID.ToString
Dim newProp As CustomDocumentProperty = New CustomDocumentProperty() With {
.Name = "TranscriptID",
.FormatId = "{D5CDD505-2E9C-101B-9397-08002B2CF9AE}"
}
newProp.Append(val)
cProps.AppendChild(newProp)
[EDIT] I believe i left out my original problem. To me it seems like the issue resides in passing the content of the decoded MIMEEntity to a stream, which i'd like to write out to a file. No matter how i attempt it, i can not get lotus script to write the binary data to the file. If anyone has any helpful opinion/suggestion/etc.., I'd be more then grateful!
[ORIGINAL]
I have the following code
Dim a As String
a = "TVqQAAMAAAAEAAAA//8AALgAAAAAAAAAQAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" & _
"AAAAgAAAAA4fug4AtAnNIbgBTM0hVGhpcyBwcm9ncmFtIGNhbm5vdCBiZSBydW4gaW4gRE9TIG1v" & _
...
...
Dim session As New NotesSession
Dim stream As NotesStream
Dim doc As NotesDocument
Dim body As NotesMimeEntity
Dim db As NotesDatabase
Set session = New NotesSession
'Create stream and display properties
Set stream = session.CreateStream
'check if the file exists
If Not stream.Open("C:\\Notes\\update.dll") Then
'if the file doesnot exist then create one and add a time stamp to it
Dim fileNum As Integer
fileNum% = Freefile()
Open "/ww414/notes/ebcdicfile.txt" For Output As fileNum%
Close fileNum%
'this should have created the file. see if it existis now
If Not stream.Open("C:\\Notes\\update.dll") Then
'if the file has not been created yet then let the user know of the error that blocks the operation
Messagebox("Log file Is inaccessible")
End If
End If
Dim b As NotesStream
Set b = session.CreateStream
Call b.WriteText(a)
'==========================================================
'update file with the b64 decoded content
Set db = session.CurrentDatabase
Set doc = db.CreateDocument
session.ConvertMime = False
Set body = doc.CreateMIMEEntity
Call body.SetContentFromText(b, "", ENC_BASE64)
Call body.DecodeContent
content = body.ContentAsText
Call stream.WriteText(content)
'close stream/file open in memory
Call stream.Close()
The problem is, the file gets created, but when it comes to the content, it simply puts a few bytes in it (instead of the 14kb of actual file data)
I have checked a bunch of forums and possible solutions, but none of them seem to work.
For instance:
https://www.nsftools.com/tips/Base64v14.lss
http://www-10.lotus.com/ldd/nd6forum.nsf/e5f5333619f2996885256a220009508f/a8bb2c21c99f9c4d852571ee005cede9?OpenDocument
https://ghads.wordpress.com/2008/10/17/vbscript-readwrite-binary-encodedecode-base64/
So, the solution was even simpler as i thought.
This was a huge help, as the root cause of my issue seemed to be the writing out the binary content to the disk. And that was due to creating the file the wrong way! While the file got created it couldn't output the content properly (for some "Lotus reasons"..)
Either way, taking a coffee break and starting everything from zero helped a lot! The code that worked (for future ref. if someone would need to get such a thing working):
Sub Initialize
Dim a As String
a ="BASE64 ENCODED STRING(In my case it was a DLL)"
Dim session As New NotesSession
Dim stream As NotesStream
Dim doc As NotesDocument
Dim body As NotesMimeEntity
Dim db As NotesDatabase
Set session = New NotesSession
Set stream = session.CreateStream
Dim b As NotesStream
Set b = session.CreateStream
Call b.WriteText(a, EOL_NONE)
Set db = session.CurrentDatabase
Set doc = db.CreateDocument
session.ConvertMime = False
Set mime = doc.CreateMIMEEntity
Call mime.SetContentFromText(b, "application/octet-stream", ENC_BASE64)
Call mime.DecodeContent
If Not(mime Is Nothing) Then
Set stream = session.CreateStream
pathname$ = "c:\temp\test.dll"
If Not stream.Open(pathname$, "binary") Then
Messagebox pathname$,, "Open failed"
Goto ExitSub
End If
Call mime.GetContentAsBytes(stream)
Call stream.Close
Else
Messagebox "Not MIME",, doc.GetItemValue("Subject")(0)
End If
ExitSub:
session.ConvertMIME = True ' Restore conversion
End Sub
I want to access a Lotus Notes Database and get attachments from documents in it.
I can open the DB and doc and loop through all items.
The problem is, I can not use the items as NotesRichTextItem and therefore not check if there are any item.EmbeddedObject.
I guess it is a problem with declaration of the items.
In general: If I debug using VS2010, doc and the database and NotesSession have the "value" System.__ComObject and "type" is the Domino.Notes Object it should be.
e.g. doc in WATCH:
Name VALUE TYPE
doc {System.__ComObject} Domino.NotesDocument
but if I use the doc.GetType() command the result is
doc.GetType() = {Name = "__ComObject" FullName = "System.__ComObject"}
Since I do not know if my doc.item is a NotesRichTextItem, I define it as an object and want to check afterwards is type. Which I can't since the return value of the functions is as above for doc, too.
Here is the complete code I use currently, I loaded the Lotus Domino reference from the COM section.
Public Sub OpenDocumentLN()
Try
Dim ns As New Domino.NotesSession
Dim db As Domino.NotesDatabase
Dim doc As Domino.NotesDocument
Dim view As Domino.NotesView
If Not (ns Is Nothing) Then
ns.Initialize()
db = ns.GetDatabase("", sLotusNotesPath & sLotusNotesDB, False)
If Not (db Is Nothing) Then
view = db.GetView(sLotusView)
doc = view.GetFirstDocument
While Not doc Is Nothing
Dim lnNextDoc As Domino.NotesDocument = view.GetNextDocument(doc)
For Each item As Domino.NotesItem In doc.Items
Dim rtItem As Object = doc.GetFirstItem(item.Name)
If rtItem Is Nothing Then Continue For
If Not rtItem.GetType() = GetType(Domino.NotesRichTextItem) Then Continue For
' NEVER reach this part of the code since the IF clause prevents it due to the type problem
If rtItem.EmbeddedObjects Is Nothing Then Continue For
For Each o As Domino.NotesEmbeddedObject In rtItem.EmbeddedObjects
o.ExtractFile(sLotusExportPath & o.Source)
Next
Next
doc = lnNextDoc
End While
End If
db = Nothing
ns = Nothing
End If
Catch ex As Exception
End Try
End Sub
How can I use my rtitem as a NotesRichTextItem so I can handle it appropiate? And why are all objects are treated als ComObjects?
I wrote a simple macro function in VBA for Excel to extract text appearing in a particular location in an HTML document, first retrieving the HTML document from a URL value in another cell. The macro function itself is not important, except for the fact that it sends an HTTP request and creates an HTML file object, which I fear will cause Excel to crash if I paste, say, a column of 100 or more URLs and it starts trying to calculate all the values at once. I can see that it stops and churns for a moment if I drag the formula down 10 cells where there is already a column of URLs. Is there a setting to force Excel to calculate one formula at a time, so that it may take longer but is less likely to freeze up or crash?
Update: I incorporated a static collection variable into the function to at least avoid repeated slowdowns retrieving the same HTML in the same worksheet:
Function GetUSPatentAbstract(ByVal url As String) As String
Static colAbstract As New Collection
Dim abstract As String
On Error Resume Next
abstract = colAbstract(url)
`If there is no abstract for the URL in the collection yet, then it is retrieved:
If Err.Number <> 0 Then
Dim description As String
Dim abstractStart As Long
Dim abstractEnd As Long
Dim abstractLength As Long
Set html_doc = CreateObject("htmlfile")
Set xml_obj = CreateObject("MSXML2.XMLHTTP")
xml_obj.Open "GET", url, False
xml_obj.send
html_doc.body.innerhtml = xml_obj.responseText
Set xml_obj = Nothing
description = html_doc.body.innertext
abstractStart = InStr(description, "Abstract") + 8
abstractEnd = InStr(description, "Inventors:")
abstractLength = abstractEnd - abstractStart
abstract = Mid(description, abstractStart, abstractLength)
colAbstract.Add Item:=abstract, Key:=url
End If
On Error GoTo 0
GetUSPatentAbstract = abstract
End Function
I create a browser like so, and manually navigate to the web page I need to be. I intend to automatically pull certain elements once I get to the page I need to be on via a seperate macro
Sub Test()
Set CAS = New SHDocVw.InternetExplorer ' create a browser
CAS.Visible = True ' make it visible
CAS.navigate "http://intraneturl"
Do Until CAS.readyState = 4
DoEvents
Loop
This works fine, then I do
Public Sub Gather
Set HTMLDoc2 = CAS.document.frames("top").document
Call Timer1
With HTMLDoc2
.getElementById("tab4").FirstChild.Click
End With
Call Timer2
Dim fir, las, add1, add2, cit, stat, zi As String
Dim First As Variant
Dim Last As Variant
Dim addr1 As Variant
Dim addr2 As Variant
Dim city As Variant
Dim Thisstate As Variant
Dim Zip As Variant
Call Timer2
Set HTMLDoc = CAS.document.frames("MainFrame").document
Call Timer2
With HTMLDoc
First = .getElementsByName("IndFirst")
Last = .getElementsByName("IndLast")
addr1 = .getElementsByName("txtAdd_Line1")
addr2 = .getElementsByName("txtAdd_Line2")
city = .getElementsByName("txtAdd_City")
Thisstate = .getElementsByName("cmb_Add_State")
Zip = .getElementsByName("txtAdd_Zip")
End With
fir = First.Value
las = Last.Value
add1 = addr1.Value
add2 = addr2.Value
cit = city.Value
stat = Thisstate.Value
zi = Zip.Value
'navigate back to start page
With HTMLDoc2
.getElementById("tab3").FirstChild.Click
End With
End Sub
This works the first time, but after the first time, I get "Object variable or with block variable not set" when trying to run the gather() sub again, on a different web page that contains similar information. Any Ideas as to what im doing wrong?
"The error "object variable or with block variable not set" occurs on: Set HTMLDoc2 = CAS.document.frames("top").document the second time i try running Gather()."
This is probably one of three things:
CAS is no longer an object
To check this, set a breakpoint on the line, press ctr+G in the VBA Editor and type ?CAS Is Nothing in the Immediate Window; the result should be False; if it is True CAS is no longer an object
Like Daniel Dusek suggested, make sure CAS.document.frames("top") is an actual element on the page.
To check this, open the webpage you are trying to script, press F12 in Internet Explorer, click on the arrow in the toolbar and click on the "top" frame element in the webpage, switch back to the Developer Tool and look at the line highlighted. Make sure the frame element is named "top".
The HTML hasn't fully loaded when you try to reference the frame element. Set a longer delay or a loop.
i.e. (untested):
Do Until HtmlDoc2 Is Nothing = false
Set HTMLDoc2 = CAS.document.frames("top").document
Loop
Maybe the more important question is why manually navigate to another page? Can't you automate that part of your process too?