LotusNotes 8.5 - Adding a row to a table with a button - lotus-notes

I am an intern and learning LotusNotes currently, so am not very fluent with it yet.
My question is, how can I program an action button to add a row to an existing table in LotusNotes 8.5?
I have tried the following code, but it has not worked for me,
Sub Click(Source As Button)
Dim uiw As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = uiw.CurrentDocument
Dim doc As NotesDocument
Set doc = uidoc.Document
Dim Body As NotesRichTextItem
Set body = doc.GetFirstItem("Body")
If body Is Nothing Then
Msgbox "Click on the Reset the demo action to create the table first."
End If
Dim rows As Integer, rownumber As Integer, numrowstoadd As Integer
Dim strrownumber As String, strrowstoadd As String
Dim rtnav As NotesRichTextNavigator
Set rtnav = body.CreateNavigator
Dim rttable As NotesRichTextTable
Set rttable = rtnav.GetFirstElement(RTELEM_TYPE_TABLE)
If rttable Is Nothing Then
Msgbox "No table created - use the Reset the demo action first."
Else
rows=rttable.RowCount
strrowstoadd = Inputbox("Enter the number of rows to add.")
If Isnumeric( strrowstoadd ) Then
numrowstoAdd = Cint(strrowstoAdd)
If numrowstoAdd <= 0 Then
Msgbox "Enter a number greater than zero."
Exit Sub
End If
Else
Msgbox ("Enter a integer number only.")
Exit Sub
End If
strrownumber = Inputbox("Enter the number corresponding to the row to start adding at, no greater than " & rows & ".")
If Isnumeric( strrownumber ) Then
rownumber = Cint(strrownumber)
If rownumber < 0 Or rownumber > rows Then
Msgbox ("You entered too high a number or a number less than zero, try again.")
Exit Sub
End If
Else
Msgbox ("Enter a integer number only.")
Exit Sub
End If
Call rttable.AddRow(numrowstoadd, rownumber)
End If
doc.save True, True
uidoc.Close
Call uiw.EditDocument(False,doc)
End Sub
Any help would be great. Thanks!

Without taking a detailed look at your code, I believe the fundamental problem you are facing is most likely the fact that the NotesRichText class is part of what we call the "back end classes" for Notes. That means that it is one of the objects that represents the in-memory version of data from an NSF file in its storage format, and this is not the same as the "front end classes". Those are objects that represent the data that the user sees and edits. You can tell the front end from back end classes by the prefix NotesUI for all the front end classes.
The thing is, the objects in the front end classes and back end are kept synchronized except for rich text, and what that means is that changes that you make to NotesRichText objects do occur in memory, and the are saved to the NSF file if you call NotesDocument.save(), but they are not reflected in what you see on the screen until you do something to reload the front end data from the back end. Here's a link to a wiki page that demonstrates a technique for doing that.

You wrote "but it has not worked for me". I tried your code and it works. I suggest you just few changes in order to make it work better:
close the doc before working with the table in the RT (back end) just before Dim Body As NotesRichTextItem
uidoc.save 'to save any change done
doc.saveoptions = "0"'to avoid do you want to save
uidoc.Close True
in place of the 3 last lines:
doc.Save True, True
Call uiw.EditDocument(True,doc)
NB you have to add Exit Sub after "Click on the Reset the demo action to create the table first" and after "No table created"

Related

How can I make removal of Strikethrough text in Excel cells using XML parsing more robust?

I have a complex spreadsheet with many cells of text containing random mixtures of normal text and text with strikethrough. Before I scan a cell for useful information, I have to remove the struck through text. I intially achieved this (with VBA) using the Characters object, but it was so slow as to be totally impractical, for business purposes. I was then kindly supplied with some code (on this site) that parses the XML encoding. This was 1000's of times faster, but it occassionally causes the following error:
"The parameter node is not a child of this node".
So far, it only happens in heavily loaded cells (1000's of characters), otherwise it works fine. I cannot see anything wrong in the code or the XML structure of the problem cells, although I am a total newbie to XML. Using the VBA debugger, I know the error is occurring when RemoveChild() is called, typically when it has already worked without error on a few struck through sections of a cell's text.
Is there a way I could make the following code more robust?
Public Sub ParseCellForItems(TargetCell As Excel.Range, ItemsInCell() As String)
Dim XMLDocObj As MSXML2.DOMDocument60
Dim x As MSXML2.IXMLDOMNode
Dim s As MSXML2.IXMLDOMNode
Dim CleanedCellText As String
On Error GoTo ErrorHandler
Call UnstrikeLineBreakCharsInCell(TargetCell)
Set XMLDocObj = New MSXML2.DOMDocument60
'Add some namespaces.
XMLDocObj.SetProperty "SelectionNamespaces", "xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
"xmlns:ht='http://www.w3.org/TR/REC-html40'"
'Load the cell data as XML into XMLDOcObj.
If XMLDocObj.LoadXML(TargetCell.Value(xlRangeValueXMLSpreadsheet)) Then
Set x = XMLDocObj.SelectSingleNode("//ss:Data") 'Cell content.
If Not x Is Nothing Then
Set s = x.SelectSingleNode("//ht:S") 'Struck through cell content.
Do While Not s Is Nothing
x.RemoveChild s
Set s = x.SelectSingleNode("//ht:S")
Loop
CleanedCellText = XMLDocObj.Text
'Parse CleanedCellText for useful information.'
'...
End If
End If
Set XMLDocObj = Nothing
'Presumably don't have to 'destroy' x and s as well, as they were pointing to elements of XMLObj.
Exit Sub
ErrorHandler:
Call RaiseError(Err.Number, Err.Source, "ParseCellForItems()", Err.Description, Erl)
End Sub
Public Sub UnstrikeLineBreakCharsInCell(TargetCell As Excel.Range)
Dim mc As MatchCollection
Dim RegExObj1 As RegExp
Dim Match As Variant
On Error GoTo ErrorHandler
Set RegExObj1 = New RegExp
RegExObj1.Global = True
RegExObj1.IgnoreCase = True
RegExObj1.Pattern = "\n" 'New line. Equivalent to vbNewLine.
Set mc = RegExObj1.Execute(TargetCell.Value)
For Each Match In mc
TargetCell.Characters(Match.FirstIndex + 1, 1).Font.Strikethrough = False
Next Match
Set mc = Nothing
Set RegExObj1 = Nothing
Exit Sub
ErrorHandler:
Call RaiseError(Err.Number, Err.Source, "UnstrikeLineBreakCharsInCell()", Err.Description, Erl)
End Sub
Yep, as per Tim Williams' comment, making sure you're calling RemoveChild() from its immediate parent fixes the problem:
Set s = x.SelectSingleNode("//ht:S")
Do While Not s Is Nothing
s.ParentNode.RemoveChild s
Set s = x.SelectSingleNode("//ht:S")
Loop

Cancel Option GetOpenFilename(Multiselect:= True)

I have the following question: when I use the GetFileOpenFileName option with
Multiselect = True it returns the results as a Array if I selected one file or more, but if I click "Cancel" it returns as a boolean vartype. What should I do to avoid the
error 13 "Incompatible Type
when someone clicks it.
Besides, I already tried to test if(vartype(filename) = vbBoolean) then or if(filename = False) then to exit sub, but the first one I took the same error and the second one it said that I'm not allowed to assign values to filename if I select some file.
Here is the code.
public sub open_file()
dim i as integer
Dim filename() As Variant
filename = Application.GetOpenFilename(Title:="Arquivos em Excel", MultiSelect:=True, FileFilter:="Arquivos em Excel,*.xls*")
For i = 1 To UBound(filename)
msgbox filename(i)
next i
end sub
As per comments from both #Brian M Stafford and #braX, your code should be amended as follows...
Public Sub open_file()
Dim i As Integer
Dim filename As Variant
filename = Application.GetOpenFilename(Title:="Arquivos em Excel", MultiSelect:=True, FileFilter:="Arquivos em Excel,*.xls*")
If Not IsArray(filename) Then
MsgBox "User cancelled!", vbExclamation 'optional
Exit Sub
End If
For i = 1 To UBound(filename)
MsgBox filename(i)
Next i
End Sub
To clarify, notice that filename is declared as Variant, not as an array whose elements are a Variant data type.
As such, filename can be assigned either an array containing the filenames when one or more files are selected, or a boolean value when the user cancels.
Also notice that we test whether filename is an array to determine whether the user has selected one or more files. If not, it exits the sub. Otherwise, it continues.

How do I copy the contents of one word document to the end of another using vba?

Goal for my project:
I want to be able to copy the contents of one document and append that selection to the end of another document.
What it does... (this is just background info so you understand why I am trying to do this):
I am trying to dynamically produce a document which quotes a variety of information regarding different parts and materials involved for a product.
The document itself has a consistent format which I have broken down and separated into two documents. The first contains a bunch of data that needs to be entered manually, and is where I want to append all additional content. The second contains roughly a dozen custom fields which are updated from an excel spreadsheet in VBA. For a single part and as a single doc this works as I want it (my base case). However my issue is when there are multiple parts for a project.
The Problem:
For multiple parts I have to store information in an array which changes in size dynamically as each additional part is added. When someone has added all the necessary parts they can select a button called "Create Quote".
Create quote runs a procedure which creates/opens separate copies of the two template documents mentioned above (saved on my computer). It then iterates through the array of parts and updates all the custom field in the 2nd document (no problems). Now I just need the contents of the 2nd document appended to the end of the first which is my problem.
What I want:
Ideally, my procedure will continue to iterate through every part in the array - updating custom fields, copy then paste the updated text, repeat... Until every part is included in the newly generated quote.
What I Tried - this code can be found in my generate quote procedure
I have tried many of the examples and suggestions provided by people who had similar question, but I don't know if its because I am operating from an excel doc, but many of their solution have not worked for me.
This is my most recent attempt and occurs after each iteration of the for loop
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
QUOTE PROCEDURE - I am only including a handful of the fields I am updating because its not necessary to show them all
Private Sub quote_button_Click()
On Error GoTo RunError
Dim wrdApp1, wrdApp2 As Word.Application
Dim wrdDoc1, wrdDoc2 As Word.Document
Set wrdApp1 = CreateObject("Word.Application")
Set wrdApp2 = CreateObject("Word.Application")
wrdApp1.Visible = True
wrdApp2.Visible = True
Set wrdDoc1 = wrdApp1.Documents.Add(Template:="C:\MWES\AQT_v1.1(start).docm", NewTemplate:=False, DocumentType:=0)
Set wrdDoc2 = wrdApp2.Documents.Add(Template:="C:\MWES\AQT_v2.1(format).docm", NewTemplate:=False, DocumentType:=0)
Dim propName As String
For i = LBound(part_array, 1) To UBound(part_array, 1)
For Each prop In wrdDoc2.CustomDocumentProperties
propName = prop.name
' Looks for and sets the property name to custom values of select properties
With wrdDoc2.CustomDocumentProperties(propName)
Select Case propName
Case "EST_Quantity"
.value = part_array(i, 0) ' "QTY" ' Sheet1.Cells(1, 3) 'NA
Case "EST_Metal_Number"
.value = part_array(i, 1) ' "METAL_#" ' Sheet1.Cells(2, 3) 'NA"
Case "EST_Metal_Name"
.value = part_array(i, 2) ' "METAL_N" ' Sheet1.Cells(5, 2)
End Select
End With
Next prop ' Iterates until all the custom properties are set
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
Next i ' update the document for the next part
RunError: ' Reportd any errors that might occur in the system
If Err.Number = 0 Then
Debug.Print "IGNORE ERROR 0!"
Else
Dim strError As String
strError = "ERROR: " & Err.Number & vbCrLf & Err.Description & vbCrLf & Erl
MsgBox strError
Debug.Print strError & " LINE: " & Erl
End If
End Sub
I apologize this was so long winded. Let me know if there is anything confusing or you may want clarified. I think I included everything though.
I think you're close, so here are a couple of comments and an example.
First of all, you're opening two separate MS Word Application objects. You only need one. In fact, it's possible that the copy/paste is failing because you're trying to copy from one Word app to a document opened in the other. (Trust me, I've seen weird things like this.) My example below shows how to do this by only opening a single application instance.
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication() 'more on this function below...
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
While I don't often write code for Word, I've found that there are so many different ways to get at the same content using different objects or properties. This is always a source of confusion.
Based on this answer, which has worked well for me in the past, I then set up the source and destination ranges to perform the "copy":
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
Here is the whole module for reference:
Option Explicit
Sub AddDocs()
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning()
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication()
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
doc2.Close SaveChanges:=True
doc1.Close
If Not wordWasRunning Then
mswApp.Quit
End If
End Sub
Here's the promised note on a couple functions I use in the sample. I've built up a set of library functions, several of which help me access other Office applications. I save these modules as .bas files (by using the Export function in the VBA Editor) and import them as needed. So if you'd like to use it, just save the code below in using a plain text editor (NOT in the VBA Editor!), then import that file into your project.
Suggested filename is Lib_MSWordSupport.bas:
Attribute VB_Name = "Lib_MSWordSupport"
Attribute VB_Description = "Variety of support functions operating on MS Word"
Option Explicit
Public Function IsMSWordRunning() As Boolean
Attribute IsMSWordRunning.VB_Description = "quick check to see if an instance of MS Word is running"
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
Attribute AttachToMSWordApplication.VB_Description = "finds an existing and running instance of MS Word, or starts the application if one is not already running"
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function

How to filter selection document to prevent user from select different document based on field "status"

Before this I ask this question and #Torsten Link suggest that I filter document to prevent user from select different document. Basically I have view, and in this view I have list of document sort by Faulty Status which I set as PFStatus. So I have three status which is Obsolete, Spoilt, and Not Found. So I want to filter so that user choose either these three status only and cannot be mixed up.
So I try to filter using below code but nothing happened.
Set doc = dc.GetFirstDocument()
If (doc.PFStatus(0) = "Obsolete" And doc.PFStatus(0) = "Spoilt" And doc.PFStatus(0) = "Not Found") Then
Messagebox"Please choose either one Write Off selection!"
Exit Sub
Elseif (doc.PFStatus(0) = "Obsolete" And doc.PFStatus(0) = "Spoilt") Then
Msgbox"Please choose only one Write Off selection!"
Exit Sub
Elseif (doc.PFStatus(0) = "Obsolete" And doc.PFStatus(0) = "Not Found") Then
Msgbox"Please choose only one Write Off selection!"
Exit Sub
Elseif (doc.PFStatus(0) = "Spoilt" And doc.PFStatus(0) = "Not Found") Then
Msgbox"Please choose only one Write Off selection!"
Exit Sub
Else
'Some code...
End If
So how can I filter selection of documents? Did I put the code in wrong way? Any help I really appreciate. Thank you. :)
Update question
Below are my view name "WriteOff". And I have a button to create new batch. So I want to try prevent user from create a batch with mixed up Faulty Status.
I created a sample on how to do this
Best is not to put your code in the button, but to create an agent to put your code in. Like this, you don't need to refresh your view while debugging your code.
Set 'Agent list selection' as trigger and Target = None.
Create a button in the view using the following formula (replace 'batch process' by your agent name):
#Command([ToolsRunMacro];"(batch process)")
Here's an example of the agent code on how you can check if pfstatus in selected docs is the same.
Option Public
Option Declare
Sub Initialize
Dim col As NotesDocumentCollection
Dim doc As NotesDocument
Dim vwUI As NotesUIView
Dim ws As New NotesUIWorkspace
Dim session As New NotesSession
Dim dbcurrent As NotesDatabase
Set dbCurrent = session.currentdatabase
'Use vwui.documents to keep documents selected if the agent runs.
'Like this, a user can deselect a faulty document.
'Don't forget to deselect all docs at the end of your code
Set vwui = ws.Currentview
Set col = vwui.Documents
'If a user did not 'select' a document (eg V marker before the docline), but merely positioned on a document,
'you need to create a single doc collection based on the caretnoteid (= id of selected document)
If col.count = 0 And vwui.caretnoteid <> "" Then
Set doc = dbCurrent.Getdocumentbyid(vwui.caretnoteid)
Set col = dbCurrent.createdocumentcollection()
Call col.Adddocument(doc)
End If
'Get status from first document to get status to compare against
Dim statusRef As String
Set doc = col.getfirstdocument
If doc Is Nothing Then Exit Sub 'avoid error when no doc is selected
statusRef = doc.pfStatus(0)
'loop other selected documents to compare status
Set doc = col.getNextDocument(doc)
While Not doc Is Nothing
If doc.pfStatus(0) <> statusRef Then
'A document with another status is selected, so do not continue
Msgbox"Please choose only one Write Off selection!"
Exit sub
End If
Set doc = col.getNextDocument(doc)
Wend
'If code gets here, you can loop all documents again to do you batch processing
'Reset doc to first doc in selected collection
Set doc = col.getfirstdocument()
While Not doc Is Nothing
'... some code to run on current doc in the loop ...
Set doc = col.getNextDocument(doc)
Wend
'Deselect documents at the end of your code
Call vwui.Deselectall()
End Sub
Is PFStatus a multi-value field? If it isn't, it can never have more than 1 value (unless you set more than one value programmatically). Or is it a checkbox field?
I think it would be the best if you simply disallow the selection of documents from multiple categories in the view. See https://www.ibm.com/support/knowledgecenter/en/SSVRGU_9.0.1/basic/H_ONSELECT_EVENT.html
IMHO a status field should never be directly input by the user. You should have buttons that guide the user to perform some functions AND change the status in the meantime.

Excel VBA lock access db records via DAO for editing

I have an Excel application I've developed and now want to store all of the data in an Access file (rather than an Excel sheet). I'm able to read data in and write data out, my issue has to do with handling concurrent users. There's around 150-200 square images that when clicked open up a UserForm that is loaded with data. Users are able to go in and edit any of that data so I want to make sure that two users are not editing a record at the same time. Given the size of it I do not want to lock down the entire file, just the one record. Everything I've read so far indicates that the record only locks while in .Edit, however I want to lock it as soon as the user opens the UserForm, then apply any edits they made and unlock it.
Here's where I'm at now with the code, the first three sections are where the main focus is with this:
Sub OpenDAO()
Set Db = DBEngine.Workspaces(0).OpenDatabase(Path, ReadOnly:=False)
strSQL = "SELECT * FROM AccessDB1 WHERE ID = 5" '& Cells(1, Rng.Column)
Set Rs = Db.OpenRecordset(strSQL)
End Sub
'==========================================================================
Sub CloseDAO()
On Error Resume Next
Rs.Close
Set dbC = Nothing
Set Rs = Nothing
Set Db = Nothing
End Sub
'==========================================================================
Function ADO_update(Target As Range)
Set ws = Sheets("Sheet1")
Set dbC = DBEngine.Workspaces(0).Databases(0)
'if no change exit function
If Target.Value = oldValue Then GoTo 0
On Error GoTo trans_Err
'begin the transaction
DBEngine.BeginTrans
dbC.Execute "UPDATE AccessDB1 SET Field1 = 5 WHERE ID= 5"
DBEngine.CommitTrans dbForceOSFlush
Exit Function
trans_Err:
'roll back the transaction
Workspaces(0).Rollback
0
End Function
'==========================================================================
Function MakeSQLText(data As Variant)
If (IsNumeric(data)) Then
MakeSQLText = data
Else
MakeSQLText = "'" & Replace(data, "'", "''") & "'"
End If
End Function

Resources