Lotusscript Rich Text Field adding Images or Unicode Characters to Rich Text Table - lotus-notes

Is there any method of adding images or unicode characters from (say) Wingdings by in a table generated by lotusscript.
As the options for formatting of tables in lotusscript are limited I store a formatted table in a profile document and append it to the rich text field.
In the Queryopen event of the document I add the rtf table and add rows and populate. The one below is finding emails sent from a document and displaying them in that document in an RTF
Any help is greatly appreciated.
Sub Queryopen(Source As Notesuidocument, Mode As Integer, Isnewdoc As Variant, Continue As Variant)
Dim session As New NotesSession
Dim ws As New NotesUIWorkspace
Dim rtItem As NotesRichTextItem
Dim rtnavBody As NotesRichTextNavigator
Dim rtt As NotesRichTextTable
Dim rc As Integer
Dim cc As Integer
Dim rcc As Integer
Dim cl As Integer
Dim richStyle As NotesRichTextStyle
Dim tablelayout As NotesRichTextItem
Dim db As NotesDatabase
Dim pdoc As NotesDocument
On Error Goto errorsub
Set uidoc = source
Set db =session.CurrentDatabase
Set doc = uidoc.Document
Set view = db.Getview("MailByParentID")
Set col = view.Getalldocumentsbykey(doc.DocID,True)
If col.count=0 Then Exit Sub 'No items exist so no point in carrying on.
End If
Set rtItem = New NotesRichTextItem(doc,"rtfCustMail") 'field in the current document
Set pdoc=db.Getprofiledocument("Profile Doc")
Set tablelayout = pdoc.GetFirstItem("rtfMailLog") 'Get a ready made table from the Profile Doc.
Call rtitem.AppendRTItem(tablelayout)
Set rtnavBody = rtItem.CreateNavigator
Set richStyle = session.CreateRichTextStyle
Set idoc = col.Getfirstdocument()
'Add a row to the table to hold the data for the first item in the order
Call rtnavBody.FindFirstElement(RTELEM_TYPE_TABLE)
Set rtt = rtnavBody.GetElement
Do Until idoc Is Nothing
Call rtt.AddRow()
'Write the item data into the tablecells --
rc%= rtt.RowCount 'Find the number of rows in the table
cc% =rtt.ColumnCount
rcc% =rc%*cc% 'Calculate total number of table cells
cl% =rcc%-5 'Calculate cell number of the first cell in the new (last) row
Call rtnavBody.FindNthElement(RTELEM_TYPE_TABLECELL,cl%) 'Move to the first cell in the last row
Call rtitem.BeginInsert(rtnavBody)
Call rtitem.Appenddoclink(idoc,"")
Call rtitem.EndInsert
Call rtnavBody.FindNextElement(RTELEM_TYPE_TABLECELL)
Call rtitem.BeginInsert(rtnavBody)
Call rtitem.AppendText(******need to add characters in here or better still images.)
Call rtitem.EndInsert
'To
Call rtnavBody.FindNextElement(RTELEM_TYPE_TABLECELL)
Call rtitem.BeginInsert(rtnavBody)
Call rtitem.AppendText(idoc.SendTo(0))
Call rtitem.EndInsert
etc etc.
Set idoc = col.Getnextdocument(idoc)
Loop
errorsub: Print " Line " Erl & " Reason - "& Error$
End Sub

Unicode characters can simply be appended as text. There is some complication because Notes is using LMBCS, not Unicode. Still, if you can paste the character you want into a text string in your LotusScript code, the conversions will be done behind the scenes. If there are any issues with it, I uploaded an NSF containing a full listing of all Unicode characters with their LMBCs equivalents on the OpenNTF website somewhere between 10 and 20 years ago. I still have a copy if it can no longer be found after the various changes to OpenNTF.
BTW, a very useful trick that I've found for getting content into a NotesRichText item that is being constructed on the fly from parts that you have already built advance is the AppendToRTItem method. I.e., you are building rtitem, as above. You have a config document containing a rich text field containing the content that you want (e.g., an image, a hypertext link, something with a hide-when formula, etc.) so you open that config document, get the NotesRichText item from that document into rtitem2, and call rtitem2.AppendToRTItem(rtitem).

Related

How to keep rows which do not have a new line character from splitting, when importing the Body of a Lotus Notes e-mail into Excel using VBA?

I have an Excel VBA program that will find a Lotus Notes email with specific text in the subject and import the body into the Excel spreadsheet.
I can find the email, and import the data to Excel. Unfortunately, it seems to be creating a new line where there isn't a new line character.
I noticed that the breaks in the Excel sheet match up with the line wrapping in Word when I cut and paste the Body into a Word doc and the doc is in portrait mode.
If I change Word to landscape, it looks like the e-mail.
Changing the Excel sheet to landscape had no effect.
I also tried changing the split to use vbCR and vbLf independently of each other without positive results.
Is there a line length option I can set? How can I keep all the data associated with one line in the e-mail with one line in Excel?
Sub LNExtract()
Dim NSession As Object 'NotesSession
Dim NMailDb As Object 'NotesDatabase
Dim NDocs As Object 'NotesDocumentCollection
Dim NDoc As Object 'NotesDocument
Dim NNextDoc As Object 'NotesDocument
Dim NItem As Object 'NotesItem
Dim view As String
Dim filterText As String
view = "Folder\SubFolder" 'Name of view or folder to retrieve documents from
filterText = "SubjectLineText" 'Optional text string to filter the view
Set NSession = CreateObject("Notes.NotesSession")
Set NMailDb = NSession.GETDATABASE("", "") 'Default server and database
If Not NMailDb.IsOpen Then
NMailDb.OPENMAIL
End If
Set NDocs = NMailDb.GETVIEW(view)
NDocs.Clear
'Apply optional filter
If filterText <> "" Then
NDocs.FTSEARCH filterText, 0
End If
Set NDoc = NDocs.GETFIRSTDOCUMENT
Do Until NDoc Is Nothing
Set NNextDoc = NDocs.GETNEXTDOCUMENT(NDoc)
Set NItem = NDoc.GETFIRSTITEM("Body")
If Not NItem Is Nothing Then
Lines = Split(NItem.Text, vbCrLf)
Range("A1").Resize(UBound(Lines) + 1, 1).Value = Application.WorksheetFunction.Transpose(Lines)
End If
Set NDoc = NNextDoc
Loop
End Sub
Where you have NItem.Text in your code, I'm fairly sure that gives the same result as the GetFormattedText method of the NotesRichTextItem class, which limits the line length. Relevant documentation is here:
https://help.hcltechsw.com/dom_designer/9.0.1/appdev/H_GETFORMATTEDTEXT_METHOD.html
In contrast, the GetUnformattedText method doesn't limit the line length, so you should get a better result if you replace NItem.Text with NItem.GetUnformattedText().

How to clear bookmark data using macro in MS word

I am trying to update data in ms word from excel using macro. To simplify the process, I am using bookmark feature. The issue is when I ran the code, the data in bookmark gets duplicated and I see the same data points from excel in ms word multiple times. I tried to find out a solution on how to clear the data stored in bookmarks before pasting new data but the problem seems to be unresolved.
------------------CODE----------------------------
Option Explicit
Const FilePath As String = "C:\Users\Prablee.Singh\Desktop\"
Dim wd As New Word.Application
Sub ExporttoWord()
Dim doc As Word.Document
wd.Visible = True
Dim Model_Name As String
Dim Model_Description As String
Dim Model_Status As String
Model_Name = ThisWorkbook.Sheets(2).Range("A2").Value 'value from sheet1
Model_Description = ThisWorkbook.Sheets(2).Range("B2").Value
Model_Status = ThisWorkbook.Sheets(2).Range("C2").Value
Set doc = wd.Documents.Open(FilePath & "VBA Code Doc.docx")
Copy2word "Project1", Model_Name
Copy2word "Project1Description", Model_Description
Copy2word "Project1Status", Model_Status
doc.Close
wd.Quit
End Sub
Sub Copy2word(BookMarkName As String, Text2Type As String)
wd.Selection.GoTo What:=wdGoToBookmark, Name:=BookMarkName
wd.Selection.TypeText Text2Type
End Sub
Correct me if I'm wrong. You want to insert text to replace old bookmark? Is your bookmarks marked as range or it's only location? You can replace whole bookmark text using this sample:
Dim BookmarkRange As Range
Set BookmarkRange = ActiveDocument.Bookmarks("myBookmarkRange").Range
BookmarkRange.Text = "this text will replace the old one."
This problem is likely caused by the bookmark simply marking a location in the document, as shown in the top example of the screenshot below, rather than enclosing text.
To see the bookmarks go to File | Options | Advanced | Show Document Content and tick the "Show bookmarks" option.
When inserting text into an enclosing bookmark the bookmark gets deleted and needs to be replaced. This can be done by using a routine such as the one below which also checks that the bookmark exists to avoid errors.
Public Sub InsertIntoBookmark(bookmarkName As String, text As String, _
Optional targetDoc As Document = Nothing)
Dim bookmarkRange As Range
If targetDoc Is Nothing Then Set targetDoc = ActiveDocument
If targetDoc.Bookmarks.Exists(bookmarkName) Then
Set bookmarkRange = targetDoc.Bookmarks(bookmarkName).Range
bookmarkRange.text = text
targetDoc.Bookmarks.Add bookmarkName, bookmarkRange
End If
End Sub
Since the text, as you've said is duplicating that indicates your bookmark is a single point in the document and not a spanned range. The resultant behavor is then to add the text behind the bookmark and leave the bookmark in place. If your bookmark was a spanned range of existing text then Word would replace the text but it would also remove the bookmark.
Either way, your code must reestablish a bookmark ... that is unless you want to remove the bookmark after you have placed the new data into the document.
Try this code ...
Dim rng As Word.Range
Set rng = doc.Bookmarks("BookMarkName").Range
rng.Text = "Project Name"
doc.Bookmarks.Add "BookMarkName", rng
As I've tried to explain above, if your Word document had in the BookMarkName a placeholder of "Temp Name" the code above would replace it with "Project Name" and then reestablish the BookMareName surrounding "Project Name". If you didn't what it to reestablish BookMarkName, then just omit the last line.
If in your existing document BookMarkName is a single address point and not a span of text, the code above will still add the new text, but it will also relocate the BookMarkName range to the new span of text. And the difference here is if you don't want the BookMarkName to remain after inserting the new text, you will have to replace the last code line with ...
doc.Bookmarks(BookMarkName).Delete

VBA to Lotus Notes - Variable body with formatting ( Colors )

I'm currently working in the automation of a process at work that used to require a lot of hand work and gathering data from several sources and ended in sending an email with:
Header ( fixed ) Regular
Description ( One line for each cell with data in a given range ) Bold
Footer ( fixed ) - Text Color: Red
Attachment
Well, we had a stationery to aid with the email, but as i can't guarantee that everybody will have the stationery properly set up i am looking for a more elegant way to do so ( basically the goal is to make it fool-proof ), so i started to work on a way to do it mixing VBA+Formulas in the cells.
So far my code creates the message on notes, inserts the adress list, title and attaches the file that it generates, but when it comes to inserting the body, fat chance! I can insert a single-lined message but without any formatting or styles, the ones described above in bold next to the elements of the body.
What i'm chasing is a way to paste the text in given cells from my spreadsheet to notes and apply formatting on them, so each cell value would be a line of text on notes, with different styling.
I've been reading questions and articles for about 3 days already without any success, and i decided to ask it myself cause it's a big step forward in my project, is there a way to do it? i believe i'm looking for something like
notesmagicproperty.boldthisrange("B3")
that translates to
"03 - Lorem ipsum dolor sit amet"
Thanks in advance, Stack Overflow has saved me a thousand times already!
Also, sorry for not posting the code, i'm writing this from home and it's 3am so i have no access to it at the moment.
0. NotesRichTextRange.SetStyle method
NotesRichTextRange.SetStyle method is what you are looking for. For this method you need to create NotesRichTextStyle object. Also you need to SetBegin end SetEnd of range by using NotesRichTextNavigator object.
Here is example:
Dim ses As New NotesSession
Dim doc As NotesDocument
Dim richText As NotesRichTextItem
Dim navigator As NotesRichTextNavigator
Dim range As NotesRichTextRange
Dim headerStyle As NotesRichTextStyle
Dim descriptionStyle As NotesRichTextStyle
Dim footerStyle As NotesRichTextStyle
'Create your doc.
'Generate rich text content:
Set richText = doc.CreateRichTextItem("Body")
Set navigator = richText.CreateNavigator
Set range = richText.CreateRange
richText.AppendText("Header")
richText.AddNewline(1)
Set headerStyle = ses.CreateRichTextStyle
headerStyle.Underline = True
Set descriptionStyle = ses.CreateRichTextStyle
descriptionStyle.Bold = True
Set footerStyle = ses.CreateRichTextStyle
footerStyle.NotesColor = COLOR_RED
navigator.FindFirstElement(RTELEM_TYPE_TEXTPARAGRAPH)
range.SetBegin(navigator)
range.SetEnd(navigator)
Call range.SetStyle(headerStyle)
For index% = 0 To 7
richText.AppendText("Description" & index%)
richText.AddNewline(1)
navigator.FindNextElement(RTELEM_TYPE_TEXTPARAGRAPH)
range.SetBegin(navigator)
range.SetEnd(navigator)
Call range.SetStyle(descriptionStyle)
Next
richText.AppendText("Footer")
richText.AddNewline(1)
navigator.FindNextElement(RTELEM_TYPE_TEXTPARAGRAPH)
range.SetBegin(navigator)
range.SetEnd(navigator)
Call range.SetStyle(footerStyle)
Call richText.EmbedObject(EMBED_ATTACHMENT, "", "SomeFile")
richText.Update
'Process your doc.
This example generates this rich text:
1. NotesDocument.RenderToRTItem method
The other way is to use NotesDocument.RenderToRTItem method. For this method you need to create a form and style it as you need. For example, create a form "Message" and add to this form four fields:
And use this form in your code:
Dim ses As New NotesSession
Dim db As NotesDatabase
Dim messageDoc As NotesDocument
Dim attachment As NotesRichTextItem
Dim description(7) As String
Dim doc As NotesDocument
Dim richText As NotesRichTextItem
Set db = ses.CurrentDatabase
Set messageDoc = db.CreateDocument
messageDoc.Form = "Message"
messageDoc.Header = "Header"
For index% = 0 To Ubound(description)
description(index%) = "Description" & index%
Next
messageDoc.Description = description
messageDoc.Footer = "Footer"
Set attachment = messageDoc.CreateRichTextItem("Attachment")
Call attachment.EmbedObject(EMBED_ATTACHMENT, "", "SomeFile")
'Create your doc.
'Generate rich text content:
Set richText = doc.CreateRichTextItem("Body")
Call messageDoc.RenderToRTItem(richText)
richText.Update
'Process your doc.
This example generates this rich text:
2. NotesUIDocument.Import method
You can genereate the rich text content somewhere else and import it to your document by using NotesUIDocument.Import method.
Here is example for importing html content:
Dim ses As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim richText As NotesRichTextItem
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
'Generate html file
tempdir$ = Environ("Temp")
file = Freefile
filename$ = tempdir$ & "\temp.html"
Open filename$ For Output As file
Print #file, "<u>Header</u><br>"
For index% = 0 To 7
Print #file, "<b>Description" & index% & "</b><br>"
Next
Print #file, "<font color='red'>Footer</font><br><br>"
Close file
Set db = ses.CurrentDatabase
Set doc = db.CreateDocument
'Create your doc.
'Add attachment to rich text:
Set richText = doc.CreateRichTextItem("Body")
Call richText.EmbedObject(EMBED_ATTACHMENT, "", "SomeFile")
Set uidoc = ws.EditDocument(True, doc)
uidoc.GotoField("Body")
uidoc.Import "html", filename$
'Process your doc.
This example generates this rich text:
Please note that this code IS NOT MINE
I took it from user John_W in a mr excel post, I'm just pasting it here because I wanted to share something that helped me as it might help others. Also, I won't link the page here because I don't think it's fair with Stack Overflow but I have a big Thank You for John_W for sharing this online.
Sub Notes_Email_Excel_Cells()
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then
NDatabase.OPENMAIL
End If
'Create a new document
Set NDoc = NDatabase.CreateDocument
With NDoc
.SendTo = "email.address#email.com" 'CHANGE THIS
.CopyTo = ""
.subject = "Pasted Excel cells " & Now
'Email body text, including marker text which will be replaced by the Excel cells
.body = "Text in email body" & vbNewLine & vbNewLine & _
"**PASTE EXCEL CELLS HERE**" & vbNewLine & vbNewLine & _
"Excel cells are shown above"
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it
Set NUIdoc = NUIWorkSpace.EDITDocument(True, NDoc)
With NUIdoc
'Find the marker text in the Body item
.GotoField ("Body")
.FINDSTRING "**PASTE EXCEL CELLS HERE**"
'.DESELECTALL 'Uncomment to leave the marker text in place (cells are inserted immediately before)
'Replace it with the Excel cells
Sheets("Sheet1").Range("A1:E6").Copy 'CHANGE THIS
.Paste
Application.CutCopyMode = False
.Send
.Close
End With
Set NSession = Nothing
End Sub

How do I keep the new structure of web imported data after refresh?

I am creating an Excel database. I would like to import names, emails and job positions of all employees of a firm from the firm website.
I choose Data->From Web and select the whole page, as it is the only possibility.
The page shows no table with data; just a long list of photos of employees with names, emails and job positions next to them
I import the data into my Excel spreadsheet: the format is very bad. So I begin cut and paste creating a column for "names", one for "email" and similarly for "job position". All other information is manually canceled.
I would like to refresh data keeping this new format. Unfortunately, every time I refresh the imported data using the "refresh all" button, they return to the original format.
How can I keep the new format of my web imported data, after refresh?
I thank you all for your support!
Kr,
A
I've put together an example that will extract the name and title from that page you specified and put them into sheet 1.
The code will only work providing the layout of the underlying html remains the same. It does not support updating of an existing list (anything on sheet 1 is removed prior to reading the list again)
To use this code you must place it in a new code module (not the worksheet or workbook sections) and you can run it either from the code editor or via the macros menu in the main excel window.
' Note: This code requires the following references to be loaded.
' Microsoft HTML Object Library (mshtml.tlb)
' Microsoft Internet Controls (ieframe.dll)
' To add a reference
' In the VBA Code Editor, in the Tools Menu click the References item
' Scroll through the list and ensure that the references are selected
' Press OK and your done.
Sub Scrape()
Dim Browser As InternetExplorer
Dim Document As HTMLDocument
Dim Element As IHTMLElement
Dim Elements As IHTMLElementCollection
Dim empName As String
Dim empTitle As String
Dim Sheet As Worksheet
Set Sheet = ThisWorkbook.ActiveSheet
Sheet.UsedRange.ClearContents ' Nuke the old list
Set Browser = New InternetExplorer
Browser.navigate "http://www.hsbc.com/about-hsbc/leadership"
Do While Browser.Busy And Not Browser.readyState = READYSTATE_COMPLETE
DoEvents
Loop
Set Document = Browser.Document
Set Elements = Document.getElementsByClassName("profile-col1")
For Each Element In Elements
empName = Trim(Element.Children(1).Children(0).innerText)
empTitle = Trim(Element.Children(1).Children(1).innerText)
Sheet.Range("A1:B1").Insert xlShiftDown
Sheet.Cells(1, 1).Value = empName
Sheet.Cells(1, 2).Value = empTitle
'Debug.Print "[ name] " & empName
'Debug.Print "[ title] " & empTitle
Next Element
Set Browser = Nothing
Set Elements = Nothing
End Sub

Copy email to the clipboard with Outlook VBA

How do I copy an email to the clipboard and then paste it into excel with the tables intact?
I am using Outlook 2007 and I want to do the equivalent of
"Click on email > Select All > Copy > Switch to Excel > Select Cell > Paste".
I have the Excel Object Model pretty well figured out, but have no experience in Outlook other than the following code.
Dim mapi As NameSpace
Dim msg As Outlook.MailItem
Set mapi = Outlook.Application.GetNamespace("MAPI")
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
I must admit I use this in Outlook 2003, but please see if it works in 2007 as well:
you can use the MSForms.DataObject to exchange data with the clipboard. In Outlook VBA, create a reference to "Microsoft Forms 2.0 Object Library", and try this code (you can of course attach the Sub() to a button, etc.):
Sub Test()
Dim M As MailItem, Buf As MSForms.DataObject
Set M = ActiveExplorer().Selection.Item(1)
Set Buf = New MSForms.DataObject
Buf.SetText M.HTMLBody
Buf.PutInClipboard
End Sub
After that, switch to Excel and press Ctrl-V - there we go!
If you also want to find the currently running Excel Application and automate even this, let me know.
There's always a valid HTMLBody, even when the mail was sent in Plain Text or RTF, and Excel will display all text attributes conveyed within HTMLBody incl. columns, colors, fonts, hyperlinks, indents etc. However, embedded images are not copied.
This code demonstrates the essentials, but doesn't check if really a MailItem is selected. This would require more coding, if you want to make it work for calendar entries, contacts, etc. as well.
It's enough if you have selected the mail in the list view, you don't even need to open it.
I finally picked it up again and completely automated it. Here are the basics of what I did to automate it.
Dim appExcel As Excel.Application
Dim Buf As MSForms.DataObject
Dim Shape As Excel.Shape
Dim mitm As MailItem
Dim itm As Object
Dim rws As Excel.Worksheet
'code to open excel
Set appExcel = VBA.GetObject(, "Excel.Application")
'...
'code to loop through emails here
Set mitm = itm
body = Replace(mitm.HTMLBody, "http://example.com/images/logo.jpg", "")
Call Buf.SetText(body)
Call Buf.PutInClipboard
Call rws.Cells(i, 1).PasteSpecial
For Each Shape In rws.Shapes
Shape.Delete 'this deletes the empty shapes
Next Shape
'next itm
I removed the logo urls to save time, and when you're dealing with 300 emails, that translates into at least ten minutes saved.
I got the code I needed from a TechRepublic article, and then changed it to suit my needs. Many thanks to the accepted answerer of this question for the clipboard code.
Ok so I will have to make certain assumptions because there is information missing from your question.
Firstly you didn't say what mailformat the message is... HTML would be the easiest, the process will be different for RTF and not possible in plaintext
Since you are refering to tables I will assume they are HTML tables and the mail format is HTML.
Also it is not clear from your question if you want the table content pasted seperately (1 excel cell per table cell) and the rest of the emails bodytext pasted into 1 cell or several?
finally you haven't really said if you want the VBA running from Outlook or Excel (not that important but it affects which intrinsic objects are available.
Anyway code sample:
Outlook code to access the htmlbody prop
Dim mapi As Namespace
Set mapi = Application.Session
Dim msg As MailItem
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526)
Dim strHTML as String
strHTML = msg.HTMLBody
' There is no object model collection for html tables within the htmlbody (which is a string of html) you will need to parse the html and collect the tables before inserting into Excel.
After a while again, I found another way. MailItem.Body is plain text, and has a tab character between table cells. So I used that. Here is the gist of what I did:
Sub Import()
Dim itms As Outlook.Items
Dim itm As Object
Dim i As Long, j As Long
Dim body As String
Dim mitm As Outlook.MailItem
For Each itm In itms
Set mitm = itm
ParseReports (mitm.body) 'uses the global var k
Next itm
End Sub
Sub ParseReports(text As String)
Dim table(1 To 1000, 1 To 11) As String 'I'm not expecting to see a thousand rows!
Dim drow(1 To 11) As String
For Each Row In VBA.Split(text, vbCrLf)
j = 1
For Each Col In VBA.Split(Row, vbTab)
table(i, j) = Col
j = j + 1
Next Col
i = i + 1
Next Row
For i = 1 To l
For j = 1 To 11
drow(j) = table(i, j)
Next j
hws.Range(hws.Cells(k, 1), hws.Cells(k, 11)) = drow
k = k + 1
Next i
End Sub
Average: 77 emails processed per second. I do some minor processing and extracting.

Resources