Sub Initialize On Error Goto ProcessErr
Dim ws As New NotesUIWorkspace
Dim session As New NotesSession
'Dim db As NotesDatabase
Dim maildb As New NotesDatabase( “”, “” )
Dim view As Notesview
Dim orgView As NotesView
Dim MACView As NotesView
Dim MACdoc As NotesDocument
Dim orgdoc As NotesDocument
Dim doc As NotesDocument
Dim seldoc As NotesDocument
Dim rec As UIRecepient
Dim maildoc As NotesDocument
Dim uidoc As NotesUIDocument
Dim rtitemA As NotesRichTextItem
Dim rtitemB As NotesRichTextItem
Dim findarray(4), replacearray(4) As Variant
Dim msg As String
Dim col As NotesDocumentCollection
Dim conf As NotesDocument 'configuration document
Dim profiledoc As NotesDocument
Dim infoDelDays As Integer
Dim currMonth As Integer
Dim currQuarter As String
Dim QEndDate As NotesDateTime
Dim Quarter As String
Dim selLevel() As Variant
Dim rtNav As NotesRichTextNavigator
Dim strToReplace(1) As String
Dim strselLevel As String
Dim count , t As Integer
Set db = session.CurrentDatabase
Set view = db.GetView(“vwLuReminder”)
Set conf = view.GetDocumentByKey(“Reminder for Risk Managers”) 'get reminder configuration document
Set seldoc = New NotesDocument(db)
Call conf.CopyAllItems( seldoc, True )
findarray(0) = “current year”
findarray(1) = “current year - 1”
findarray(2) = “current year - 2”
findarray(3) = “current year - 3”
replacearray(0) = Cstr(Year(Today))
replacearray(1) = Cstr(Year(Today) - 1)
replacearray(2) = Cstr(Year(Today) - 2)
replacearray(3) = Cstr(Year(Today) - 3)
seldoc.lstTRPYear = Arrayreplace(seldoc.lstTRPYear, findarray, replacearray)
seldoc.defTRPYear = Arrayreplace(seldoc.defTRPYear, findarray, replacearray)
seldoc.Subject = “Create Reminder for Risk Managers”
Set profileDoc = db.GetProfileDocument(“AdminProfile”) 'get TRP Configuration document
infoDelDays = profileDoc.InfoDeliveryDaysBefore(0)
If ws.DialogBox(“(dlgCreateMailReminder)”, True,False, False, False,_
False, False,“Select Recipients”, seldoc,True) Then 'ask for parameters, if OK then…
If seldoc.MAC_or_BU(0) = “” Then
msg = msg + “Org/Reporting Unit selection is missing” + Chr(10)
Else
If Seldoc.MAC_or_BU(0) = “1” Then
If seldoc.selMACUnit(0) = "" Then
msg = msg + "Reporting unit is missing" + Chr(10)
End If
Elseif Seldoc.MAC_or_BU(0) = “2” Then
If seldoc.selBDivision(0) = "" Then
msg = msg + "Org unit is missing" + Chr(10)
End If
Else
If seldoc.selLevel(0)="" Then
msg = msg + "Level of Org unit is missing" + Chr(10)
End If
End If
End If
If msg <> “” Then
Messagebox msg + Chr(10) + “Please restart the agent again and correct your selected options.”,“Invalid selection”
Else
Set rec = New UIRecepient 'create recepient collector
If Seldoc.MAC_or_BU(0) = “1” Then 'If Reporting unit has been selected
Set view = db.getview("vwTRPMACNotTakenOver") 'View with all the analysis documents
Set MACView = db.GetView("vwLUOrgUnit") 'View with all the MAC Unit documents
Dim keyarray(1) As String
Dim TRPArray(1) As String
Forall x In seldoc.selMACUnit
keyarray(0) = "fmMACUnit"
keyarray(1) = x
Set MACdoc = MACView.GetDocumentByKey(keyarray,True)
If Not MACdoc Is Nothing Then
Call rec.extractRecipient(MACDoc, seldoc.selMACRiskManager, "RiskManager")
Call rec.extractRecipient(MACDoc, seldoc.selMACRiskAssistant, "RiskAssistant")
End If
TRPArray(0) = seldoc.TRPYear(0)
TRPArray(1) = x
Set col = view.GetAllDocumentsByKey(TRPArray)
Set doc = col.GetFirstDocument
Do While Not doc Is Nothing 'loop through all selected docs and extract recepients
Call rec.extractRecipient(doc, seldoc.selSponsor, "PSponsor")
Call rec.extractRecipient(doc, seldoc.selFacilitator, "Facilitator")
Call rec.extractRecipient(doc, seldoc.selCoFacilitator, "CoFacilitator")
Call rec.extractRecipient(doc, seldoc.selBURiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selBURiskAssistant, "RiskAssistant")
Set doc = col.GetNextDocument(doc)
If seldoc.TRPYear(0) >= "2009" Then
If (doc.selLevel(0)="FA/BU" Or doc.selLevel(0)="LoB/SSU" ) And doc.FunctionalArea(0)="" Then
strselLevel="BU"
Elseif doc.selLevel(0)<>"" And doc.FunctionalArea(0)="Yes" Then
strselLevel="FA"
Else
strselLevel=doc.selLevel(0)
End If
Redim Preserve sellevel(count)
selLevel(count)=strselLevel
count=count+1
End If
Loop
End Forall
If seldoc.TRPYear(0) >= "2009" Then : Call updateQuarters(Fulltrim(R6ArrayUnique(selLevel)),seldoc.TRPYear(0))
Elseif Seldoc.MAC_or_BU(0) = “2” Then ’ If BS/BD has been selected
Dim query As String
Dim numdocs As Integer
Dim icount As Integer
Forall x In seldoc.selBDivision
Set orgView = db.GetView("vwLUBDManager")
Set orgdoc = orgView.GetDocumentByKey(x)
If Not orgdoc Is Nothing Then
Call rec.extractRecipient(orgdoc, seldoc.selBDRiskManager, "RiskManager")
Call rec.extractRecipient(orgdoc, seldoc.selBDRiskAssistant, "RiskAssistant")
End If
End Forall
Set view = db.GetView("vwVisOrgUnitsPerYear")
query = "([TRPYear] = " + seldoc.TRPYear(0) + ")"
If seldoc.selSBU(0) <> "" Then
query = query + | AND ([OrgUnit] = | + |"| + Implode(seldoc.selSBU, |",[OrgUnit] = "|) + |")|
Else
If seldoc.selCountry(0) <> "" Then
query = query + | AND ([OrgUnit] = | + |"| + Implode(seldoc.selCountry, |",[OrgUnit] = "|) + |")|
Else
If seldoc.selRegion(0) <> "" Then
query = query + | AND ([OrgUnit] = | + |"| + Implode(seldoc.selRegion, |",[OrgUnit] = "|) + |")|
Else
If seldoc.selBDivision(0) <> "" Then
query = query + | AND ([OrgUnit] = | + |"| + Implode(seldoc.selBDivision, |",[OrgUnit] = "|) + |")|
End If
End If
End If
End If
Print "Collect analysis documents with " + query
numdocs = view.FTSearch( query, 0 )
Set doc = view.GetFirstDocument
Do While Not (doc Is Nothing) 'loop through all analysis docs
icount = icount + 1
Print "Perform analysis document " + Cstr(icount) + " of " + Cstr(numdocs) + " analysis document(s)"
Call rec.extractRecipient(doc, seldoc.selSponsor, "PSponsor")
Call rec.extractRecipient(doc, seldoc.selFacilitator, "Facilitator")
Call rec.extractRecipient(doc, seldoc.selCoFacilitator, "CoFacilitator")
Call rec.extractRecipient(doc, seldoc.selBURiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selBURiskAssistant, "RiskAssistant")
If seldoc.TRPYear(0) >= "2009" Then
If (doc.selLevel(0)="FA/BU" Or doc.selLevel(0)="LoB/SSU" ) And doc.FunctionalArea(0)="" Then
strselLevel="BU"
Elseif doc.selLevel(0)<>"" And doc.FunctionalArea(0)="Yes" Then
strselLevel="FA"
Else
strselLevel=doc.selLevel(0)
End If
Redim Preserve sellevel(count)
selLevel(count)=strselLevel
count=count+1
End If
Set doc=view.GetNextdocument(doc)
Loop
If seldoc.TRPYear(0) >= "2009" Then : Call updateQuarters(Fulltrim(R6ArrayUnique(selLevel)),seldoc.TRPYear(0))
Else ’ Level of Org Unit is selected
Dim TRPArr(1) As String
Set view = db.getview("vwTRPselLevelNotTakenOver")
Forall x In seldoc.selLevel
TRPArr(0) = seldoc.TRPYear(0)
TRPArr(1) = x
Set col = view.GetAllDocumentsByKey(TRPArr)
Set doc = col.GetFirstDocument
Do While Not doc Is Nothing 'loop through all selected docs and extract recepients
Call rec.extractRecipient(doc, seldoc.selSponsor, "PSponsor")
Call rec.extractRecipient(doc, seldoc.selFacilitator, "Facilitator")
Call rec.extractRecipient(doc, seldoc.selCoFacilitator, "CoFacilitator")
Select Case x
Case "BU"
Call rec.extractRecipient(doc, seldoc.selBURiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selBURiskAssistant, "RiskAssistant")
Case "FA"
Call rec.extractRecipient(doc, seldoc.selFARiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selFARiskAssistant, "RiskAssistant")
Case "BS/BD"
Call rec.extractRecipient(doc, seldoc.selBDRiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selBDRiskAssistant, "RiskAssistant")
Case "Group"
Call rec.extractRecipient(doc, seldoc.selGroupRiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selGroupRiskAssistant, "RiskAssistant")
Case "Region"
Call rec.extractRecipient(doc, seldoc.selRegionRiskManager, "Responsible")
Call rec.extractRecipient(doc, seldoc.selRegionRiskAssistant, "RiskAssistant")
End Select
Set doc = col.GetNextDocument(doc)
Loop
Redim Preserve sellevel(count)
selLevel(count)=x
count=count+1
End Forall
Call updateQuarters(selLevel,seldoc.TRPYear(0))
End If
Call rec.getRecipient(seldoc) 'get recepients
''Call maildb.OpenMail 'open user’s mail db and create new mail
Set maildoc = db.CreateDocument
maildoc.sendTo = seldoc.sendTo
Dim Tmpcc As Variant
Dim Tmpbcc As Variant
Tmpcc= R6ArrayUnique(Arrayappend(seldoc.sendto,seldoc.copyto)) 'MS 24.10.2007
maildoc.copyTo= Fulltrim(Arrayreplace(Tmpcc,maildoc.sendTo,“” ))
' maildoc.copyTo = seldoc.copyTo
Tmpbcc= R6ArrayUnique(Arrayappend(Tmpcc,seldoc.blindcopyto))
maildoc.blindcopyTo= Fulltrim(Arrayreplace(Tmpbcc,Tmpcc,“” ))
' maildoc.blindcopyTo = seldoc.blindcopyTo
Set rtitemA = seldoc.GetFirstItem( “Body” )
Set rtitemB = maildoc.CreateRichTextItem( “body” )
Dim Tags(2) As String
Dim Replaced(1) As String
Dim infodate As Variant
Tags(0) = “”
Tags(1) = “”
Tags(2) = “”
Quarter=getCalenderQuarter(seldoc.TRPYear(0))
If seldoc.TRPYear(0) < “2009” Then : Call QEndDate.AdjustDay(infodeldays)
Replaced(0) = conf.Subject(0)
If seldoc.TRPYear(0) < “2009” Then : Replaced(1) = rtitemA.Text
Forall j In Replaced
Forall i In Tags
Do While Instr(j, i) <> 0
Select Case i
Case "<YEAR>"
j = Strleft(j, i) + Cstr(Year(Today)) + Strright(j, i)
Case "<INFODELIVERYDATE>"
j = Strleft(j, i) + Cstr(QEndDate.DateOnly) + Strright(j, i)
Case "<QUARTER>"
j = Strleft(j, i) + Quarter + Strright(j, i)
End Select
Loop
End Forall
End Forall
maildoc.subject = Replaced(0)
Dim rtrange As NotesRichTextRange
Dim flag As Variant
Dim replacestring As String
Dim strYearEndDueDate As String
Dim rtt As NotesRichTextTable
Dim profdoc As NotesDocument
Dim strToReplaceleft As String
Dim strToReplaceRight As String
Set profdoc=db.GetProfileDocument (“AdminProfile”)
Set rtitemA = seldoc.GetFirstItem( “Body” )
strToReplace(0)= “”
'strToReplace(0)= “”
'strToReplace(1)=“”
Dim strToPlace(0) As String
strToPlace(0)=rtitemA.text
If seldoc.TRPYear(0) >= “2009” Then
Dim trows As Integer, tcolumns As Integer
'Dim tablertitem As NotesRichTextItem
'Dim trtitem As NotesRichTextItem
'Set trtitem=profdoc.GetFirstItem("table")
'Set tablertitem=trtitem
Dim trtnav As NotesRichTextNavigator
Dim rtnavD As NotesRichTextNavigator
‘’ Dim rtt As NotesRichTextTable
Dim rtitemD As NotesRichTextItem
Dim rtpStyle As NotesRichTextParagraphStyle
Set rtpStyle = session.CreateRichTextParagraphStyle
Set rtitemD=maildoc.CreateRichTextItem("table")
Call rtitemD.AppendParagraphStyle(rtpStyle)
tcolumns =3
trows= Ubound(R6ArrayUnique(Fulltrim(selLevel)))
''rtpStyle.Alignment = ALIGN_LEFT
‘’ multival=Fulltrim(R6ArrayUnique(multiLevelofOrgunit))
Set trtnav = rtitemA.CreateNavigator
Set rtnavD =rtitemD.createnavigator
'Forall g In strTorePlace
flag = trtNav.FindFirstString("<UNIT>")
If flag Then
strToReplaceleft=Strleft(strtoplace(0), strToReplace(0))
strToReplaceRight = Strright(strtoplace(0),strToReplace(0))
Call rtitemD.AppendTable(trows,tcolumns,,RULER_ONE_INCH*7)
Call rtnavD.FindFirstElement(RTELEM_TYPE_TABLECELL)
For tRows% = 0 To trows-1 Step 1
For tColumns% = 0 To tcolumns-1 Step 1
Call rtitemD.BeginInsert(rtnavD)
Call rtitemD.AppendText(multiLevelofOrgunit(trows,tcolumns))
' Call rtitemA.AppendText(multival(trows,tcolumns))
Call rtitemD.EndInsert()
Call rtnavD.FindNextElement(RTELEM_TYPE_TABLECELL)
Next
Next
If Not rtnavD.FindFirstElement(RTELEM_TYPE_TABLE) Then
Messagebox "Could not find table",, "Fatal error"
Exit Sub
End If
Set rtt=rtnavD.GetElement
'Call rtitemB.AppendRTItem(rtitemD)
Call rtitemB.AppendText(strtoreplaceleft)
Call trtnav .FindFirstElement( RTELEM_TYPE_TEXTPARAGRAPH )
Set rtrange =rtitemA .CreateRange
replacestring = " "
''count = rtrange .FindAndReplace( "<UNIT>", replacestring, RT_REPL_ALL )
Call trtnav.SetPosition(rtrange)
'Else
' Call rtitemB.BeginInsert(trtnav)
' Call rtitemb.AppendText(g)
' Call rtitemB.EndInsert
End If
'' flag = trtnav.FindNextString( g )
'End Forall
''rtpStyle.Alignment = ALIGN_LEFT
''Call rTitemD.AppendParagraphStyle(rtt)
Call rtnavD.SetPosition (rtt)
Call rtitemB.AppendRTItem(rtitemD)
''Set rtitemB = maildoc.CopyItem(rtitemA,"body")
Call rtitemB.AppendText(strtoreplaceright)
Else ’ for 2008 documents
Call rtitemB.AppendText(Replaced(1))
Call rtitemB.AddNewLine( 3 )
End If
'Call rtitemB.AppendText(Replaced(1))
Call rtitemB.AddNewLine( 3 )
'Dim tableRtitem As New NotesRichTextItem(maildoc, “rtitemB”)
Dim rtitemC As NotesRichTextItem
Set rtitemC = seldoc.GetFirstItem( “Instructions” ) 'add instructions if available
If Not rtitemC Is Nothing Then
Call rtitemB.AppendRTItem( rtitemC )
End If
maildoc.form=“memo”
maildoc.save True, True
'Set uidoc = ws.EditDocument(True , maildoc )
End If
End If
ProcessErr:
If Err<>0 Then
Msgbox("Error in sub initialize: “+Error$+” at line no: "+Cstr(Erl))
Resume fin
End If
fin:
End Subaaaa
Here is my NotesRichTextParagraphStyle:
Set styles(i) = s.CreateRichTextParagraphStyle
styles(i).LeftMargin = RULER_ONE_INCH
styles(i).FirstLineLeftMargin = 0
'Set width of cell…
styles(i).RightMargin = RULER_ONE_INCH * 1.5
'Set alignment of cell contents …
styles(i).Alignment = ALIGN_LEFT
This is a function from a generic audit trail solution that stores audit trail details across multiple XML fields. The richtext stuff works for me (now) but I vaguely recall having some similar problems until I arrived at this.
hth,
dgg
Function addRichTextTable(pnsess As NotesSession, prtItm As NotesRichTextItem, pintRowCount As Integer) As Boolean
'// +++ GLOBAL VARIABLES +++
'// Constants:
'// SUBFORM_NAME = Name of this subform (source: form global declarations)
'// HOTSPOT_NAME = Name of this hotspot (source: declarations)
'// AXN_ID_VIEW = 1 (source: declarations)
'// AXN_ID_XPRT = 2 (source: declarations)
'// AXN_ID_XPRT_WRD = AXN_ID_XPRT + 0.1 (source: declarations)
'// AXN_ID_XPRT_XML = AXN_ID_XPRT + 0.2 (source: declarations)
'//
'// Class instances:
'// none
'//
'// Primitives:
'// none
'//
'// 01/07/2005 - Dallas Gimpel
'//
'// DESCRIPTION:
'// This function appends a NotesRichTextTable to the RichTextItem passed. The resulting
'// table is created with the required formatting by creating it with an array of
'// NotesRichTextParagraphStyle objects, the attributes of which have been determined by
'// way of fairly extensive testing (i.e., trial & error).
'//
'// INPUT:
'// pnsess - NotesSession, active NotesSession object
'// prtItm - NotesRichTextItem, the item to which a NotesRichTextTable is to be added
'// pintRowCount - Integer, number of rows with which to to create the NotesRichTextTable
'//
'// OUTPUT:
'// Function returns a boolean, true unless an error is encountered
On Error Goto errorHandler
Const COLUMN_COUNT = 4
Const RULER_ONE_INCH = 1440
Const ALIGN_RIGHT = 1
Const ALIGN_LEFT = 0
Dim rtpsStyleArray(0 To (COLUMN_COUNT - 1)) As NotesRichTextParagraphStyle
addRichTextTable = False
With iaschddoc
If Not Isnull(Arraygetindex(arrselLevel,.selLevel(0))) Then
If .TimeSlotFrom1(0) <= Today And Today <= .TimeSlotTo1(0) Then 'determine current quarter of the Level of Orgunit
multiLevelofOrgunit(c ,0)=.selLevel(0)
multiLevelofOrgunit(c,1)="Q1"
Set itmto = .GetFirstItem("TimeSlotTo1")
multiLevelofOrgunit(c,2)=Left(itmto.Text,10)
c=c +1
Elseif .TimeSlotFrom2(0) <= Today And Today <= .TimeSlotTo2(0) Then
multiLevelofOrgunit(c ,0)=.selLevel(0)
multiLevelofOrgunit(c,1)="Q2"
Set itmto = .GetFirstItem("TimeSlotTo2")
multiLevelofOrgunit(c,2)=Left(itmto.Text,10)
c=c +1
Elseif .TimeSlotFrom3(0) <= Today And Today <= .TimeSlotTo3(0) Then
multiLevelofOrgunit(c ,0)=.selLevel(0)
multiLevelofOrgunit(c,1)="Q3"
Set itmto = .GetFirstItem("TimeSlotTo3")
multiLevelofOrgunit(c,2)=Left(itmto.Text,10)
c=c +1
Elseif .TimeSlotFrom4(0) <= Today And Today <= .TimeSlotTo4(0) Then
multiLevelofOrgunit(c ,0)=.selLevel(0)
multiLevelofOrgunit(c,1)="Q4"
Set itmto = .GetFirstItem("TimeSlotTo4")
multiLevelofOrgunit(c,2)=Left(itmto.Text,10)
c=c +1
Else
'nothing
End If
End If
End With
'// NOTE:
'// The LeftMargin and FirstLineLeftMargin properties of the first column in the table
'// have to be set to a higher value for printing purposes. Otherwise, the table borders
'// will print, but the contents of the table cells will be cropped (by the printer?).
'// This can be tested by turning on the “Print crop marks” option from the “Page Setup”
'// tab of the “File Print” dialog (i.e., the dialog that appears when using the Print
'// method of NotesUIDocument or @Command([FilePrint])). I tinkered with this for quite
'// a while before arriving at a fairly satisfactory solution, but if someone else has
'// the time/patience to find a better solution, I’d really like to know about it! - dgg
'// 1st column = modifer’s name
Set rtpsStyleArray(0) = pnsess.CreateRichTextParagraphStyle()
With rtpsStyleArray(0)
Call .ClearAllTabs()
.LeftMargin = RULER_ONE_INCH * 0.375
.FirstLineLeftMargin = RULER_ONE_INCH * 0.375
.RightMargin = RULER_ONE_INCH * 2
.Alignment = ALIGN_LEFT
End With
'// 2nd column = date of change
Set rtpsStyleArray(1) = pnsess.CreateRichTextParagraphStyle()
With rtpsStyleArray(1)
Call .ClearAllTabs()
.LeftMargin = RULER_ONE_INCH * 0.0625
.FirstLineLeftMargin = RULER_ONE_INCH * 0.0625
.RightMargin = RULER_ONE_INCH * 1
End With
'// 3rd column = previous value(s)
Set rtpsStyleArray(2) = pnsess.CreateRichTextParagraphStyle()
With rtpsStyleArray(2)
Call .ClearAllTabs()
.LeftMargin = RULER_ONE_INCH * 0.0625
.FirstLineLeftMargin = RULER_ONE_INCH * 0.0625
.RightMargin = RULER_ONE_INCH * 3
End With
'// 4th column = “changed to” value(s)
Set rtpsStyleArray(3) = pnsess.CreateRichTextParagraphStyle()
With rtpsStyleArray(3)
Call .ClearAllTabs()
.LeftMargin = RULER_ONE_INCH * 0.0625
.FirstLineLeftMargin = RULER_ONE_INCH * 0.0625
.RightMargin = RULER_ONE_INCH * 3
End With
'// Note from Designer help (ND 6.51):
'// Array of type NotesRichTextParagraphStyle. Optional. Creates a table with fixed-width columns
'// and style attributes as specified. Omitting this parameter creates an auto-width table. The
'// array must contain one element for each column in the table in sequence. Explicitly set the
'// first line left margin and left margin, which control the start of text relative to the start
'// of the column, and the right margin, which controls column width.
Call prtItm.AppendTable(pintRowCount%, COLUMN_COUNT, , RULER_ONE_INCH * 0.0125, rtpsStyleArray)
addRichTextTable = True
functionExit:
Exit Function
errorHandler:
Call processUIError(HOTSPOT_NAME & " / " & SUBFORM_NAME)
Resume functionExit
End Function
RE: removing blank elements from multi-dimensional array
Sign in to participate
Previous Next
RE: removing blank elements from multi-dimensional array
Posted by Brandt S Fundak on 9.Aug.06 at 01:46 PM using a Web browser
Category: Domino Designer Release: All Releases Platform: All Platforms
The only thing I can think to do is to create two additional arrays, one one dimensional and another multidimensional equal to the same dimensions as your array with the null values in it.
Redim the one dimensional array equal to number of positions of the second dimension of your multi-dimensional array. make the one dimensional array equal to the values of the multidimensional array at position 1
so for example using your array:
redim array(Ubound(multiarray(2))
For x = 0 to ubound(array)
array(x) = multiarray(1,x)
Next
Fulltrim(array)
For x = 0 to ubound(array)
newmultiarray(1,x) = array(x)
Next