Lotus Notes Database Synopsis - Generated at 08:27:34 on 14/08/2008
Code Library Information
Name: Functions.ATK.DominoDirectory
Last Modification: 25/10/2007 12:16:08
LotusScript Code:
Option Public
Option Declare
Use "Functions.ATK.General"
Sub Initialize
End Sub
Function GetFirstPublicAddressBookDb() As NotesDatabase
Dim session As New NotesSession()
Dim dbCurrent As NotesDatabase
Set dbCurrent = session.CurrentDatabase
Dim dbAddressBook As NotesDatabase
Set dbAddressBook = session.GetDatabase(dbCurrent.Server, "names.nsf")
' if we are on local, then print a warning
If dbAddressBook.Server = "" Then
Print "Note that you are using the address book '" & _
dbAddressBook.Title & "' with filepath '" & _
dbAddressBook.FilePath & "' on local."
End If
Set GetFirstPublicAddressBookDb = dbAddressBook
End Function
Function GetAddressBook() As NotesDatabase
Set GetAddressBook = GetFirstPublicAddressBookDb()
End Function
Function GetGroupMembers(strGroupName As String, dbNAB As NotesDatabase ) As Variant
' get Groupmembers is a standard group explode function designed to retrieve all users and users
' within nested groups and return an array of user names
Dim session As New notesSession
Dim nmUser As notesName
Dim docGroup As notesDocument
Dim docGroupMember As notesDocument
Dim nmServer As notesName
Dim vGroupList() As Variant
Dim vGroupList2 As Variant
Dim vwPerson As notesView
Set nmServer = New notesName(Session.CurrentDatabase.Server)
Redim vGroupList(0) As Variant
If dbNAB Is Nothing Then
Set DBNAB = GetAddressBook()
End If
Dim vwGroup As NotesView
If dbNAB.IsOpen Then
If vwGroup Is Nothing Then
Set vwGroup = dbNAB.getView("($VIMGroups)")
End If
Set docGroup = vwGroup.getDocumentByKey(strGroupName)
If Not docGroup Is Nothing Then
' for each groupMember in members
Forall groupMember In docGroup.Members
If Trim(groupMember) <> "" Then
' if the group member is not a sub-group
Set nmUser = New notesName(groupMember)
Set docGroupMember = vwGroup.GetDocumentByKey(Trim(nmUser.Abbreviated))
If docGroupMember Is Nothing Then
' append it to the end of the list
Call AddToArray(vGroupList, groupMember)
Else
' ***** Recursive Call *****
vGroupList2 = GetGroupMembers(groupMember, dbNAB)
' ***************************
' add any recursed group names into the groupNames
Forall groupMember2 In vGroupList2
Call AddToArray(vGroupList, Cstr(groupMember2))
End Forall
End If
End If
End Forall
End If
End If
GetGroupMembers = vGroupList
End Function
Function GetNABGroupDocument( dbNAB As NotesDatabase, strGroupName As String ) As NotesDocument
Dim vwNABGroups As NotesView
Set vwNABGroups = dbNAB.GetView("($VIMGroups)")
Dim groupDoc As NotesDocument
Dim blExactMatch As Boolean
blExactMatch = True
Set groupDoc = vwNABGroups.GetDocumentByKey(strGroupName, blExactMatch)
Set GetNABGroupDocument = groupDoc
End Function ' GetNABGroupDocument
Function DoesNABGroupExist( dbNAB As NotesDatabase, strGroupName As String ) As Boolean
' check the domino directory to see if that name is being used.
' will not need to refresh directory as this is not
' actually where the name is created.
' the refresh will be done once the new group is created.
' the refresh may have to be targeted to the specific view that
' i am looking up... yes that will be best.
Dim groupDoc As NotesDocument
Set groupDoc = GetNABGroupDocument( dbNAB, strGroupName )
If groupDoc Is Nothing Then ' this is expected
DoesNABGroupExist = False
Else
DoesNABGroupExist = True
End If
End Function ' DoesGroupExist
Function GetNameFromPersonDoc(docPerson As NotesDocument) As String
' same as address book view
' @Trim(@Subset(LastName;1))+@If(Firstname !="";" , "+@Trim(@Subset(FirstName;1));"")+@If(MiddleInitial !="";" "+@Trim(@Subset(MiddleInitial;1));"")
Dim strFirstname As String, strLastName As String, strMiddleInitial As String
If docPerson.HasItem("FirstName") Then
strFirstName = docPerson.FirstName(0)
End If
If docPerson.HasItem("LastName") Then
strLastName = docPerson.LastName(0)
End If
If docPerson.HasItem("MiddleInitial") Then
strMiddleInitial = docPerson.MiddleInitial(0)
End If
GetNameFromPersonDoc = Trim(strFirstName + " " + strMiddleInitial + " " + strLastName)
End Function
Function GetPersonDocFromAddressBook( strNameToFind As String, dbNab As NotesDatabase ) As NotesDocument
Dim vwPerson As NotesView
Set vwPerson = dbNAB.GetView("($Users)")
Dim dcPersons As NotesDocumentCollection
Set dcPersons = vwPerson.GetAllDocumentsByKey( strNameToFind, True )' true for exact match
If dcPersons.Count> 1 Then
Error 1000, "More than 1 person (" + Cstr( dcPersons.Count ) + " ) with that name '"+ strNameToFind +"'"
End If
If dcPersons.Count = 0 Then
Set GetPersonDocFromAddressBook = Nothing
Else
Set GetPersonDocFromAddressBook = dcPersons.GetFirstDocument()
End If
End Function
Function GetACLInformationAsHTML( db As NotesDatabase, strFilter As String ) As String
' This function can be used to get all information or just a subset matching eg
' if we just want to match a role of "[Admin]" then set strFilter = "[Admin]"
Dim strACLInformation As String
Dim aclEntry As NotesACLEntry
Dim strLineOfACLInformationForFilter As String
Dim acl As NotesACL
Set acl = db.ACL
'=====================================================
' Loop through each ACL Entry
'=====================================================
strACLInformation = strACLInformation + {<table class=tableclass1 cellspacing=2px style="background-color:#fff" width=100%>} +_
{<tr class="rowheader">}+_
{<th>Name</th>}+_
{<th>Type</th>}+_
{<th>Level</th>}+_
{<th>Roles</th></tr>}
Set aclEntry = acl.GetFirstEntry
Do While (Not aclEntry Is Nothing)
strLineOfACLInformationForFilter = aclEntry.Name + "," + ConvertUserTypeToString(aclEntry.UserType) +_
ConvertAccessLevelToString(aclEntry.Level) + ArrayToString(aclEntry.Roles, "," )
If aclEntry.CanDeleteDocuments = True Then
strLineOfACLInformationForFilter = strLineOfACLInformationForFilter + "Delete Docs"
End If
If ( strFilter="" Or Instr( strLineOfACLInformationForFilter, strFilter ) > 0) Then
strACLInformation = strACLInformation + "<tr class='rownormal'><td>" + aclEntry.Name + "</td>"
strACLInformation = strACLInformation + "<td>" + ConvertUserTypeToString(aclEntry.UserType) + "</td>"
strACLInformation = strACLInformation + "<td>" + ConvertAccessLevelToString(aclEntry.Level) + "</td>"
strACLInformation = strACLInformation + "<td>" + ArrayToString(aclEntry.Roles, "," )
If aclEntry.CanDeleteDocuments = True Then
strACLInformation = strACLInformation + "Delete Docs"
End If
strACLInformation = strACLInformation + "</td></tr>" + Chr(10) + Chr(13) + ""
End If
Set aclEntry = acl.GetNextEntry( aclEntry )
Loop
'=====================================================
' Get explicit names from this acl
'=====================================================
'=====================================================
' Get Groups from this acl
'=====================================================
' expand each group
strACLInformation = strACLInformation + "</table>"
GetACLInformationAsHTML = strACLInformation
End Function
Function ConvertUserTypeToString( intUserType As Integer) As String
%REM
ACLTYPE_UNSPECIFIED (0)
ACLTYPE_PERSON (1)
ACLTYPE_SERVER (2)
ACLTYPE_MIXED_GROUP (3)
ACLTYPE_PERSON_GROUP (4)
ACLTYPE_SERVER_GROUP (5)
%ENDREM
Dim strUserType As String
Select Case intUserType
Case 0
strUserType = "Unspecified"
Case 1
strUserType = "Person"
Case 2
strUserType = "Server"
Case 3
strUserType = "Mixed Group"
Case 4
strUserType = "Person Group"
Case 5
strUserType = "Server Group"
Case Else
Error 1000, "No string coded for a role type of " & intUserType
End Select
ConvertUserTypeToString = strUserType
End Function ' ConvertUserTypeToString
Function GetACLInformationAsArr( db As NotesDatabase, strFilter As String ) As Variant
' This function can be used to get all information or just a subset matching eg
' if we just want to match a role of "[Admin]" then set strFilter = "[Admin]"
' returns an arr=
' eg strFilter = "[Admin]"
Dim arrACLInformation As Variant
Dim aclEntry As NotesACLEntry
Dim strLineOfACLInformationForFilter As String
Dim acl As NotesACL
Set acl = db.ACL
'=====================================================
' Loop through each ACL Entry
'=====================================================
Set aclEntry = acl.GetFirstEntry
Do While (Not aclEntry Is Nothing)
strLineOfACLInformationForFilter = aclEntry.Name + "," + ConvertUserTypeToString(aclEntry.UserType) + "," +_
ConvertAccessLevelToString(aclEntry.Level) + "," + ArrayToString(aclEntry.Roles, "," )
If aclEntry.CanDeleteDocuments = True Then
strLineOfACLInformationForFilter = strLineOfACLInformationForFilter + "Delete Docs"
End If
If ( strFilter="" Or Instr( strLineOfACLInformationForFilter, strFilter ) > 0) Then
'Sub AddToArray( iArray As Variant, newValue As String )
Call AddToArray( arrACLInformation, strLineOfACLInformationForFilter )
End If
Set aclEntry = acl.GetNextEntry( aclEntry )
Loop
'=====================================================
' Get explicit names from this acl
'=====================================================
'=====================================================
' Get Groups from this acl
'=====================================================
' expand each group
GetACLInformationAsArr = arrACLInformation
End Function
Sub BreakUpACLInformation( arrACLInformation As Variant, arrNames As Variant, arruserTypes As Variant, _
arrAccess As Variant, arrRoles As Variant, arrPermissions As Variant )
Forall strACLInformation In arrACLInformation
Call AddToArray( arrNames, GetCommonName(Strtoken(strACLInformation, ",", 1 ))) ' 1 for first word
Call AddToArray( arrUserTypes, Strtoken(strACLInformation, ",", 2 ) ) ' 3 for first word
Call AddToArray( arrAccess, Strtoken(strACLInformation, ",", 3 ) ) ' 3 for first word
Call AddToArray( arrRoles, Strtoken(strACLInformation, ",", 4 ) ) ' 3 for first word
Call AddToArray( arrPermissions, Strtoken(strACLInformation, ",", 5 ) ) ' 3 for first word
End Forall
End Sub
Name: Functions.ATK.General
Last Modification: 25/10/2007 12:16:08
LotusScript Code:
Option Public
Option Declare
Sub Initialize
' 03/08/2005 ATK GetIntegerFromRightOfString
' 13/05/2005 ATK MakeSafeFileName
' 10/05/2005 ATK Added CleanOutACL
' 29/04/2005 ATK Modified FileExists to not error out on directories
' ATK modfified AddToArray
' 12/04/2005 ATK Modified GetTextAtPosition for delimieters longer than 1 char "~~"
' 05/04/2005 ATK Modified ReplaceSubstring!!!!
' Added IncreaseCountField
' 03/02/2005 ATK Added GetNextAlphabetLetter
' ATK Added GetPrevAlphabetLetter
' ATK Added IsAlpha
' ATK Added TranslateIntToChar
' ATK Added Sub AddSectionToRTItem( doc As NotesDocument, strRTItemName As String, strTitle As String, strText As String )
' 25/01/2005 ATK Added GetGenericHTMLLinkToDoc
' 12/01/2005 ATK Added PrintOutFilesInDir
' 06/01/2004 ATK Modified Function GetTextAtPosition for first pos
' 06/12/2004 ATK Added Function OpenDirectoryDialog(blMultipleSelect, strTitle, _
' 26/11/2004 ATK Added GetAbbreviatedName( strNameInCanonical As String ) As String
' 19/11/2004 ATK Modified MailResults with Error handling!
' 15/11/2004 ATK Added fileExists( pathname As String )
' 25/10/2004 ATK Added DoesGroupExist
' ATK Added GetGroupDocument
' ATK Added ChooseAddressBook( strServer )
' 22/10/2004 ATK Added Sub GetAllGroupsInACL( strGroupsInACLArr As Variant )
' 22/10/2004 ATK Added Function GetAccessLevelAsString( ) As String
' 21/10/2004 ATK Added GenerateUniqueFilename
' 20/10/2004 ATK Updated RemoveNonAlphaNum to work
' 19/10/2004 ATK Added RemoveNonAlphaNum
' 18/10/2004 ATK Added QuickSort
' 14/10/2004 ATK Modified GetCommonName
' 8/10/2004 ATK Added IsAccessLevelAtLeast
' ATK Changed GoToURL to use location.replace
' 7/10/2004 ATK Added CleanUpOldDocs
' 27/09/2004 ATK Added IsAbbreviatedFormat
' Added IsCommonFormat
' 24/09/2004 ATK Modified EncodeURL( iString As String )
'
' 21/09/2004 ATK Updated MailResults make the link look nicer
' ATK Added new parameter to PoliceProcessError. Can be used for warnings etc.
' ATK Removed new parameter from PoliceProcessError.
' ATK Added new function PoliceProcessWarning
' 09/09/2004 ATK ConvertDateToYYYYMM
' ConvertDateToMMMYYYY
' GetMonthName
' Maybe I could split this script library into web and regular.
' 26/08/2004 ATK 2.6 Added option declare, and a good thing too as I
' discovered some spelling errors
' 26/08/2004 ATK 2.5 Added heaps of functions, to wit:
' Function SplitStringToChars( iString )
' Function CheckAlphaNum( iString, iException ) As Integer
' Function RemoveVowels(iString As String) As String
' Function DecodeURL( iString As String ) As String
' Function EncodeURL( iString As String ) As String
' Function GoToURL( iUrl As String) As String
' Function GetHTMLBackLinks(doc) As String
' GetMessageURL, GetMessageURLSmall, GetMessageURLMed, GetMessageURLLarge
' CleanUpOldMessageDocs
' GetRandomIntInRange
' Function GetCurrentDbInfo() As String
' Function GetArgFromQuery_String(iArgName, iQuery_String) As String
' Function HasRole( strRoleName As String, strFullUsername As String ) As Boolean
' Function GetAsHTMLComment( iString ) As String
' 25/08/2004 ATK 2.4 Added Function GetCurrentDbInfo() As String
' 20/08/2004 ATK 2.3 Removed PoliceMailError added PoliceProcessError
' 19/08/2004 ATK 2.2 Added Sub PoliceMailError( strApplication As String, strSection As String, strErrorNoAndString As String, contextDoc As NotesDocument)
' 19/08/2004 ATK 2.1 Added Function InsertText( rtItem As NotesRichTextItem, strTextToInsert As String ) As NotesRichTextItem
' 18/08/2004 AK 2.0 Added function Sub AddToArray( iArray As Variant, newValue As String )
' 10/08/2004 AK 1.9 Added function IsCanonicalFormat( strUsername as string ) as boolean
' 03/08/2004 AK 1.8 Added function PadStart( iString As String, iSize As Integer, iPadChar As St
' 02/08/2004 AK 1.7 Added function POLICEUpdateAuditCode
' 30/07/2004 AK 1.6 Added function GetCommonName( iLongName ) as STring
' 30/06/2004 AK 1.5 Added iGetViewOrDie, modified iGetView
' 18/06/2004 AK 1.4 Added Propercase function, Added PadOrCut function
' April 21 2004 version 1.3 AK
' updatate mailresults for outlook express chr(10) etc
' Mar 31 2004 version 1.2 AK
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As Str
' updated string to array
' updated igetdocumentcollection
'Function ProperCase(strString As String) As String
'Function ReplaceSubstring(src As String, search As String, replace As String) As String
'Function StringToArray(textstr As String, delimiter As String) As Variant
'Function BreakUpStringWithReturns( iString As String, iNumChars As Integer ) As String
'Function LeftByWord( iString As String, iNumChars As Integer )
'Function SearchForViewsNamed(db As NotesDatabase, partOfViewName As String) As Variant
'Function WhatKindOfArray( t As Variant ) As Integer
'Function GetCommonItemsInArrays(array1 As Variant, array2 As Variant) As Variant
'Function GetDatabasesWithTitle( iServerName As String, iTitle As String) As Variant
'Function GetDatabasesThatUseTemplate( iServerName As String, iNameOfTemplate As String) As Variant
'Function ConvertDate( DateString As String, FString As String)
'Function CountSubstrings( strBig As String, strLittle As String ) As Integer
'Function AreValuesInArray(FindArray, SearchArray)
'Function RemoveLastNChars(iString, iNumberOfChars ) As String
'Function ArrayToString( iArray As Variant, newSeparator As String ) As String
'Sub WriteToAFile(fileName As String, aMessage As String)
'Function GetFilePathFromFileNameAndPath( fileNameAndPath As String )
'Function GetTextAtPosition( bigString, posToFind As Integer, Delimeter As String ) As String
'Function LineCount( fileName As String ) As Integer
'Function GetMiddle( FullString, StartString As String, EndString As String) As String
'Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
'Function StringArrayIsEqual( array1() As String, array2() As String ) As Integer
'Function iGetView( db As NotesDatabase, ViewName As String ) As NotesView
'Function iGetDocumentCollection( db As NotesDatabase, SearchFormula As String ) As NotesDocumentCollection
End Sub
Function ReplaceSubstring( strSource As String, strSearch As String, strReplace As String) As String
'iSource = original string
'iSearch = what to iSearch for
'replace = replace string
' if we are replacing something like a single "\" with a double "\\" , then this never finishes...... need to fix that.
If (strSearch = strReplace) Then
ReplaceSubstring = strSource
Exit Function
End If
Dim intBegin As Integer
intBegin = 1
Dim intPos As Integer
intPos = Instr( intBegin, strSource, strSearch )
While intPos > 0
strSource = Left$( strSource, Instr( intBegin, strSource, strSearch) - 1) + strReplace + Right$( strSource, Len( strSource) - Instr( intBegin, strSource, strSearch ) - Len( strSearch) + 1 )
intBegin = Instr( intBegin + Len( strReplace ) + 1, strSource, strSearch )
If intBegin > 0 Then
intPos = Instr( intBegin, strSource, strSearch )
Else
intPos = 0
End If
Wend
ReplaceSubstring = strSource
End Function
Function StringToArray(textstr As String, delimiter As String) As Variant
' count is the counter for the number of array elements
Dim count As Integer
Dim ending As Integer
count = 0
'placeholder is used to mark the beginning of the string to be split
Dim placeholder As Integer
Dim splitstr As String
placeholder = 1
splitstr$ = delimiter
' txt$() is the array that will be returned
Dim txt$()
Redim txt$(0)
ending = Instr(placeholder, textstr, splitstr$)
'if ending = 0 then text does not contain a ; and the entire value should be returned
If ending = 0 Then
txt$(0) = textstr
End If
' do this until no more delimiters are found
While ending <> 0 And ending < Len(textstr)
Redim Preserve txt$(count)
txt$(count) = Mid$(textstr, placeholder, ending - placeholder )
count = count + 1
placeholder = ending + Len(splitstr$)
ending = Instr(placeholder, textstr, splitstr$)
If ending = 0 Then
Redim Preserve txt$(count)
txt$(count) = Mid$(textstr, placeholder, (Len(textstr)-placeholder) +1 )
End If
Wend
StringToArray = txt$
End Function
Function BreakUpStringWithReturns( iString As String, iNumChars As Integer ) As String
' returns the string broken up with return chars every iNumChars
Dim newString As String
Dim numberOfLoops As Long
Dim lineChunk As String
Do While Len(iString) > 0
' Get the string with full complete words up to the num chars
lineChunk = LeftByWord( iString, iNumChars ) & Chr(10) & Chr(13)
' Add the new chunk to the string we will return
newString = newString & lineChunk
' reduce the original string by the new chunk
If Len(iString) < Len(lineChunk) + 1 Then
iString = ""
Else
iString = Trim(Right( iString, Len(iString) - Len(lineChunk) + 1))
End If
numberOfLoops = numberOfLoops + 1
If numberOfLoops > 1000 Then
Print "The BreakUpStringWithReturns function cannot complete the task."
newString = newString & Chr(10) & Chr(13) & iString
Exit Do
End If
Loop
newString = RemoveLastNChars( newString, 2 )
BreakUpStringWithReturns = newString
End Function
Function LeftByWord( iString As String, iNumChars As Integer )
' eg LeftByWord("The man in the moon comes back", 13 )
' returns "The man in"
' so, get the left of the word up to iNumChars, eg "The man in th"
' then get the last space space at pos ..10
' then get the left of that "The man in"
Dim initialCut As String
Dim posOfLastSpace As Integer, oldPosOfLastSpace As Integer
Dim finalCut As String
If Len(iString) < iNumChars Then
finalCut = iString
Goto EndNow
End If
initialCut = Left( iString, iNumChars )
posOfLastSpace = Instr(initialCut, " ")
oldPosOfLastSpace = posOfLastSpace
Do While ( posOfLastSpace < Len(initialCut)) And posOfLastSpace > 0
oldPosOfLastSpace = posOfLastSpace
posOfLastSpace = Instr(posOfLastSpace + 1, initialCut, " " )
Loop
If oldPosOfLastSpace <> 0 Then
finalCut = Left( initialCut, oldPosOfLastSpace-1 )
Else
finalCut = initialCut
End If
EndNow:
LeftByWord = finalCut
End Function
Function SearchForViewsNamed(db As NotesDatabase, partOfViewName As String) As Variant
' returns an array of view names that contain
' the partOfViewName in the Title
Dim NUM_VIEWS_FOUND As Integer
NUM_VIEWS_FOUND = 0
partOfViewName = Lcase(partOfViewName)
Print "Searching for views with [" & partOfViewName & "] in the name"
Dim iNotesView As NotesView
Forall v In db.Views
Set iNotesView = v
If Instr( Lcase(iNotesView.Name), partOfViewName ) > 0 Then
Redim Preserve iViewArray(NUM_VIEWS_FOUND) As String
iViewArray(NUM_VIEWS_FOUND) = iNotesView.Name
NUM_VIEWS_FOUND = NUM_VIEWS_FOUND + 1
End If
End Forall
SearchForViewsNamed = iViewArray
End Function
Function WhatKindOfArray( t As Variant ) As Integer
%REM
This function takes a Variant as input variable and returns an integer :
-1 (minus one) if input is not an array
0 if it's an array, but not initialized yet
1 if it's a fully initialized array.
%END REM
' April 4th 2003
Dim res As Integer, n As Integer
res = False
On Error Goto errH
If Isarray( t ) Then
n = Ubound( t ) ' raises error 200 if not initialized
res = 1
Else
' not even an array
res = -1
End If
Goto theEnd
errH:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
res = 0
Else
res = -1
Print "Unexpected error n°" & Err " while testing array in whatKindOfArray function"
End If
Resume theEnd
theEnd:
whatKindOfArray = res
End Function
Function GetCommonItemsInArrays(array1 As Variant, array2 As Variant) As Variant
'return an array with the common elements
' eg from array1 = "Cat", "Dog", "Fish"
' eg array2 = "Cat", "Fish", "Canary"
' then return "Cat", "Fish"
Dim commonList() As Variant
Dim commonListSize As Integer
%REM
Dim iType As String
iType = Typename ( array1 )
If iType = "STRING( )" Then
Redim commonList As String
Elseif iType = "INTEGER( )" Then
Redim commonList As Integer
Else
Print "Unknown type of array."
End If
%END REM
Forall x In array1
Forall y In array2
If x = y Then
Redim Preserve commonList(commonListSize)
commonList(commonListSize) = x
commonListSize = commonListSize + 1
End If
End Forall
End Forall
If commonListSize > 0 Then
GetCommonItemsInArrays = commonList
End If
End Function
Function GetDatabasesWithTitle( iServerName As String, iTitle As String) As Variant
' returns an array of strings of database names and filenames
' where the title contains the string iTitle.
Dim dbdir As NotesDbDirectory
Dim xdb As NotesDatabase
Dim TEMPLATE_CANDIDATE As Integer
TEMPLATE_CANDIDATE = 1246 ' database or template
Dim listOfDbs() As String
Dim numberOfDbsFound As Integer
Dim totalCount As Integer
iTitle = Lcase(iTitle)
Set dbdir = New NotesDbDirectory( iServerName )
Set xdb = dbdir.GetFirstDatabase(TEMPLATE_CANDIDATE)
Do While Not xdb Is Nothing
totalCount = totalCount + 1
If totalCount Mod 10 = 0 Then
Print "Processed " & totalCount
End If
'===========================
If Instr(Lcase(xdb.Title), iTitle ) Then
Redim Preserve listOfDbs(numberOfDbsFound)
listOfDbs(numberOfDbsFound) = xdb.Title & "~" & xdb.FilePath
numberOfDbsFound = numberOfDbsFound + 1
End If
Set xdb = dbdir.GetNextDatabase()
Loop
If numberOfDbsFound > 0 Then
GetDatabasesWithTitle = listOfDbs
Erase listOfDbs
End If
End Function
Function GetDatabasesThatUseTemplate( iServerName As String, iNameOfTemplate As String) As Variant
Dim dbdir As NotesDbDirectory
Dim xdb As NotesDatabase
Dim TEMPLATE_CANDIDATE As Integer
TEMPLATE_CANDIDATE = 1246 ' database or template
Dim listOfDbs() As String
Dim numberOfDbsFound As Integer
Dim totalCount As Integer
Set dbdir = New NotesDbDirectory( iServerName )
Set xdb = dbdir.GetFirstDatabase(TEMPLATE_CANDIDATE)
Do While Not xdb Is Nothing
totalCount = totalCount + 1
If totalCount Mod 10 = 0 Then
Print "Processed " & totalCount
End If
'===========================
If xdb.DesignTemplateName = iNameOfTemplate Then
Redim Preserve listOfDbs(numberOfDbsFound)
listOfDbs(numberOfDbsFound) = xdb.Title & "~" & xdb.FilePath
numberOfDbsFound = numberOfDbsFound + 1
End If
Set xdb = dbdir.GetNextDatabase()
Loop
If numberOfDbsFound > 0 Then
GetDatabasesThatUseTemplate = listOfDbs
Erase listOfDbs
End If
End Function
Function ConvertDate( DateString As String, FString As String)
' convert a date sting into a date variant
'eg: DT = ConvertDate("2003-09-27 07:00:00", "YYYY-MM-DD")
Dim DD As String
Dim MM As String
Dim YY As String
Dim TT As String
Dim YPos As Integer
Dim YLen As Integer
Dim MPos As Integer
Dim MLen As Integer
Dim DPos As Integer
Dim DLen As Integer
Dim TPos As Integer
Dim DateOnly
' get the year postion
YPos = Instr(FString , "Y")
YLen = CountSubstrings( FString, "Y" )
YY = Mid(DateString , YPos , YLen )
' get the month
MPos = Instr(FString , "M")
MLen = CountSubstrings( FString, "M" )
MM = Mid(DateString , MPos , MLen )
' get the day
DPos = Instr(FString , "D")
DLen = CountSubstrings( FString, "D" )
DD = Mid(DateString , DPos , DLen )
' get the time
TPos = Instr(FString , " ")
TT = Mid(DateString , TPos , (Len(DateString) + 1) - TPos )
' put the date together and convert to a date
DateOnly = Datenumber ( Cint(YY) , Cint(MM) , Cint(DD) )
ConvertDate = Cdat(Cstr(DateOnly) & TT)
End Function
Function CountSubstrings( strBig As String, strLittle As String ) As Integer
' return the number of times that the smaller string appears in the bigger string
If strBig= "" Or strLittle = "" Then
CountSubstrings = 0
Exit Function
End If
Dim tempLine As String
Dim posLittle As Integer
Dim countLittle As Integer
tempLine = strBig
posLittle = Instr( tempLine, strLittle )
Do While posLittle > 0
countLittle = countLittle + 1
tempLine = Right( tempLine, Len( tempLine ) - posLittle )
posLittle = Instr( tempLine, strLittle )
Loop
CountSubstrings = countLittle
End Function
Function AreValuesInArray(FindArray, SearchArray)
' checks to see if values in a smaller array exist in a larger array
' returns true if all the values exist.
Dim FA As Integer
Dim SA As Integer
Dim foundFlag As Integer
For FA = 0 To Ubound(FindArray)
foundFlag = False
For SA = 0 To Ubound(SearchArray)
If Ucase(FindArray(FA)) = Ucase(SearchArray(SA)) Then
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
Exit For
End If
Next
AreValuesInArray = foundFlag
End Function
Function RemoveLastNChars(iString, iNumberOfChars ) As String
If Len(iString) = 0 Then
RemoveLastNChars =""
Else
RemoveLastNChars = Left( iString, Len(iString) - iNumberOfChars)
End If
End Function
Function ArrayToString( iArray As Variant, newSeparator As String ) As String
' iArray is the array to convert
' newSeparator is the new separator eg ","
' Take in an array of strings, or an array of integers and return a string
If Datatype(iArray) = 8 Then
ArrayToString = iArray
Exit Function
End If
If Isempty(iArray) Then
ArrayToString = ""
Exit Function
End If
If Isnull(iArray) Then
ArrayToString = ""
Exit Function
End If
If Datatype(iArray(Lbound(iArray))) = 8 Then '8 String V_STRING
Forall iBit In iArray
ArrayToString = ArrayToString & iBit & newSeparator
End Forall
Else
Forall iBit In iArray
ArrayToString = ArrayToString & Cstr(iBit) & newSeparator
End Forall
End If '--If Datatype(iArray(0)) = 8 Then
' Remove the last added bit
'Left( iString, Len(iString) - iNumberOfChars)
ArrayToString = Left(ArrayToString, Len(ArrayToString) - Len(newSeparator))
End Function
Sub WriteToAFile(fileName As String, aMessage As String)
Dim fileNum As Variant
Dim counter As Integer
fileNum = Freefile()
counter% = 0
Print fileName
Open fileName For Output As fileNum
Print # fileNum, aMessage
Close fileNum
End Sub
Function GetFilePathFromFileNameAndPath( fileNameAndPath As String )
' Given C:\notes\data\mydatabase.nsf returns C:\notes\data\
' does return the slash
Dim posOfSlash As String
Dim prevPosOfSlash As String
If fileNameAndPath = "" Then
GetFilePathFromFileNameAndPath = ""
Exit Function
End If
posOfSlash = Instr( fileNameAndPath, "\" )
prevPosOfSlash = posOfSlash
Do While posOfSlash >0
prevPosOfSlash = posOfSlash
posOfSlash = Instr( posOfSlash + 1, fileNameAndPath, "\" )
Loop
Dim session As New NotesSession()
Dim db As NotesDatabase
Dim vw As NotesView
Set db = session.CurrentDatabase
Dim strViewName As String
strViewName = "CitiesLookup"
strViewName = "ParametersLookup"
Set vw=db.GetView(strViewName)
If vw Is Nothing Then
Error 1000, "There is no view named " + strViewName + " in the db " + db.Title
Exit Function
End If
Dim strCitiesArr As Variant ' a string array
strCitiesArr = PerformDbLookupLS( vw, "database_code", 2)
' or
' strCitiesArr = PerformDbLookupLS( vw, "Australia", "CityName")
Msgbox Join(strCitiesArr, ", ")
GetFilePathFromFileNameAndPath = Left( fileNameAndPath, prevPosOfSlash )
End Function
Function GetTextAtPosition( strBigString, intPosToFind As Integer, strDelimeter As String ) As String
' Finds text at a certain position given the delimeter
'atk modified 12/04/2005. Added + lenstrDelim-1
If strBigString = "" Then
GetTextAtPosition = ""
Exit Function
End If
Dim RightSide As String
Dim pos As Integer
Dim lastPos As Integer
Dim count As Integer
Dim NumberOfRightMostChars As Integer
lastPos = 0
pos = 1
pos = Instr ( pos, strBigString , strDelimeter )
Do While pos > 0 And count < intPosToFind-1
count = count + 1
lastPos = pos
pos = Instr ( pos + 1, strBigString , strDelimeter )
Loop
' If we found at least one of the substring then
If lastPos > 0 Then
NumberOfRightMostChars = Len( strBigString ) - ( lastPos + Len(strDelimeter)-1 ) ' atk modified12/04/2005. Added + lenstrDelim-1
RightSide = Right( strBigString, NumberOfRightMostChars )
If pos > 0 Then
GetTextAtPosition = Left( RightSide, pos-lastPos-1 )
Else
GetTextAtPosition = RightSide
End If
Elseif lastPos = 0 And pos > 0 Then
' Must have been the first item in the string
GetTextAtPosition = Left( strBigString, pos -1 )
Elseif lastPos = 0 And pos = 0 And (intPosToFind = 0 Or intPosToFind = 1) Then
' must be the first item in the string, and no delimeters
GetTextAtPosition = strBigString
Else
GetTextAtPosition = ""
End If
End Function
Function LineCount( fileName As String ) As Integer
Dim fileNum As Integer
Dim count As Integer
Dim txt As String
count = 0
fileNum% = Freefile()
Open fileName For Input As fileNum%
' Read the first line which will have the column headers in it
Do While Not Eof(fileNum%)
' Read each line of the file.
Line Input #fileNum%, txt$
count = count + 1
Loop
Close fileNum%
LineCount = count
End Function
Function GetMiddle( FullString, StartString As String, EndString As String) As String
' get the string within two delimiters
Dim begin As Integer
Dim idx As Integer
Dim idx2 As Integer
' make sue the delimiter exists else retrun the full string
If Instr (FullString , StartString) = 0 Then
GetMiddle = FullString
Exit Function
End If
If Instr (FullString , EndString) = 0 Then
GetMiddle = FullString
Exit Function
End If
begin = 1
idx = Instr (begin , FullString , StartString)
idx2 = Instr (begin , FullString , EndString)
GetMiddle = Trim(Mid(FullString , idx + 1 , (idx2 - idx - 1) ))
End Function
Function StringArrayIsEqual( array1() As String, array2() As String ) As Integer
Dim i As Integer
If Ubound( array1 ) <> Ubound( array2) Then
StringArrayIsEqual = False
Exit Function
End If
Dim upper_bound As Integer
upper_bound = Ubound ( array1)
For i = 0 To upper_bound
If array1( i ) <> array2 ( i ) Then
StringArrayIsEqual = False
Exit Function
End If
Next
StringArrayIsEqual = True
End Function
Function iGetView( db As NotesDatabase, ViewName As String ) As NotesView
Dim session As New NotesSession
If db Is Nothing Then
Print "Database not found. ( Function: [iGetView]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
If ViewName ="" Then
Set iGetView = Nothing
Exit Function
End If
Set iGetView = db.GetView( ViewName )
If iGetView Is Nothing Then
Set iGetView = Nothing
Exit Function
End If
End Function
Function iGetDocumentCollection( db As NotesDatabase, SearchFormula As String ) As NotesDocumentCollection
' Simply pass in the searchFormula and this document
' collection either returns the collection or ends the agent
' ATK 24/08/2004 Removed 3xprint statements
Dim dc As NotesDocumentCollection
Dim dt As New notesDateTime ( "1/1/1980")
Set dc = db.search(SearchFormula, dt, 0)
Set iGetDocumentCollection = dc
End Function
Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
' use sendmail now or sendmailwithdoclink
' version 2.... I like it
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
' only send if we have names to send to
If Datatype( iTo ) = 8 Then '8 String V_STRING
If iTo= "" Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
Else
Dim someoneToSendTo As Integer
someoneToSendTo = False
Forall bit In iTo
If bit <> "" Then
someoneToSendTo = True
End If
End Forall
If someoneToSendTo = False Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
End If
Dim iMailDoc As New NotesDocument(db)
iMailDoc.From = iFrom ' Set who it comes from
iMailDoc.SendFrom = iFrom ' Set who it comes from
iMailDoc.Principal = iFrom ' Set the Username Sender (from)
iMaildoc.Subject = Subject
'===================================================
' Set the body of the email
Dim rtBody As New NotesRichTextItem( iMailDoc, "Body" ) ' for attachment
Call rtBody.AppendText( "Dear " & ArrayToString(iTo, " and ") & ",")
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "This mail has been created via an automatic process." )
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtBody.AppendRtitem( newRTItem )
End If
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "Regards, The Agent")
' Call rtBody.AddNewLine(1)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
'=========================================================
' Add a link to this database so that users can find where this email came from
Call rtBody.AppendText( "DB Title: " & db.Title & Chr(13) )
Call rtBody.AppendText( "DB Path: " & db.FilePath & Chr(13) )
Call rtBody.AppendText( "DB Server: " & db.Server & Chr(13) )
Call rtBody.AppendText( "Doclink: " )
Call rtBody.AppendDocLink( db, db.Title )
'==========================================================
' Send the mail
' try to catch the error no match found in name and address book.
On Error 4294 Goto HandleNoMatchInAddBook
Call iMaildoc.Send( False, iTo )
Exit Sub
HandleNoMatchInAddBook:
Print Err & " " & Error
If Datatype( iTo ) = 8 Then '8 String V_STRING
Print "MailResults sub: Warning: Tried to send to " & iTo
Else
Print "MailResults sub: Warning: Tried to send to " & ArrayToString(iTo, ", ")
End If
Resume ContinueNow
ContinueNow:
End Sub
Function ProperCase(strString As String) As String
Dim ReturnVal As Variant
Dim LowerCase As String
LowerCase = Lcase(strString)
ReturnVal = Evaluate("@ProperCase(" + Chr(34) + LowerCase + Chr(34) + ")")
ProperCase = ReturnVal(0)
End Function
Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
' eg iString = "BT", iLenMin = 3, iLenMax = 10, iPadChar = "X" - desired length =
' would return BTX
Do While Len(iString) < iLenMin
iString = iString & iPadChar
Loop
' it can be MAX chars at most
If Len(iString) > iLenMax Then
iString = Left( iString, iLenMax )'
End If' len > max
PadOrCut = iString
End Function
Function GetViewOrDie( db As NotesDatabase, strViewName As String ) As NotesView
' renamed from iGetViewOrDie
Dim session As New NotesSession
If db Is Nothing Then
If session.CurrentAgent Is Nothing Then
Error 1000, "Database not found for view '" & strViewName & "'. ( Function: "&_
"[GetViewOrDie])."
Else
Error 1000, "Database not found for view '" & strViewName & "'. ( Function: "&_
"[GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End If
End
End If
If strViewName ="" Then
Error 1000, "Cannot get view in db " & db.Title & " with a blank name passed in " &_
"Exiting ( Function: "&_
"[GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
Set GetViewOrDie = db.GetView( strViewName )
If GetViewOrDie Is Nothing Then
Error 1000, "Cannot get view in db " & db.Title & " with name " &_
"'" & strViewName & "' Exiting ( Function: [GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
End Function
Function GetCommonName( iLongName As String ) As String
Dim intFirstSlash As Integer
Dim intCN As Integer ' the pos of the "CN"
intCN = Instr(iLongName, "CN=")
If intCN <= 0 Then
intCN = 1
Else
intCN = intCN + 3 '3 is the length of CN=
End If
intFirstSlash = Instr(iLongName, "/")
If intFirstSlash <= 0 Then
intFirstSlash = Len( iLongName )+1
End If
'Mid[$] ( expr , start [ , length ] )
Dim intLength As Integer
intLength = intFirstSlash - intCN
' Mid must start from 1 or greater as the left most, not 0
GetCommonName = Mid( iLongName, intCN, intLength)
End Function
Sub POLICEUpdateAuditCode( doc As NotesDocument, update_string As String )
Dim iSession As NotesSession
Set iSession = New NotesSession
Dim item As NotesItem
Dim AgentName As String
Dim thisAgent As NotesAgent
Set thisAgent = iSession.CurrentAgent
If thisAgent Is Nothing Then
AgentName = ""
Else
AgentName= "AgentName=" & thisAgent.Name & ". "
End If
update_string = "Updated by " & iSession.CommonUserName & ". " & AgentName & update_string & " " & Str ( Today )
Set Item = doc.GetFirstItem ( "audit_police_code" )
If item Is Nothing Then
Set item = New NotesItem ( doc , "audit_police_code" , update_string )
Else
Call item.AppendToTextList ( update_string )
End If
item.IsSummary = True
End Sub
Function PadStart( iString As String, iSize As Integer, iPadChar As String )
' eg iString = "BT", iSize, iPadChar = "X" - desired length =
' would return BTX
' add to max
Do While Len(iString) < iSize
iString = iPadChar & iString
Loop
PadStart = iString
End Function
Function IsCanonicalFormat( strUserName ) As Boolean
' check if we have a cn= at the start
If Instr(strUserName, "CN=") > 0 Then
IsCanonicalFormat = True
Else
IsCanonicalFormat = False
End If
End Function ' IsCanonicalFormat
Function InsertText( rtItem As NotesRichTextItem, strTextToInsert As String ) As NotesRichTextItem
' Still working on this function ATK 19/08/2004
'Put the subject at the start of the body as well as in the subject line of the email.
' Dim rtnav As NotesRichTextNavigator
' Set rtnav = bodyItem.CreateNavigator( )
' move the insertion point to be the beginning of the first paragraph with the rtnav object
' Call rtnav.FindFirstElement( 4 ) 'RTELEM_TYPE_TEXTPARAGRAPH (4)
' Call bodyItem.BeginInsert(rtnav, False) 'False for parameter 2 (default) puts the insertion position at the beginning of the element.
Call rtItem.AppendText( strTextToInsert )
' End put the subject at the start of the body
End Function
Sub AddToArray( iArray As Variant, newValue As String )
On Error Goto ErrorAddToArray
If Isempty(iArray) Then ' if array was declared as a variant
Redim iArray(0) As String
End If
If ( Ubound(iArray) = Lbound(iArray) ) And iArray(Ubound(iArray)) = "" Then ' will raise err 200 if uninit
' if we are a new array with nothing in it then do not increase size
iArray(Lbound(iArray)) = newValue
Else
Dim newSize As Integer
newSize = Ubound(iArray)+1
ContinueFromErr:
Redim Preserve iArray(newSize)
iArray(newSize) = newValue
'AddToArray = iArray
End If
Exit Sub
ErrorAddToArray:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
newSize = 0
Resume ContinueFromErr
Else
Error Err, Error
End If
End Sub ' add to array
Sub PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument)
%REM
' 21/09/2004 ATK added parameter strOtherInfo as string to pass in other information
' ATK removed parameter and created function PoliceProcessWarning
'PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument )
----------------------------------------------------------------------------------------------------
Purpose: Process unexpected errors. Send a message with error information.
Parameters: strSendTo - email address to send the error message to; person or a group
strSubject - subject of the mailed error message
strFunctionName - name of the function where the error occurred
docWithError - the document to linked to
----------------------------------------------------------------------------------------------------
'
' This sub taken from TheView
%END REM
Dim session As NotesSession
Dim db As NotesDatabase
Dim docMemo As NotesDocument
Dim item As NotesItem
Dim rtiBody As NotesRichTextItem
Set session = New NotesSession
Set db = session.CurrentDatabase
Set docMemo = New NotesDocument(db)
Set item = New NotesItem(docMemo, "Form", "Memo")
item.IsSummary = True
'===================================================================
' Set the send to
'===================================================================
Dim vRecipients(0 To 1) As String
vRecipients(0) = "#LotusNotesError"
vRecipients(1) = "_SP-AppDesigner"
Set item = New NotesItem(docMemo, "SendTo", vRecipients )
Set item = New NotesItem(docMemo, "Logo", "Plain Text")
Set item = New NotesItem(docMemo, "Subject", strSubject)
item.IsSummary = True
'===================================================================
' Set the error specific fields
'===================================================================
Set item = docMemo.ReplaceItemValue("Application", db.title)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("Subroutine", strFunctionName)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorLine", Erl)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorNumber", Err )
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorMessage", Error$ )
item.IsSummary = True
'===================================================================
' Set the Body
'===================================================================
Set rtiBody = New NotesRichTextItem(docMemo, "Body")
Call rtiBody.AppendText("An unexpected error was encountered processing. ")
Call rtiBody.AddNewLine(2)
If Not (docWithError Is Nothing) Then
Call rtiBody.AppendText(" Error Document -> ")
Call rtiBody.AppendDocLink(docWithError, "")
Call rtiBody.AddNewLine(1)
End If
Call rtiBody.AppendText(" Database Title = " & db.title & " ---> ")
Call rtiBody.AppendDocLink(db, "DB throwing this error.")
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Server Name = " & db.server)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" FilePath= " & db.filepath )
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Subroutine = " & strFunctionName)
Call rtiBody.AddNewLine(2)
Call rtiBody.AppendText(" Error " & Err & " : " & Error$ + " at line number " & Erl )
Call rtiBody.AddNewLine(1)
'===================================================================
' Send it off
'===================================================================
Call docMemo.Send(False)
' print the info to the server log or console window
Print "ERROR in " & db.title & " - " + strFunctionName + ". Error " & Err & ": " & Error$ + " at line " & Erl
End Sub
Function GetCurrentDbInfo() As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim iString As String
iString = Chr(10) & "Title of db:" & db.Title
iString = iString & Chr(10) & "Filename of db:" & db.FileName
GetCurrentDbInfo = iString
End Function
Function GetMessageURLSmall( iMessage As String ) As String
GetMessageURLSmall = "Message?OpenForm&msg=" & EncodeURL(Replace(iMessage, """", "'"))
End Function
Function GetMessageURLMedium( iMessage As String ) As String
' get the message document if it does not exist, create it
Dim MESSAGE_VIEW_NAME As String
MESSAGE_VIEW_NAME = "vwMessage"
Dim docMessage As NotesDocument
Dim vwMessage As NotesView
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Set vwMessage = iGetView(db, MESSAGE_VIEW_NAME)
If vwMessage Is Nothing Then
'if the view is not there, then just use the small one
GetMessageURLMedium= GetMessageURLSmall(iMessage & "<!-- note to developer. Could not find view with name '" & MESSAGE_VIEW_NAME & "' -->")
Exit Function
End If
Dim KEEP_DOC_NUMBER As Integer
KEEP_DOC_NUMBER = 50
' get the 1st, 2nd, 3rd, 4th or 5th - KEEP_DOC_NUMBER doc as we should have 5 of them
' but we don't want to get the same one all the time
Dim iRandomNumber As Integer
' we want between 1 and KEEP_DOC_NUMBER
iRandomNumber = GetRandomIntInRange( 1, KEEP_DOC_NUMBER )
If iRandomNumber < 1 Or iRandomNumber > KEEP_DOC_NUMBER Then
Print "Could not get random number between 0 and " & Cstr(KEEP_DOC_NUMBER)
iRandomNumber = KEEP_DOC_NUMBER - 5 ' my own random
End If
Set docMessage = vwMessage.GetNthDocument(iRandomNumber)
Dim var As Variant
If docMessage Is Nothing Then
' create it
Set docMessage = db.CreateDocument( )
docMessage.Form = "Message"
var = Evaluate("@Unique", docMessage)
docMessage.ID = var
End If
If docMessage.ID(0) = "" Then
var = Evaluate("@Unique", docMessage)
docMessage.ID = var
End If
docMessage.SearchString = "" ' clear the search string as this is a saved doc
docMessage.Message = iMessage
docMessage.Information = "Created in script library to show error/warning messages"
docMessage.MessageAuthorAN = "*"
Call docMessage.ComputeWithForm( False, False )
Call docMessage.Save( True, True )
' Clean up messages if necessary - housekeeping, don't delete our current message
Call CleanUpOldMessageDocs( vwMessage, docMessage, KEEP_DOC_NUMBER )
GetMessageURLMedium = MESSAGE_VIEW_NAME & "/" & docMessage.ID(0) & "?OpenDocument"
End Function
Function GetRandomIntInRange( iMin As Integer, iMax As Integer ) As Integer
GetRandomIntInRange = Int( Rnd()*(iMax-iMin+1) ) + iMin
End Function
Sub CleanUpOldMessageDocs( iVwMessage As NotesView, docDontDelete As NotesDocument, KeepNumber As Integer )
' eg Keepnumber = 20
' lets keep keepNumber messages in the db
' lets clean up if there is more than KeepNumber
Dim docMessage As NotesDocument, docMessageNext As NotesDocument
Set docMessage = iVwMessage.GetFirstDocument( )
Dim removedCount As Long
While Not docMessage Is Nothing
Set docMessageNext = iVwMessage.GetNextDocument( docMessage )'
If removedCount > KeepNumber Then ' leave keepNumber messages in the system
If docMessage.Id(0) <> docDontDelete.Id(0) Then ' dont delete the one we just created
Print "<br>Cleaning up other messages - removing the message starting with {" & EncodeURL( Replace(Left(docMessage.Message(0), 200 ),"""", "'")) & "}<br><br>"
Call docMessage.Remove( False )
End If ' check id
End If 'removedCount > keepnumber
Set docMessage = docMessageNext
removedCount = removedCount + 1
If removedCount > ( KeepNumber + 20 ) Then
Print "Cleaning up messages. Removed max, 20 documents. Getting out."
Set docMessage = Nothing
Else
End If
Wend
End Sub
Function GetMessageURLLarge( iMessage As String ) As String
' I can't think of what to do differently for
' large and medium messages.
GetMessageURLLarge = GetMessageURLMedium( iMessage )
End Function
Function GetMessageURL ( iMessage As String ) As String
'depending on the size of the message, show different things'
' for a very small message, then just show the MailingRequest form with
' the message at teh top for larger messages, save it to a document
' and return the URL of that document
Dim MESSAGE_SMALL As Long
Dim MESSAGE_MEDIUM As Long
Dim MESSAGE_LARGE As Long
MESSAGE_SMALL = 50
MESSAGE_MEDIUM = 100
MESSAGE_LARGE = 1000000
Dim lngMessageSize As Long
lngMessageSize = Len(iMessage)
If lngMessageSize < MESSAGE_SMALL Then
GetMessageURL = GetMessageURLSmall( iMessage )
Elseif lngMessageSize < MESSAGE_MEDIUM Then
GetMessageURL = GetMessageURLMedium( iMessage )
Else
GetMessageURL = GetMessageURLLarge( iMessage )
End If ' message size
End Function
Function GetHTMLBackLinks(doc) As String
' to be used on the print out results of an agent
Dim strPoliceLastURL As String
Dim strThisURL As String
Dim strQuery_String As String
strPoliceLastURL = doc.HTTP_Referer(0)
strThisURL = doc.Path_Info_Decoded(0)
strQuery_String = doc.Query_String(0)
If strQuery_String <> "" Then
strThisURL = strThisURL '& "?" & strQuery_String
End If
' use single quotes here, not doulble quotes as it will prob be used
' in a url in a quote delimeted by " " that is double quotes
Dim strHome As String
strHome = {<a href=''>Go Home</a>} ' yes, blank
Dim strHistoryBack As String
strHistoryBack = {<a href='javascript:history.go(-1);'>History-1</a>}
strHistoryBack = strHistoryBack & {<a href='javascript:history.go(-2);'>History-2</a>}
GetHTMLBackLinks = strHome & { <a href='} & strPoliceLastURL &_
{'>Go Back</a> <a href='} & strThisURL & {'>Try Again</a>} &_
{ } & strHistoryBack
End Function
Function GoToURL( iUrl As String) As String
' Prints out the html and javascript to change pages.
' includes its own "/"
' we will make sure that if we are using a small url
' that we convert "" to single ' quotes
' Changed to use location.replace, not location =
Dim iString As String
' check if the nsf is already in the name
Dim thisFileNameAndPath As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
thisFileNameAndPath = "/" & Replace(db.FilePath,"\","/")
If Instr( iUrl, thisFileNameAndPath ) > 0 Then
' leave the url alone as it has the name and path,
Else
' append the name at the beginning
iUrl = thisFileNameAndPath + "/" + iUrl
End If
iUrl = Replace(iUrl, |"|, |'| )
iString = |<script language="javascript">|
iString = iString & |location.replace("| & iUrl & |")|
iString = iString & |</script>|
GoToURL = iString
End Function
Function EncodeURL( iString As String ) As String
Dim vntResult As Variant
' Double quotes do not work in @URLEncode
iString = Replace( iString, """", "'" )
vntResult = Evaluate(|@URLEncode( "Domino"; "| & iString & |")|)
If Datatype(vntResult) <> 0 Then
EncodeURL = vntResult(0)
Else
EncodeURL = ""
End If
End Function
Function DecodeURL( iString As String ) As String
Dim vntResult As Variant
vntResult = Evaluate(|@URLDecode( "Domino"; "| & iString & |")|)
If Datatype(vntResult) <> 0 Then
DecodeURL = vntResult(0)
Else
DecodeURL = ""
End If
End Function
Function RemoveVowels(iString As String) As String
' remove a, e, i, o, u
'sourceArray = ["first second third"]
'replaceArray = ["first"]["second"]["1"]["third"]["2"]["3"]
'replacementArray = ["1"]["2"]["a"]["3"]["b"]["c"]
Dim removeThese(4) As String
removeThese(0) = "a"
removeThese(1) = "e"
removeThese(2) = "i"
removeThese(3) = "o"
removeThese(4) = "u"
Dim sourceString(0) As String
sourceString(0) = iString
Dim replaceWith(0) As String
replaceWith(0) = "" ' blank
Dim iVar As Variant
If Len(iString) = 0 Then
' do nothing as it is empty string
iVar(0) = iString
Else
iVar = Replace( sourceString, removeThese, replaceWith )
End If
RemoveVowels = iVar(0)
End Function ' RemoveVowels
Function CheckAlphaNum( iString, iException ) As Integer
' check if the string is alpha numeric
' allows spaces and "-" dashes
' returns 0 if there is no problem, otherwise
' returns the position of the offending character
' eg iException = "-"
' renamed this from IsAlphaNum as we are not returning a boolean
CheckAlphaNum = 0 ' default to zero, ie no non alphanum found
Dim startOfAlphaAsciiCode As Integer, endOfAlphaAsciiCode As Integer
Dim startOfNumAsciiCode As Integer, endOfNumAsciiCode As Integer
Dim asciiCodeException As Integer, asciiCodeSpace As Integer
' Set up the ascii codes to check
startOfAlphaAsciiCode = Asc("A") ' upper case A
endOfAlphaAsciiCode = Asc ("z") ' to lowercase z
startOfNumAsciiCode = Asc("0") ' zero
endOfNumAsciiCode = Asc ("9" )
asciiCodeSpace = Asc( " " )
If Len(iException) = 1 Then ' if there is nothing or a string
asciiCodeException = Asc(iException)
Else
asciiCodeException = asciiCodeSpace ' ie ignore this
End If
' Convert the input to an array of characters for processing
Dim ArrayOfChars As Variant ' (Len(iString)) As String
ArrayOfChars = SplitStringToChars (iString)
Dim charIdx As Integer ' the index of where we are at
' Loop through each character, exiting if we find even one error. Return the pos of invalid char
Dim lenOfArray As Integer
lenOfArray = Ubound(ArrayOfChars) + 1
Dim var1 As Variant
Dim asciiValueThisChar As Integer
Do While charIdx < lenOfArray And CheckAlphaNum = 0
' Check if Not ( isAlpha Or isNum or is Dash )
asciiValueThisChar = Asc(ArrayOfChars(charIdx))
charIdx = charIdx + 1
If Not ( _
( asciiValueThisChar >= startOfAlphaAsciiCode And asciiValueThisChar <= endOfAlphaAsciiCode ) Or _
( asciiValueThisChar >= startOfNumAsciiCode And asciiValueThisChar <= endOfNumAsciiCode ) Or _
asciiValueThisChar = asciiCodeException Or _
asciiValueThisChar = asciiCodeSpace ) Then
' failure
CheckAlphaNum = charIdx
End If '
Loop
'--Do While charIdx <= lenOfArray And IsAlphaNum = 0
CheckAlphaNum = CheckAlphaNum ' code here for ease of reading. either 0 as default or pos of invalid char
End Function ' IsAlphaNum
Function SplitStringToChars( iString )
' am not using split because it cannot take "" as the
' second parameter
' given "abc" returns
' array(0) = "a"
' array(1) = "b"
' array(2) = "c"
' given "abc def" returns
' array(0) = "a"
' array(1) = "b"
' array(2) = "c"
' array(3) = " "
' array(4) = "d"
' array(5) = "e"
Dim lenOfSource As Integer
lenOfSource = Len(iString)
Redim returnArray(0 To lenOfSource-1) As String
Dim i As Integer
For i = 1 To lenOfSource
' Mid ( iString , start [ , length ]
returnArray(i-1) = Mid ( iString , i, 1 )
Next
SplitStringToChars = returnArray
End Function
Function GetArgFromQuery_String(iArgName, iQuery_String) As String
' eg GetArgFromQuery_String("&user=", "OpenAgent&user=Anthony"
Dim lenOfArgWithValue As Integer
Dim lenOfValue As Integer
Dim argValue As String
If Instr(iQuery_String, iArgName) <= 0 Then
GetArgFromQuery_String = ""
Exit Function
End If
lenOfArgWithValue = Len(iQuery_String) - ( Instr(iQuery_String, iArgName) -1 )
lenOfValue = lenOfArgWithValue - Len(iArgName)
argValue = Right( iQuery_String, lenOfValue )
' check if there are any more args after this one, if there is an &
Dim hasAmp As Integer ' the pos of an ampersand char
hasAmp = Instr(argValue, "&" )
If hasAmp > 0 Then
argValue = Left( argValue, hasAmp-1 )
End If
GetArgFromQuery_String = DecodeURL(argValue)
End Function
Function HasRole( strRoleName As String, strFullUsername As String ) As Boolean
' strFullUserName, eg "CN=Anthony T Kendrick/OU=Staff/O=NSWPolice"
' I thikn that the role name should be encased in "[]" eg "[Admin]"
If Instr(strRoleName, "[" ) <=0 Then
strRoleName = "[" & strRoleName
End If
If Instr(strRoleName, "]") <=0 Then
strRoleName = strRoleName & "]"
End If
Dim strUsernameWarning As String
If Not IsCanonicalFormat( strFullUserName ) Then
strUsernameWarning = "Note that roles are " & _
"queried based on full user name eg, "&_
"of the form CN=FirstName Lastname/O=The Organisation. " &_
"It appears that the user name passed in '" & strFullUserName & "' " &_
"is not of canonical format"
Error 1000, strUsernameWarning & " Function: HasRole()"
End If
Dim session As New NotesSession()
Dim db As NotesDatabase
Dim roles As Variant
Set db = session.CurrentDatabase
' Default to false
HasRole = False
roles = db.QueryAccessRoles(strFullUsername)
If roles(0) = "" Then
HasRole = False
Else
Forall role In roles
If role = strRoleName Then
HasRole = True
Exit Function
End If
End Forall
End If
End Function ' HasRole
Function GetAsHTMLComment( iString ) As String
GetAsHTMLComment = Chr(10) & Chr(13) & "<!-- " & iString & "-->"
End Function
Function ConvertDateToYYYYMM ( dtADate As Variant ) As String
' eg given 05/08/2004 returns 200408
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
' Pad or Cut makes sure that the month is not "2", but "02"
ConvertDateToYYYYMM = Cstr( Year( dtADate )) & PadOrCut( Cstr( Month(dtADate )), 2, 2, "0" )
End Function
Function ConvertDateToMMMYYYY ( dtADate As Variant ) As String
' eg given 05/08/2004 returns August 2004
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
ConvertDateToMMMYYYY = GetMonthName( Month(dtADate )) & " " & Cstr( Year( dtADate ))
End Function
Function GetMonthName( intMonthNumber As Integer ) As String
' eg give 1, returns "January"
Dim strMonth As String
Select Case intMonthNumber
Case 1
strMonth = "January"
Case 2
strMonth = "February"
Case 3
strMonth = "March"
Case 4
strMonth = "April"
Case 5
strMonth = "May"
Case 6
strMonth = "June"
Case 7
strMonth = "July"
Case 8
strMonth = "August"
Case 9
strMonth = "September"
Case 10
strMonth = "October"
Case 11
strMonth = "November"
Case 12
strMonth = "December"
Case Else
strMonth = Cstr(intMonthNumber)
End Select
GetMonthName = strMonth
End Function
Sub PoliceProcessWarning( strSubject As String, strFunctionName As String, docWithError As NotesDocument, strOtherInfo As String )
%REM
' 21/09/2004 ATK Created from PoliceProcessError.
'PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument )
----------------------------------------------------------------------------------------------------
Purpose: Process warnings. Send a message with error information.
Parameters: strSendTo - email address to send the error message to; person or a group
strSubject - subject of the mailed error message
strFunctionName - name of the function where the error occurred
docWithError - the document to linked to
----------------------------------------------------------------------------------------------------
' Does not print the log or console at the end like the process error function
' This sub taken from TheView
%END REM
Dim session As NotesSession
Dim db As NotesDatabase
Dim docMemo As NotesDocument
Dim item As NotesItem
Dim rtiBody As NotesRichTextItem
Set session = New NotesSession
Set db = session.CurrentDatabase
Set docMemo = New NotesDocument(db)
Set item = New NotesItem(docMemo, "Form", "Memo")
item.IsSummary = True
'===================================================================
' Set the send to
'===================================================================
Dim vRecipients(0 To 1) As String
vRecipients(0) = "#Errors in Apps"
vRecipients(1) = "_SP-AppDesigner"
Set item = New NotesItem(docMemo, "SendTo", vRecipients )
Set item = New NotesItem(docMemo, "Logo", "Plain Text")
Set item = New NotesItem(docMemo, "Subject", strSubject)
item.IsSummary = True
'===================================================================
' Set the error specific fields
'===================================================================
Set item = docMemo.ReplaceItemValue("Application", db.title)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("Subroutine", strFunctionName)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorLine", Erl)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorNumber", Err )
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorMessage", Error$ )
item.IsSummary = True
'===================================================================
' Set the Body
'===================================================================
Set rtiBody = New NotesRichTextItem(docMemo, "Body")
Call rtiBody.AppendText("An unexpected error was encountered processing. ")
Call rtiBody.AddNewLine(2)
If Not (docWithError Is Nothing) Then
Call rtiBody.AppendText(" Error Document -> ")
Call rtiBody.AppendDocLink(docWithError, "")
Call rtiBody.AddNewLine(1)
End If
Call rtiBody.AppendText(" Database Title = " & db.title & " ---> ")
Call rtiBody.AppendDocLink(db, "DB throwing this error.")
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Server Name = " & db.server)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Filename = " & db.filename)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Subroutine = " & strFunctionName)
Call rtiBody.AddNewLine(2)
Call rtiBody.AppendText(" Error " & Err & " : " & Error$ + " at line number " & Erl )
Call rtiBody.AddNewLine(1)
If strOtherInfo <> "" Then
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText( strOtherInfo )
Call rtiBody.AddNewLine(1)
End If
'===================================================================
' Send it off
'===================================================================
Call docMemo.Send(False)
End Sub
Function IsAbbreviatedFormat( strUserName As String ) As Boolean
'eg abbreviated "John B Goode/Sales/East/Acme/US"
If IsCanonicalFormat( strUserName ) = True Then
IsAbbreviatedFormat = False
Else
If Instr( strUserName, "/" ) > 0 Then
IsAbbreviatedFormat = True
Else
IsAbbreviatedFormat = False
End If
End If
End Function '-- IsAbbreviatedFormat
Function IsCommonFormat ( strUserName As String ) As Boolean
' eg common "John B Goode"
If Instr( strUserName, "/" ) Then
IsCommonFormat = False
Else
IsCommonFormat = True
End If
End Function '-- IsCommonFormat
Sub CleanUpOldDocs( iView As NotesView, docDontDelete As NotesDocument, KeepNumber As Integer )
' eg Keepnumber = 20
' lets keep keepNumber messages in the db
' lets clean up if there is more than KeepNumber
Dim doc As NotesDocument, docNext As NotesDocument
Set doc = iView.GetFirstDocument( )
Dim removedCount As Long
While Not doc Is Nothing
Set docNext = iView.GetNextDocument( doc )'
If removedCount > KeepNumber Then ' leave keepNumber of these docs in the system
If doc.Id(0) <> docDontDelete.Id(0) Then ' dont delete the one we just created
' Print "<br>Cleaning up other docs of this type - removing the doc starting with {" & EncodeURL( Replace(Left(docMessage.Message(0), 200 ),"""", "'")) & "}<br><br>"
Call doc.Remove( False )
End If ' check id
End If 'removedCount > keepnumber
Set doc = docNext
removedCount = removedCount + 1
If removedCount > ( KeepNumber + 20 ) Then
Print "Cleaning up docs. Removed max, 20 documents. Getting out."
Set doc = Nothing
Else
' do nothing
End If
Wend
End Sub
Function IsAccessLevelAtLeast ( required_level As String ) As Integer
' Returns true if the user has the level of access or greater requested.
' NOT case sensitive
' required_level = ["manager", "designer", "editor", "author", "reader", "depositor", "noaccess"]
%REM
ACLLEVEL_NOACCESS (0)
ACLLEVEL_DEPOSITOR (1)
ACLLEVEL_READER (2)
ACLLEVEL_AUTHOR (3)
ACLLEVEL_EDITOR (4)
ACLLEVEL_DESIGNER (5)
ACLLEVEL_MANAGER (6)
%ENDREM
Dim required As Integer
Dim session As New NotesSession
Dim db As NotesDatabase
Dim level As Integer
Set db = session.CurrentDatabase
IsAccessLevelAtLeast = False
Select Case Lcase( required_level)
Case "manager"
required = 6
Case "designer"
required = 5
Case "editor"
required = 4
Case "author"
required = 3
Case "reader"
required = 2
Case "depositor"
required = 1
Case "noaccess"
required = 0
Case Else
Print "Exiting. Error Cannot determine access level. Sub CheckAccessLevel(" & required_level & ")"
IsAccessLevelAtLeast = False
Exit Function
End Select
level = db.CurrentAccessLevel
If level >= required Then
IsAccessLevelAtLeast = True
End If
End Function
Sub QuickSort (lngLbound As Long,lngUbound As Long, varSortArray As Variant)
'Pass the lower bound of the array to lngLbound, the upper bound of the array to lngUbound and the array to varSortArray.
Dim varValue1 As Variant
Dim varValue2 As Variant
Dim lngTmpLbound As Long
Dim lngTmpUbound As Long
If lngUbound > lngLbound Then 'If there's nothing to sort, jump out
varValue1 = varSortArray(lngLbound) 'Initialize boundaries, nominate a value To sort
lngTmpUbound = lngUbound
lngTmpLBound = lngLbound
While (lngTmpLBound < lngTmpUbound) 'Repeat until lngTmpLBound and lngTmpUbound "meet in the middle"
While (varSortArray(lngTmpLBound) <= varValue1 And lngTmpLBound < lngUbound) 'Push in the boundaries while data is sorted
lngTmpLBound = lngTmpLBound + 1
Wend
While (varSortArray(lngTmpUbound) > varValue1)
lngTmpUbound = lngTmpUbound - 1
Wend
If lngTmpLBound < lngTmpUbound Then 'If there is data between lngTmpLBound and lngTmpUbound something is out of order - swap it
varValue2 = varSortArray(lngTmpLBound)
varSortArray(lngTmpLBound) = varSortArray(lngTmpUbound)
varSortArray(lngTmpUbound) = varValue2
End If
Wend
varValue2 = varSortArray(lngLbound) 'Swap the nominated and bottom values - why we came here
varSortArray(lngLbound) = varSortArray(lngTmpUbound)
varSortArray(lngTmpUbound) = varValue2
Call QuickSort (lngLbound, lngTmpUbound - 1, varSortArray) 'Recurse and sort data either side of upper bound
Call QuickSort ((lngTmpUbound + 1), lngUbound, varSortArray)
End If
End Sub
Function RemoveNonAlphaNum ( Byval strSource As String ) As String
' eg given You are 'da man 344
' returns You are da man 344
' alphaArray(0) =
' alphaUArray ' upper case
Dim numberArray(0 To 9) As String ' 9 is upper bound, not size
numberArray(0) = "0"
numberArray(1) = "1"
numberArray(2) = "2"
numberArray(3) = "3"
numberArray(4) = "4"
numberArray(5) = "5"
numberArray(6) = "6"
numberArray(7) = "7"
numberArray(8) = "8"
numberArray(9) = "9"
Dim alphaArray(0 To 25) As String
alphaArray(0) = "a"
alphaArray(1) = "b"
alphaArray(2) = "c"
alphaArray(3) = "d"
alphaArray(4) = "e"
alphaArray(5) = "f"
alphaArray(6) = "g"
alphaArray(7) = "h"
alphaArray(8) = "i"
alphaArray(9) = "j"
alphaArray(10) = "k"
alphaArray(11) = "l"
alphaArray(12) = "m"
alphaArray(13) = "n"
alphaArray(14) = "o"
alphaArray(15) = "p"
alphaArray(16) = "q"
alphaArray(17) = "r"
alphaArray(18) = "s"
alphaArray(19) = "t"
alphaArray(20) = "u"
alphaArray(21) = "v"
alphaArray(22) = "w"
alphaArray(23) = "x"
alphaArray(24) = "y"
alphaArray(25) = "z"
Dim alphaUArray(0 To 25) As String
alphaUArray(0) = "A"
alphaUArray(1) = "B"
alphaUArray(2) = "C"
alphaUArray(3) = "D"
alphaUArray(4) = "E"
alphaUArray(5) = "F"
alphaUArray(6) = "G"
alphaUArray(7) = "H"
alphaUArray(8) = "I"
alphaUArray(9) = "J"
alphaUArray(10) = "K"
alphaUArray(11) = "L"
alphaUArray(12) = "M"
alphaUArray(13) = "N"
alphaUArray(14) = "O"
alphaUArray(15) = "P"
alphaUArray(16) = "Q"
alphaUArray(17) = "R"
alphaUArray(18) = "S"
alphaUArray(19) = "T"
alphaUArray(20) = "U"
alphaUArray(21) = "V"
alphaUArray(22) = "W"
alphaUArray(23) = "X"
alphaUArray(24) = "Y"
alphaUArray(25) = "Z"
' Notes 6, use replace
Dim strBadChars As String
strBadChars = strSource
strBadChars = Replace( strBadChars, numberArray, "" )
strBadChars = Replace( strBadChars, alphaArray, "" )
strBadChars = Replace( strBadChars, alphaUArray, "" )
strBadChars = Trim( strBadChars )
' I tried to use a variant, instead of a String array and the Replace function
' died.
If Len(strBadChars) > 1 Then
Dim intUbound As Integer
intUbound = Len(strBadChars) - 1
Redim strBadCharsArr(0 To intUbound) As String
Dim i As Integer
For i = 0 To intUbound
strBadCharsArr(i) = Mid ( strBadChars, i+1, 1 )
Next
strSource = Replace( strSource, strBadCharsArr, "" )
Else
strSource = Replace( strSource, strBadChars, "" )
End If
RemoveNonAlphaNum = strSource
End Function
Sub GetAllGroupsInACL( strGroupsInACLArr As Variant )
' modify the strGroupsInACLArr array to include all of the groups in the acl
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim acl As NotesACL
Dim aclentry As NotesACLEntry
Set acl = db.ACL
Set aclentry = acl.GetFirstEntry()
Dim intACLGroupCount As Integer
intACLGroupCount = 0
Do While Not aclentry Is Nothing
If aclentry.IsGroup Then
Redim Preserve strGroupsInACLArr(0 To intACLGroupCount) As String
strGroupsInACLArr( intACLGroupCount ) = aclentry.Name
intACLGroupCount = intACLGroupCount + 1
End If ' is group
Set aclentry = acl.GetNextEntry( aclentry )
Loop
' end loop while not aclentry is nothing
End Sub
Function ChooseAddressBook( strServer As String ) As NotesDatabase
Dim session As New NotesSession()
Dim vAddBooks As Variant
vAddBooks = session.AddressBooks
Dim dbAddressBook As NotesDatabase
Dim intPubCount As Integer
Dim intBookIdx As Integer
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
intPubCount = intPubCount + 1
End If
Next
If intPubCount = 1 Then
For intBookIdx = 0 To Ubound(vAddBooks)
If Not vAddBooks(intBookIdx).IsOpen Then ' Might already be open
Call vAddBooks(intBookIdx).Open("","") ' must open first
End If ' isopen
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
Set dbAddressBook = vAddBooks(intBookIdx)
intBookIdx = Ubound(vAddBooks) 'jump out of for loop
End If
Next
Else
'============================================================
' There are multiple address books, so let the user choose
Dim intPubIdx As Integer
Redim strPubAddBooksArr(Ubound(vAddBooks)) ' a string to prompt user
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
strPubAddBooksArr(intPubIdx) = vAddBooks(intBookIdx).Title 'jump out of for loop
intPubIdx = intPubIdx + 1
End If
Next
Dim workspace As New NotesUIWorkspace
Dim response As Variant
response = workspace.Prompt (PROMPT_OKCANCELLIST, _
"Select an server to update", _
"Select an server to update", _
strPubAddBooksArr(0), strPubAddBooksArr)
If Isempty (response) Then
Set dbAddressBook = Nothing
Else
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
If vAddBooks(intBookIdx).Title = response Then
Set dbAddressBook = vAddBooks(intBookIdx) 'jump out of for loop
intBookIdx = Ubound(vAddBooks) ' jump out
End If ' Title
End If ' IsPublic
Next
End If
End If ' intPubcount
Set ChooseAddressBook = dbAddressBook
End Function
Function ConvertRoleToString( intRole As Integer) As String
%REM
ACLTYPE_UNSPECIFIED (0)
ACLTYPE_PERSON (1)
ACLTYPE_SERVER (2)
ACLTYPE_MIXED_GROUP (3)
ACLTYPE_PERSON_GROUP (4)
ACLTYPE_SERVER_GROUP (5)
%ENDREM
Dim strRole As String
Select Case intRole
Case 0
strRole = "Unspecified"
Case 1
strRole = "Person"
Case 2
strRole = "Server"
Case 3
strRole = "Mixed Group"
Case 4
strRole = "Person Group"
Case 5
strRole = "Server Group"
Case Else
Error 1000, "No string coded for a role type of " & intRole
End Select
ConvertRoleToString = strRole
End Function
Function ConvertAccessLevelToString( intAccessLevel As Integer ) As String
' eg to use this try " Your access level is " & ConvertAccessLevelToString( db.CurrentAccessLevel )
Dim strLevel As String
Select Case Lcase( intAccessLevel )
Case 6
strLevel = "Manager"
Case 5
strLevel = "Designer"
Case 4
strLevel = "Editor"
Case 3
strLevel = "Author"
Case 2
strLevel = "Reader"
Case 1
strLevel = "Depositor"
Case 0
strLevel = "No Access"
Case Else
Error 1000, "Exiting. Error cannot determine access level. Sub ConvertAccessLevelToString( )"
Exit Function
End Select
ConvertAccessLevelToString = strLevel
End Function
Function GetAccessLevelAsString( ) As String
Dim intCurrentLevel As Integer
Dim strCurrentLevel As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
intCurrentLevel = db.CurrentAccessLevel
GetAccessLevelAsString = ConvertAccessLevelToString( intCurrentLevel )
End Function
Function FileExists( strPathAndFile As String ) As Boolean
' Input: pathname is the filepath and filename eg "c:\temp\cat.txt"
' Return 1 if file exists, else return 0
On Error Goto HandleFileExistsError
Dim blFileExists As Boolean
blFileExists = False
Dim fileName As String
fileName$ = Dir$(strPathAndFile$, 0) ' 0 for normal file, 16 for directory
If fileName$ <> "" Then
blFileExists = True
Else
Dim session As New NotesSession()
If session.IsOnServer Then
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Print "fileExists: Warning - we are on a server you know - server name is [" & db.Server & "] is your file on the server?"
End If
' if session.CurrentAgent.
blFileExists = False
End If
NormalExit:
FileExists = blFileExists
Exit Function
HandleFileExistsError:
If Err = 76 Then '76 Path not found, eg if we pass in a path, not a file....
' guess the file doesn't exist, return false
blFileExists = False
Print "Warning file exists was code to check files.. are you checking a directory ? '" & strPathAndFile & "' )"
Resume NormalExit
Else
Error Err & " Error in sub FileExits - " & Error
End If
End Function
Function GetAbbreviatedName( strNameInCanonical As String ) As String
' remove the 0= and the CN=
' given CN=Anthony Kendrick/OU=45456464/OU=Staff/OU=NSWPolice
' returns "Anthony Kendrick/54844654/Staff/NSWPolice"
Dim strNewFormat As String
strNewFormat = strNameInCanonical
strNewFormat = Replace(strNewFormat, "OU=", "")
strNewFormat = Replace(strNewFormat, "CN=", "")
strNewFormat = Replace(strNewFormat, "O=", "")
GetAbbreviatedName = strNewFormat
End Function ' GetAbbreviatedName
Function OpenDirectoryDialog(blMultipleSelect, strTitle, _
strInitialDir, strInitialFile ) As String
' Simulate picking a diretory by getting a file
' and then stripping off the filename
' note there must be a file to select in the directory
Dim ws As New NotesUIWorkspace()
Dim vReturn
vReturn=ws.OpenFileDialog(False,"Please Select Directory", "*.*", "")
Dim strFileName As String
If Isempty(vReturn) Then
strFileName = ""
Else
strFileName =vReturn(0)
End If
OpenDirectoryDialog = GetFilePathFromFileNameAndPath( strFileName )
End Function
Function PrintOutFilesInDir( strDirectory As String )
Dim strTextFileName As String
Print "List of files in directory " & strDirectory
Dim intMaxFiles As Integer
intMaxFiles = 500
Dim intCounter As Integer
If fileExists( strDirectory ) = 1 Then
strTextFileName = Dir( strDirectory, 0 )
If strTextFileName = "" Then
Print "There are no files in the directory to process."
Else
Do While strTextFileName <> ""
Print "File listing '" & strTextFileName & "'"
' Get the next file in the directory
strTextFileName = Dir$()
intCounter = intCounter + 1
If intCounter > intMaxFiles Then
Print "Only showing a max of " & Cstr(intMaxFiles) " files. "
Exit Function
End If
Loop
End If
Print "Printing directories..."
intCounter = 0
strTextFileName = Dir( strDirectory, 16 ) ' 16 is directories
If strTextFileName = "" Then
Print "There are no directories in the directory to process."
Else
Do While strTextFileName <> ""
Print "File listing '" & strTextFileName & "'"
' Get the next file in the directory
strTextFileName = Dir$()
intCounter = intCounter + 1
If intCounter > intMaxFiles Then
Print "Only showing a max of " & Cstr(intMaxFiles) " files. "
Exit Function
End If
Loop
End If
Else
'Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
Dim strMessage As String
strMessage = "Possible error, does not look like the file/directory exists at " & strDirectory &_
". The current directory, ie where I am running on the server is " & Curdir$()
Print strMessage
End If
End Function
Function GetMemoIDFromPersonDoc ( docPerson As NotesDocument ) As String
Dim strMemoID As String
strMemoID = docPerson.ShortName(0)
If Isnumeric ( strMemoID ) = True Then
If Ubound( docPerson.ShortName ) > 0 Then
' try the other one
strMemoID = docPerson.ShortName( 1 )
End If
End If ' is numeric
GetMemoIDFromPersonDoc = strMemoId
End Function '--GetMemoIDFromPersonDoc (
Function GetSerialNumberFromPersonDoc ( docPerson As NotesDocument ) As String
Dim strSerialNum As String
strSerialNum = docPerson.ShortName(0)
If Isnumeric ( strSerialNum ) = False Then
If Ubound( docPerson.ShortName ) > 0 Then
' try the other one
strSerialNum = docPerson.ShortName( 1 )
End If
End If ' is numeric
GetSerialNumberFromPersonDoc = strSerialNum
End Function '--GetSerialNumberFromPersonDoc (
Function GetGenericHTMLLinkToDoc ( strID As String, strLinkText As String )
' return a string with the link
Dim strViewName As String
Dim strDocID As String
strViewName = "vwById"
strDocID = strID
Dim strURL As String
strURL = strViewName & |/| & strDocID & |?OpenDocument|
If strLinkText = "" Then
strLinkText = strURL
End If
GetGenericHTMLLinkToDoc =|<a href="| & strURL & |">| & strLinkText & |</a>|
End Function ' GetGenericHTMLLinkToDoc
Function GetNextAlphabetLetter( strAlphabetLetter As String ) As String
' Check for one and only one character
If Len(strAlphabetLetter) <> 1 Then
Error 1000, "I am expecting an alphabet letter of 1 character, but got " & strAlphabetLetter
End If
' Check we are in the correct range first
If Not IsAlpha(strAlphabetLetter) Then
Error 1000, "I am expecting an alphabet letter, but got " & strAlphabetLetter
End If
Dim strNextLetter As String
' Special cases are for z and Z
If Asc("Z") = Asc(strAlphabetLetter) Then
strNextLetter = "A"
Elseif Asc("z") = Asc(strAlphabetLetter ) Then
strNextLetter = "a"
Else
strNextLetter = Chr(Asc(strAlphabetLetter) + 1)
End If
GetNextAlphabetLetter = strNextLetter
End Function
Function IsAlpha( strString ) As Boolean
' check if the string is alpha
' allows spaces and "-" dashes
' returns 0 if there is no problem, otherwise
' returns the position of the offending character
Dim blStillAlpha As Boolean
blStillAlpha = True ' default to true
Dim startOfUpperAlphaAsciiCode As Integer, endOfUpperAlphaAsciiCode As Integer
Dim startOfLowerAlphaAsciiCode As Integer, endOfLowerAlphaAsciiCode As Integer
' Set up the ascii codes to check
startOfUpperAlphaAsciiCode = Asc("A") ' upper case A
startOfLowerAlphaAsciiCode = Asc("a") ' upper case A
endOfUpperAlphaAsciiCode = Asc ("Z") ' to lowercase z
endOfLowerAlphaAsciiCode = Asc ("z") ' to lowercase z
' Convert the input to an array of characters for processing
Dim ArrayOfChars As Variant ' (Len(iString)) As String
ArrayOfChars = SplitStringToChars (strString)
Dim charIdx As Integer ' the index of where we are at
' Loop through each character, exiting if we find even one error.
Dim lenOfArray As Integer
lenOfArray = Ubound(ArrayOfChars) + 1
Dim var1 As Variant
Dim asciiValueThisChar As Integer
Do While charIdx < lenOfArray And blStillAlpha = True
' Check if Not ( isAlpha Or isNum or is Dash )
asciiValueThisChar = Asc(ArrayOfChars(charIdx))
charIdx = charIdx + 1
If Not ( _
( asciiValueThisChar >= startOfUpperAlphaAsciiCode _
And asciiValueThisChar <= endOfUpperAlphaAsciiCode ) Or _
( asciiValueThisChar >= startOfLowerAlphaAsciiCode _
And asciiValueThisChar <= endOfLowerAlphaAsciiCode ) ) Then
' failure
blStillAlpha = False
End If '
Loop
'--Do While charIdx <= lenOfArray And IsAlphaNum = 0
IsAlpha = blStillAlpha ' code here for ease of reading. either 0 as default or pos of invalid char
End Function ' IsAlpha
Function TranslateIntToChar( intInput As Integer) As String
' eg given 1, return "A"
' eg given 2, return "B" etc
If intInput > 26 Then
Error 1000, "TranslateIntToChar: I was expecting an integer " & _
"smaller than 26, but got " & Cstr(intInput)
End If
If intInput < 1 Then
Error 1000, "TranslateIntToChar: I was expecting an integer " & _
"greater than 0, but got " & Cstr(intInput)
End If
' Return uppercase
Dim intStartOfAsciiRange As Integer, intInputAsciiRange As Integer
intStartOfAsciiRange = Asc("A") ' eg 65
' move the input to the ascii alphabet range for translation
intInputAsciiRange = intInput + intStartOfAsciiRange - 1
TranslateIntToChar = Chr(intInputAsciiRange)
End Function
Function GetPrevAlphabetLetter( strAlphabetLetter As String ) As String
' Check for one and only one character
If Len(strAlphabetLetter) <> 1 Then
Error 1000, "I am expecting an alphabet letter of 1 character, but got " & strAlphabetLetter
End If
' Check we are in the correct range first
'If Not IsAlpha(strAlphabetLetter) Then
' Error 1000, "I am expecting an alphabet letter, but got " & strAlphabetLetter
' End If
Dim strNextLetter As String
' Special cases are for z and Z
If Asc("A") = Asc(strAlphabetLetter) Then
strNextLetter = "Z"
Elseif Asc("a") = Asc(strAlphabetLetter ) Then
strNextLetter = "z"
Else
strNextLetter = Chr(Asc(strAlphabetLetter) - 1)
End If
GetPrevAlphabetLetter = strNextLetter
End Function
Sub AddSectionToRTItem( doc As NotesDocument, strRTItemName As String, strTitle As String, strText As String )
' Appends a section to the end of a rich text item
Dim session As New NotesSession
Dim rti As NotesRichTextItem
Set rti = doc.GetFirstItem( strRTItemName )
Dim rtstyle As NotesRichTextStyle
Set rtstyle = session.CreateRichTextStyle
rtstyle.Bold = True
Dim colorObject As NotesColorObject
Set colorObject = session.CreateColorObject
colorObject.NotesColor = COLOR_RED
Call rti.BeginSection(strTitle, rtstyle, colorObject, True)
Call rti.AppendText(strText)
Call rti.EndSection
Call doc.Save(True, True)
End Sub
Sub IncreaseCountField( docWithCountField As NotesDocument, strCountFieldName As String )
Dim intPreviousCount As Integer
Dim vPreviousValue As Variant
If docWithCountField.HasItem( strCountFieldName ) Then
vPreviousValue = docWithCountField.GetItemValue( strCountFieldName )(0)
If Datatype( vPreviousValue ) = 2 Then ' 2 is integer
intPreviousCount = vPreviousValue
Else
intPreviousCount = 0
End If ' datatype
Else
intPreviousCount = 0
End If ' has item
Call docWithCountField.ReplaceItemValue( strCountFieldName, intPreviousCount + 1 )
End Sub
Sub SendMail( strFrom As String, vTo As Variant, strSubject As String, Body As Variant)
' 18/04/2005 ATK copied strFrom MailResults
' version 2.... I like it
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
' only send if we have names to send to
If Datatype( vTo ) = 8 Then '8 String V_STRING
If vTo = "" Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
Else
Dim someoneToSendTo As Integer
someoneToSendTo = False
Forall bit In vTo
If bit <> "" Then
someoneToSendTo = True
End If
End Forall
If someoneToSendTo = False Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
End If
Dim iMailDoc As New NotesDocument(db)
iMailDoc.From = strFrom ' Set who it comes from
iMailDoc.SendFrom = strFrom ' Set who it comes from
iMailDoc.Principal = strFrom ' Set the Username Sender (from)
iMaildoc.Subject = strSubject
'===================================================
' Set the body of the email
Dim rtBody As New NotesRichTextItem( iMailDoc, "Body" ) ' for attachment
Call rtBody.AppendText( "Dear " & ArrayToString(vTo, " and ") & ",")
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "This mail has been created via an automatic process." )
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtBody.AppendRtitem( newRTItem )
End If
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "Regards, The Agent")
' Call rtBody.AddNewLine(1)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
'=========================================================
' Add a link to this database so that users can find where this email came from
Call rtBody.AppendText( "DB Title: " & db.Title & Chr(13) )
Call rtBody.AppendText( "DB Path: " & db.FilePath & Chr(13) )
Call rtBody.AppendText( "DB Server: " & db.Server & Chr(13) )
Call rtBody.AppendText( "Doclink: " )
Call rtBody.AppendDocLink( db, db.Title )
'==========================================================
' Send the mail
' try to catch the error no match found in name and address book.
On Error 4294 Goto ShowMoreInformationAboutSendTo ' no match found in name and address book.
On Error 4295 Goto ShowMoreInformationAboutSendTo ' 4295 is Multiple matches found in name and address book.
Call iMaildoc.Send( False, vTo )
Exit Sub
ShowMoreInformationAboutSendTo:
Print Err & " " & Error
If Datatype( vTo ) = 8 Then '8 String V_STRING
Print "SendMail sub: Warning: Tried to send to " & vTo
Else
Print "SendMail sub: Warning: Tried to send to " & ArrayToString(vTo, ", ")
End If
Resume ContinueNow
ContinueNow:
End Sub
Sub SendMailWithDocLink( strFrom As String, vTo As Variant, strSubject As String, Body As Variant, docToLinkTo As NotesDocument )
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim docMail As NotesDocument
Set docMail = New NotesDocument( db )
Dim rtiBody As NotesRichTextItem
Set rtiBody = New NotesRichTextItem ( docMail , "Body" )
' body could be a string
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtiBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtiBody.AppendRtitem( newRTItem )
End If
Call rtiBody.AddNewLine( 1 )
Call rtiBody.AppendDocLink( docToLinkTo, "" )
Call SendMail( strFrom, vTo, strSubject, rtiBody)
End Sub
Function CheckMandatoryFields( strFieldNamesArr As Variant, _
strFieldLabelsArr As Variant, uidocToCheck As NotesUIDocument ) As Boolean
' prompts for the user to fill in
' gives an error message with all mandatory fields
Dim docToCheck As NotesDocument
Set docToCheck = uidocToCheck.Document
Dim blAllFilledIn As Boolean
blAllFilledIn = True ' default to true
' Simple check at first
If Ubound( strFieldNamesArr ) <> Ubound(strFieldLabelsArr) Then
Print "something fishy going on ... field name list ( " & _
Cstr( Ubound( strFieldNamesArr ) ) & " ) and field labels ( " & _
Cstr( Ubound( strFieldLabelsArr ) ) & " ) list do not match in size"
End If
Dim intFieldIndex As Integer
Dim intNumberOfFields As Integer
intNumberOfFields = Ubound(strFieldNamesArr) + 1
'==========================================================
' Check if the fields exist and are filled in
'==========================================================
Dim strFailedField As String, strFailedLabel As String, strFieldName As String
Dim blThisOneFailed As Boolean
blThisOneFailed = False
Do While (intFieldIndex < intNumberOfFields) And (blAllFilledIn = True)
strFieldName = strFieldNamesArr(intFieldIndex)
If Not docToCheck.HasItem(strFieldName) Then
blThisOneFailed = True
Else
If Cstr(docTocheck.GetItemValue( strFieldName )(0)) = "" Then
blThisOneFailed = True
End If
End If
If blThisOneFailed = True Then
blAllFilledIn = False ' will cause it to exit the loop
strFailedField = strFieldName
strFailedLabel = strFieldLabelsArr( intFieldIndex)
End If
intFieldIndex = intFieldIndex + 1
Loop
' Show an error message of all fields
If blAllFilledIn = False Then
' go to the failed field
Call uidocToCheck.GotoField(strFailedField)
Msgbox "Please fill in the mandatory field for " & strFailedLabel & _
". The mandatory fields are: " & ArrayToString( strFieldLabelsArr, ", " )
End If
CheckMandatoryFields = blAllFilledIn
End Function
Sub CleanOutACL( aclFromDb As NotesACL )
Dim aclEntry As NotesACLEntry, aclEntryNext As NotesACLEntry
Set aclEntry = aclFromDb.GetFirstEntry()
Do While Not aclFromDb Is Nothing
Set aclEntryNext = aclFromDb.GetNextEntry(aclEntry)
If Not aclEntry.Name = "-Default-" Then ' cant remove default entry
Call aclEntry.Remove()
End If
Set aclEntry = aclEntryNext
Loop
' The acle must have at least one manager, so make sure default is manager if you are going to save here
'Set aclEntry = aclFromDb.GetEntry("-Default-")
'aclEntry.Level = 6 ' manager
' Call aclFromDb.Save()
End Sub
Function GenerateUniqueFilename( strFilename As String ) As String
' eg give the filename "\\anthonyspc\cat.txt"
' if a file already exists at that location, then returns something like
' returns "say \\anthonyspc\cat1.txt" or "\\anthonyspc\cat2.txt"
Dim intAppendix As Integer
intAppendix = 1
If strFilename = "" Then
Error 1000, "GenerateUniqueFilename - I was expecting a file to check if it exists. but nothing was passed in"
End If
Dim blFileExists As Boolean
blFileExists = FileExists( strFileName )
Dim strFilenameMinusExt As String
Dim strFilenameMinusExtMinusAppendix As String
Dim strExtension As String ' eg txt, "csv"
strExtension = Strrightback(strFileName, "." )
Dim strPrevAppendix As String
strPrevAppendix = ""
Do While blFileExists = True
' a db already exists with that filename, try another
'replace the last char with a number
' eg for cat.nsf, make it ca1.nsf, ca2.nsf
strFilenameMinusExt = Replace(strFilename, "." & strExtension, "")
strFilenameMinusExtMinusAppendix = Left(strFilenameMinusExt, (Len(strFilenameMinusExt)-Len(strPrevAppendix)))
strFilename = strFilenameMinusExtMinusAppendix & Cstr( intAppendix ) & "." & strExtension
strPrevAppendix = Cstr(intAppendix)
intAppendix = intAppendix + 1
blFileExists = FileExists( strFileName )
If intAppendix > 1000 Then
Error 1000, "GenerateUniqueFilename has not been coded to deal with more than 1000 dbs with a the same name."
End If
Loop
GenerateUniqueFilename = strFilename
End Function ' GenerateUniqueFilename
Function MakeSafeForFileName(strFileName As String) As String
Dim strSafeFileName As String
strSafeFileName = strFileName
strSafeFileName = Replace(strSafeFileName, " ", "")
strSafeFileName = Replace(strSafeFileName, ":", "")
strSafeFileName = Replace(strSafeFileName, "*", "")
strSafeFileName = Replace(strSafeFileName, "?", "")
strSafeFileName = Replace(strSafeFileName, {"}, {})
strSafeFileName = Replace(strSafeFileName, "<", "")
strSafeFileName = Replace(strSafeFileName, ">", "")
strSafeFileName = Replace(strSafeFileName, "|", "")
strSafeFileName = Replace(strSafeFileName, "/", "")
strSafeFileName = Replace(strSafeFileName, "\", "")
MakeSafeForFileName = strSafeFileName
End Function
Function MakeSafeForFilePath(strFilePath As String) As String
Dim strSafeFilePath As String
strSafeFilePath = strFilePath
strSafeFilePath = Replace(strSafeFilePath, " ", "")
strSafeFilePath = Replace(strSafeFilePath, ":", "")
strSafeFilePath = Replace(strSafeFilePath, "*", "")
strSafeFilePath = Replace(strSafeFilePath, "?", "")
strSafeFilePath = Replace(strSafeFilePath, {"}, {})
strSafeFilePath = Replace(strSafeFilePath, "<", "")
strSafeFilePath = Replace(strSafeFilePath, ">", "")
strSafeFilePath = Replace(strSafeFilePath, "|", "")
MakeSafeForFilePath = strSafeFilePath
End Function
Function IsArrayEmpty( strAnArr As Variant ) As Boolean
Dim blIsArrayEmpty As Boolean
On Error Goto errH
Dim intUbound As Integer
blIsArrayEmpty = False ' default to false, ie it is not empty
If Isarray( strAnArr ) Then
intUbound = Ubound( strAnArr ) ' raises error 200 if not initialized
End If ' isarray
Goto theEnd
errH:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
blIsArrayEmpty = True
Else
Error 1000, "Unexpected error n°" + Cstr(Err) + " while testing array in IsArrayEmpty function"
End If
Resume theEnd
theEnd:
IsArrayEmpty = blIsArrayEmpty
End Function
Function GetIntegerFromRightOfString( strSource As String ) As Integer
Dim strNumberFromRight As String
Dim strRightChar As String
strRightChar = Right( strSource, 1)
While Isnumeric( strRightChar )
strSource = Left(strSource, Len( strSource)-1 )
strNumberFromRight = strRightChar + strNumberFromRight
strRightChar = Right( strSource, 1)
Wend
GetIntegerFromRightOfString = Cint( strNumberFromRight )
End Function
Function ProperCasePlus(strString As String) As String
Dim ReturnVal As Variant
Dim LowerCase As String
LowerCase = Lcase(strString)
ReturnVal = Evaluate("@ProperCase(" + Chr(34) + LowerCase + Chr(34) + ")")
' change so that a name with a ' in it has the next initial uppercase
' do Tony O'neil become Tony O'Neil
If Instr( ReturnVal(0), "'" ) > 0 Then
Dim strLeftBit As String
Dim strRightVal As Variant
Dim strRightBit As String
strLeftBit = Strleft(ReturnVal(0), "'")
strRightVal = Evaluate("@ProperCase(" + Chr(34) + Strright(ReturnVal(0),"'") + Chr(34) + ")")
strRightBit = strRightVal(0)
ReturnVal(0) = strLeftBit + "'" + strRightBit
End If
ProperCasePlus= ReturnVal(0)
End Function
Function GetTextAtPositionForCSV( strBigString, intPosToFind As Integer, strDelimeter As String ) As String
' Finds text at a certain position given the delimeter
' atk modified for Csv files.. ie checks for ,"
' that is comma double quote or double quote at the start
'atk modified 12/04/2005. Added + lenstrDelim-1
If strBigString = "" Then
GetTextAtPositionForCSV = ""
Exit Function
End If
Dim RightSide As String
Dim pos As Integer
Dim lastPos As Integer
Dim count As Integer
Dim NumberOfRightMostChars As Integer
'==========================================================
' Setup an array of any double quotes as these will affect our count of commas
' they will exist becuase a comma is inside them
'==========================================================
Dim strStartQuotes As String, strEndQuotes As String
Dim strStartQuotesArr As Variant, strEndQuotesArr As Variant
Dim posDoubleQuote As Integer
posDoubleQuote = 0
posDoubleQuote = Instr(1, strBigString, {"}) ' instr starts at 1, not 0
Do While posDoubleQuote > 0
' The start quote
strStartQuotes = strStartQuotes + Cstr(posDoubleQuote)+ ","
' The end quote
posDoubleQuote = Instr(posDoubleQuote+1, strBigString, {"})
If posDoubleQuote > 0 Then
strEndQuotes = strEndQuotes + Cstr(posDoubleQuote)+ ","
End If
posDoubleQuote = Instr(posDoubleQuote+1, strBigString, {"})
Loop
' remove the last comma
strStartQuotes = RemoveLastNChars(strStartQuotes, 1)
strEndQuotes = RemoveLastNChars(strEndQuotes, 1)
' put into an array
If strStartQuotes <> "" Then
strStartQuotesArr = Split( strStartQuotes, ",")
strEndQuotesArr = Split( strEndQuotes, ",")
End If
'==============================================================
' loop through the text again, this time looking for the commas
'==============================================================
lastPos = 0
pos = 1
Dim idxQuote As Integer ' the quote index
Dim blIgnoreThisComma As Boolean
blIgnoreThisComma = False
Dim v1 As Variant, v2 As Variant
'========================================================
' Get the first valid delimeter
'========================================================
pos = Instr ( pos, strBigString , strDelimeter )
' check if we have a valid one, or invalid, that is if it is in a quoted string
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Do While blIgnoreThisComma = True And pos > 0
blIgnoreThisComma = False
pos = Instr ( pos+1, strBigString , strDelimeter )
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Loop
' Get the start pos. Store in variable lastpos
' get the end pos . Store in variable po
Do While pos > 0 And count < intPosToFind-1
lastPos = pos
pos = Instr ( pos + 1, strBigString , strDelimeter )
' check if we are in a quoted section
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
If blIgnoreThisComma = True Then
Do While blIgnoreThisComma = True And pos > 0
blIgnoreThisComma = False
pos = Instr ( pos + 1, strBigString , strDelimeter )
' check if we are in a quoted section
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Loop
End If
If pos > 0 Then
' valid, so update count
count = count + 1
End If
Loop
' If we found at least one of the substring then
' lastPos will be the start of the text we want,
' and pos will be the end
If lastPos > 0 Then
NumberOfRightMostChars = Len( strBigString ) - ( lastPos + Len(strDelimeter)-1 ) ' atk modified12/04/2005. Added + lenstrDelim-1
RightSide = Right( strBigString, NumberOfRightMostChars )
If pos > 0 Then
GetTextAtPositionForCSV = Left( RightSide, pos-lastPos-1 )
Else
GetTextAtPositionForCSV = RightSide
End If
Elseif lastPos = 0 And pos > 0 Then
' Must have been the first item in the string
GetTextAtPositionForCSV = Left( strBigString, pos -1 )
Elseif lastPos = 0 And pos = 0 And (intPosToFind = 0 Or intPosToFind = 1) Then
' must be the first item in the string, and no delimeters
GetTextAtPositionForCSV = strBigString
Else
GetTextAtPositionForCSV = ""
End If
' And remove any double quotes
GetTextAtPositionForCSV = Replace(GetTextAtPositionForCSV, {"}, "")
End Function
Function PerformDbLookupLS( view As NotesView, sKey As String , vFind As Variant ) As Variant
'==================================
' PerformDbLookupLS function
'==================================
On Error Goto MailError
' There is a perform db lookup function that uses @functions
' that has a limit of 64k... This one uses ls
Redim strReturnValuesArr( 0 ) As Variant
' keep the view order, use view entry collection
Dim vec As NotesViewEntryCollection
Set vec = view.GetAllEntriesByKey( sKey, True )
Dim ve As NotesViewEntry
If vec.Count <> 0 Then ' as Long as we have results...
Set ve = vec.GetFirstEntry()
Redim strReturnValuesArr( 0 To vec.Count-1 ) As Variant
Dim i As Integer
i = -1
If Typename( vFind ) = "STRING" Then
Do While Not ve Is Nothing
i = i + 1
strReturnValuesArr(i) = Join(ve.Document.GetItemValue(vFind),";")
Set ve = vec.GetNextEntry(ve)
Loop
Else
' we want a view column number. hmmmm
Do While Not ve Is Nothing
i = i + 1
strReturnValuesArr(i) =ve.ColumnValues(vFind-1) ' -1 as cols are 0 based
Set ve = vec.GetNextEntry(ve)
Loop
End If ' typename is string
End If ' vec = 0
PerformDbLookupLS = strReturnValuesArr
ExitPoint:
Exit Function
MailError:
' debug, send email
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim docMemo As New NotesDocument(db)
' debug, send email
docMemo.subject = "Error in PerformDbLookupLS function"
docMemo.body = "An error was incurred by " + session.EffectiveUserName + " using the db " + _
session.CurrentDatabase.Title + " in the agent " + session.CurrentAgent.Name + Chr(13) + Chr(13) + _
" Error" & Str(Err) & " Line " & Str(Erl) & " : " & Error$ + Chr(13) + Chr(13) + _
Chr(10) + "Current function=" + Lsi_info(2) + _ ' The current function or sub
Chr(10) + "Current module=" + Lsi_info(3) + _ ' The current module
Chr(10) + "LS Version=" + Lsi_info(6) + _ ' The version of LotusScript running
Chr(10) + "Current Langugage=" + Lsi_info(9) +_ ' Current language (en for english)
Chr(10) + "Caller function=" + Lsi_info(12) ' The name of the function that called this one, "the caller"
Call docMemo.Send(False, "Domino Admin")
' end debug
Resume ExitPoint
End Function ' PerformDbLookupLS
Function getFieldString(doc As NotesDocument, fieldName As String) As String
getFieldString = ""
If doc Is Nothing Then Exit Function
If Not doc.HasItem(fieldName) Then Exit Function
getFieldString = Cstr(doc.GetFirstItem(fieldName).values(0))
End Function
Function StripHTML (strSource As String, bool_StripOrphans As Boolean) As String
%REM
This function will strip HTML tags from a passed in string,
and return the resulting string.
Orphan Tags ("<" & ">") will be handled based on the value of bool_StripOrphans.
The Orphan Tags will be removed if bool_StripOrphans is True,
and will be ignored otherwise.
%END REM
Dim intPosOpen As Integer
Dim intPosClose As Integer
Dim strTarget As String
strTarget$ = strSource
If bool_StripOrphans Then
' Strip out Orphan Tags
Do
intPosOpen% = Instr(strTarget$, "<")
intPosClose% = Instr(strTarget$, ">")
If intPosOpen% < intPosClose% Then
' Either the first open indicator occurs prior to the first close indicator,
' or doesn't exist at all.
If intPosOpen% = 0 Then
' The first open indicator doesn't exist.
' If the Orphan close indicator exists, then strip it out.
If (intPosClose% > 0) Then strTarget$ = StripFirstSubstr(strTarget$, ">")
Else
' The first open indicator exists, and occurs prior to the first close indicator.
' THIS INDICATES STANDARD MARKUP. STRIP IT OUT
strTarget$ = StripFirstSubstr(strTarget$, Mid$(strTarget$, intPosOpen%, (intPosClose% - intPosOpen%) + 1))
End If ' intPosOpen% = 0
Else
' Either the first close indicator occurs prior to the first open indicator,
' or doesn't exist at all.
If intPosClose% = 0 Then
' The first close indicator doesn't exist.
' If the Orphan open indicator exists, then strip it out.
If (intPosOpen% > 0) Then strTarget$ = StripFirstSubstr(strTarget$, "<")
Else
' The first close indicator occurs prior to the first open indicator,
' and is therefore an Orphan. Strip it out.
strTarget$ = StripFirstSubstr(strTarget$, ">")
End If 'intPosClose% = 0
End If ' intPosOpen% < intPosClose%
Loop While ((intPosOpen% + intPosClose%) > 0)
Else
' Orphan tags are to be ignored.
Do
intPosOpen% = Instr(strTarget$, "<")
If intPosOpen% > 0 Then
' An open indicator exists. Find the subsequent close indicator
intPosClose% = Instr(intPosOpen, strTarget$, ">")
Else
' No open indicator exists. Set the close position to zero and bail out.
intPosClose% = 0
End If ' intPosOpen% > 0
If intPosClose% > intPosOpen% Then
' The first open indicator exists, and occurs prior to the first close indicator.
' THIS INDICATES STANDARD MARKUP. STRIP IT OUT
strTarget$ = StripFirstSubstr(strTarget$, Mid$(strTarget$, intPosOpen%, (intPosClose% - intPosOpen%) + 1))
Else
' No close indicator exists. Set the open position to zero and bail out.
intPosOpen% = 0
End If ' intPosClose% > intPosOpen%
Loop While ((intPosOpen% + intPosClose%) > 0)
End If ' bool_StripOrphans
StripHTML$ = strTarget$
End Function ' StripHTML
Function StripFirstSubstr (strSource As String, strSubstr As String) As String
%REM
This function strips the first occurence of a substring from a string,
and returns the result.
If the substring is not contained within the source string,
this function returns the source string.
%END REM
If (Instr(strSource$, strSubstr$) > 0) Then
StripFirstSubstr$ = Strleft(strSource$, strSubstr$) & Strright(strSource$, strSubstr$)
Else
StripFirstSubstr$ = strSource$
End If ' (Instr(strSource$, strSubstr$) > 0)
End Function ' StripFirstSubstr
Sub CopyACLToDB( dbSource As NotesDatabase, dbTarget As NotesDatabase)
%REM
eg
Sub Initialize
Dim session As New NotesSession
Dim old_db As NotesDatabase
'Open the database to which you want to copy the acl
Dim new_db As New NotesDatabase("Onward", "Finance/Invoice98.nsf")
Set old_db = session.CurrentDatabase
Call CopyACLToDB(old_db, new_db)
End Sub
%END REM
Dim acl As NotesACL
Dim newacl As NotesACL
Dim aclentry As NotesACLEntry
Dim tmpentry As NotesACLEntry
Dim entry As NotesACLEntry
'Get the ACL's of each database into NotesACL objects
Set acl = dbSource.ACL
Set newacl = dbTarget.ACL
'Loop through the ACL entries of the source database
Set aclentry = acl.GetFirstEntry
While Not (aclentry Is Nothing)
Set tmpentry = newacl.GetEntry(aclentry.Name)
If Not (tmpentry Is Nothing) Then
'This name already exists in ACL, so just set level
tmpentry.Level = aclentry.Level
Else
'Since name does not exist in ACL create a new entry
Set entry = newacl.CreateACLEntry(aclentry.Name, aclentry.Level)
End If
Set aclentry = acl.GetNextEntry(aclentry)
Wend
'Save the ACL in the target database
Call newacl.Save
End Sub
Name: Functions.ATK.Quickplace
Last Modification: 25/10/2007 12:16:08
LotusScript Code:
Option Public
Option Declare
Dim gblDebug As Boolean
Sub Initialize
Dim gblDebug As Boolean
End Sub
Function GetQPRoomName( dbQuickplace As NotesDatabase ) As String
GetQPRoomName = GetQPRoomSetting( "h_Name", dbQuickplace )
End Function
Function GetQPParentDbFilePath( dbQuickplace As NotesDatabase ) As String
Dim strParentFileName As String
strParentFileName = GetQPRoomSetting( "h_AreaParent", dbQuickplace )
Dim strParentFileNameAndPath As String
If strParentFileName <> "" Then
strParentFileNameAndPath = Strleftback(dbQuickplace.FilePath,"\") & "\" & strParentFileName
End If
GetQPParentDbFilePath = strParentFileNameAndPath
End Function
Function GetPathAndFileNameForReport( dbQuickplace As NotesDatabase ) As String
' return a filepath in which to save the room.
' return main.nsf Filename + this rooms parent rooms filename + this room name
' eg statewest2\atkroom\atkinnerroom\report.csv
' updated this to return statewest2-atkroom-atkinnerroom.csv
If gblDebug Then Call sDebug("GetPathAndFileNameForReport")
Dim dbParent As NotesDatabase
Set dbParent = GetParentDbFromRoomDb( dbQuickplace ) ' eg if this is not the parent
Dim strFilePathForReport As String
strFilePathForReport = ""
'======================================================================
' Get the parent db(s) to create the filepath/filename
'======================================================================
Do While Not dbParent Is Nothing
If gblDebug Then Call sDebug("End GetMore Parent dbs")
strFilePathForReport = GetQPRoomName( dbParent ) & "\" & strFilePathForReport
Set dbParent = GetParentDbFromRoomDb( dbParent )
Loop
' then append this room name
strFilePathForReport = strFilePathForReport & GetQPRoomName( dbQuickPlace ) & "\"
'======================================================================
' Rather than putting this in folders lets put in in a filename
'======================================================================
If gblDebug Then Call sDebug("Clean up filename")
' remove the last slash "\"
strFilePathForReport = RemoveLastNChars(strFilePathForReport, 1)
strFilePathForReport = Replace(strFilepathForReport, "\" , "-" )
strFilePathForReport = strFilepathForReport & Date()
strFilePathForReport = Replace(strFilepathForReport, "\" , "" )
strFilePathForReport = Replace(strFilepathForReport, "/" , "" )
strFilePathForReport = Replace(strFilepathForReport, " " , "" )
strFilePathForReport = Replace(strFilepathForReport, ":" , "" )
strFilePathForReport = strFilePathForReport & ".csv"
'======================================================================
' remove spaces and other undesirables from the directory name
'======================================================================
strFilePathForReport = Replace(strFilePathForReport, " ", "" )
If gblDebug Then Call sDebug("End GetPathAndFileNameForReport")
GetPathAndFileNameForReport = strFilePathForReport
End Function
Function GetParentDbFromRoomDb( dbQuickplace As NotesDatabase ) As NotesDatabase
Dim strParentDbFilePath As String
strParentDbFilePath = GetQPParentDbFilePath ( dbQuickplace )
Dim dbParent As NotesDatabase
If strParentDbFilePath = "" Then
Set dbParent = Nothing
Else
Dim session As New NotesSession()
Set dbParent = session.GetDatabase(dbQuickplace.Server, strParentDbFilePath )
If dbParent Is Nothing Then
Print "Could not get parent db (is nothing) at " & dbQuickplace.Server & " - " & strParentDbFilePath
Elseif dbParent.IsOpen = False Then
Print "Could not get parent db (is not open) at " & dbQuickplace.Server & " - " & strParentDbFilePath
End If
End If
Set GetParentDbFromRoomDb = dbParent
End Function
Function GetQPSettingsView( dbQuickplace As NotesDatabase ) As NotesView
Dim vwSystem As NotesView
Set vwSystem = dbQuickplace.GetView( "h_Settings" )
If vwSystem Is Nothing Then
Error 1000, "When trying to get the settings view I failed!!!"
End If
Set GetQPSettingsView = vwSystem
End Function
Function GetQPRoomSettingsDoc ( dbQuickplace As NotesDatabase ) As notesDocument
Dim vwSystem As NotesView
Set vwSystem = GetQPSettingsView( dbQuickplace )
Dim docRoomSettings As NotesDocument
Set docRoomSettings = vwSystem.GetDocumentByKey("h_RoomSettings")
Set GetQPRoomSettingsDoc = docRoomSettings
End Function
Function GetQPRoomSetting( strSettingFieldName As String, dbQuickplace As NotesDatabase ) As String
' get the view that has all the elements
' only returns single value items at this stage
Dim docRoomSettings As NotesDocument
Set docRoomSettings = GetQPRoomSettingsDoc ( dbQuickplace )
Dim strSettingValue As String
If docRoomSettings.HasItem( strSettingFieldName ) Then
strSettingValue = docRoomSettings.GetItemValue( strSettingFieldName )(0)
End If
GetQPRoomSetting = strSettingValue
End Function
Function RemoveLastNChars(iString, iNumberOfChars ) As String
RemoveLastNChars = Left( iString, Len(iString) - iNumberOfChars)
End Function
Function GetQPAllTasksView( dbQuickplace As NotesDatabase ) As NotesView
Dim vwAllTasks As NotesView
Set vwAllTasks = dbQuickplace.GetView("h_TaskList")
Set GetQPAllTasksView = vwAllTasks
End Function
Sub AddToArray( iArray As Variant, newValue As String )
On Error Goto ErrorAddToArray
If Isempty(iArray) Then ' if array was declared as a variant
Redim iArray(0) As String
End If
If ( Ubound(iArray) = Lbound(iArray) ) And iArray(Ubound(iArray)) = "" Then ' will raise err 200 if uninit
' if we are a new array with nothing in it then do not increase size
iArray(Lbound(iArray)) = newValue
Else
Dim newSize As Integer
newSize = Ubound(iArray)+1
ContinueFromErr:
Redim Preserve iArray(newSize)
iArray(newSize) = newValue
'AddToArray = iArray
End If
Exit Sub
ErrorAddToArray:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
newSize = 0
Resume ContinueFromErr
Else
Error Err, Error
End If
End Sub ' add to array
Function ArrayToString( iArray As Variant, newSeparator As String ) As String
' iArray is the array to convert
' newSeparator is the new separator eg ","
' Take in an array of strings, or an array of integers and return a string
If Datatype(iArray) = 8 Then
ArrayToString = iArray
Exit Function
End If
If Datatype(iArray(Lbound(iArray))) = 8 Then '8 String V_STRING
Forall iBit In iArray
ArrayToString = ArrayToString & iBit & newSeparator
End Forall
Else
Forall iBit In iArray
ArrayToString = ArrayToString & Cstr(iBit) & newSeparator
End Forall
End If '--If Datatype(iArray(0)) = 8 Then
' Remove the last added bit
ArrayToString = RemoveLastNChars(ArrayToString, Len(newSeparator))
End Function
Sub ExportQPTasksToCSVWithStartOfFile( dbQuickplace As NOtesDatabase, strFieldAndLabelList As Variant, _
strStartOfPath As String )
'====================================================================
' Work out which db we are in and create the filepath and filename
'====================================================================
If gblDebug Then Call sDebug("ExportQPTasksToCSVWithStartOfFile")
Dim strFilePathForThisReport As String 'eg \\place\room\room2
strFilePathForThisReport = strStartOfPath & GetPathAndFileNameForReport( dbQuickplace )
If gblDebug Then Call sDebug("GenerateUniqueFilename")
strFilePathForThisReport = GenerateUniqueFilename( strFilePathForThisReport )
Call ExportQPTasksToCSV( dbQuickplace, strFieldAndLabelList, strFilePathForThisReport )
End Sub
Function SetupFieldAndLabelList() As Variant
Dim strFieldAndLabelList List As String
' strFieldAndLabelList("label") = fieldnameon task doc
' strFieldAndLabelList("Group") = strRoomName ' the name of the room this is printed out manually
strFieldAndLabelList("ID") = "Task_Id" ' a unique id
strFieldAndLabelList("Task") = "h_Name"
strFieldAndLabelList("Assigned") = "h_TaskAssignedToDisplayName"
strFieldAndLabelList("Start") = "h_TaskStartDate"
strFieldAndLabelList("Due") = "h_TaskDueDate"
strFieldAndLabelList("Revised") = "h_TaskRevisedDueDate"
strFieldAndLabelList("Priority") = "h_TaskCategory"
strFieldAndLabelList("Status") = "h_TaskStatus"
strFieldAndLabelList("Milestone") = "h_isMilestone"
SetupFieldAndLabelList = strFieldAndLabelList
End Function
Sub ExportQPTasksToCSV( dbQuickplace As NotesDatabase, strFieldAndLabelList As Variant, strCSVFileName As String )
If gblDebug Then Call sDebug("Start ExportQPTasksToCSV")
Dim strDelim As String
strDelim = "," ' could be tab, Chr(9)
Dim strRoomName As String
strRoomName = GetQPRoomName( dbQuickplace )
'====================================================================
' Get all of the tasks to export
'====================================================================
If gblDebug Then Call sDebug("vwAllTasks")
Dim vwAllTasks As NotesView
Set vwAllTasks = GetQPAllTasksView( dbQuickplace )
'====================================================================
' Open the file for export - it will be unique, ie unused from code before
'====================================================================
If gblDebug Then Call sDebug("open file for export")
Dim intQuickplaceExportFileNum As Integer
intQuickplaceExportFileNum = Freefile()
Open strCSVFileName For Output As intQuickplaceExportFileNum
'====================================================================
' Print out the file names as the first line of the export
'====================================================================
If gblDebug Then Call sDebug("print out filenames")
Dim strTitleLine As String
strTitleLine = "Group" & strDelim 'add the group manually
Forall strFieldName In strFieldAndLabelList
strTitleLine = strTitleLine & Listtag(strFieldName) & strDelim
End Forall
' remove the last delim
strTitleLine = RemoveLastNChars( strTitleLine, Len( strDelim ) )
Print # intQuickplaceExportFileNum, strTitleLine
'====================================================================
' Loop through the tasks and create a line in the csv file
'====================================================================
If gblDebug Then Call sDebug("loop through all tasks")
Dim intProcessed As Integer
Dim strLineToExport As String
Dim docTask As NotesDocument
Set docTask = vwAllTasks.GetFirstDocument()
Do While Not docTask Is Nothing
strLineToExport = ""
' add the room name
strLineToExport = strLineToExport & {"} & strRoomName & {"} & strDelim
Forall strFieldName In strFieldAndLabelList
' if we use the comma delimeter, we have to be careful of commas in the fields.
' fix this by using quotes around the values
strLineToExport = strLineToExport & {"} & docTask.GetItemValue(strFieldName)(0) & {"} & strDelim
End Forall ' strFieldNames
' remove the last delim
strLineToExport = RemoveLastNChars( strLineToExport, Len( strDelim ) )
'Print to the csv file
Print # intQuickplaceExportFileNum, strLineToExport
intProcessed = intProcessed + 1
Print "Exporting " & strCSVFileName & " - " & intProcessed
Set docTask = vwAllTasks.GetNextDocument( docTask )
Loop
Print "Completed export on " & strCSVFileName & " - " & intProcessed & " lines"
Msgbox "Completed export on " & strCSVFileName & " - " & intProcessed & " lines"
'====================================================================
' Close the file for export
'====================================================================
If gblDebug Then Call sDebug("close the file")
Close intQuickplaceExportFileNum
If gblDebug Then Call sDebug("End ExportQPTasksToCSV")
End Sub
Sub sDebug(x)
REM Declare variables for Debug subroutine
Dim fileNum As Integer
Dim fileName As String
fileNum% = Freefile()
fileName$ = "data.txt"
REM Print debug message to data.txt
Dim session As New NotesSession
Dim db As notesdatabase
Set db = session.CurrentDatabase
Open fileName$ For Append As fileNum%
Write #fileNum%, Cstr(Now()) & " Quickplace debugging from " & db.Title & ":" & x
Close fileNum%
End Sub
Function GenerateUniqueFilename( strFilename As String ) As String
' eg give the filename "\\anthonyspc\cat.txt"
' if a file already exists at that location, then returns something like
' returns "say \\anthonyspc\cat1.txt" or "\\anthonyspc\cat2.txt"
If gblDebug Then Call sDebug("start GenerateUniqueFilename")
Dim intAppendix As Integer
intAppendix = 1
If strFilename = "" Then
Error 1000, "GenerateUniqueFilename - I was expecting a file to check if it exists. but nothing was passed in"
End If
Dim blFileExists As Boolean
blFileExists = FileExists( strFileName )
Dim strFilenameMinusExt As String
Dim strFilenameMinusExtMinusOneChar
Dim strExtension As String ' eg txt, "csv"
strExtension = Strrightback(strFileName, "." )
If gblDebug Then Call sDebug("check if this file already exists")
Do While blFileExists = True
' a db already exists with that filename, try another
'replace the last char with a number
' eg for cat.nsf, make it ca1.nsf, ca2.nsf
strFilenameMinusExt = Replace(strFilename, strExtension, "")
strFilenameMinusExtMinusOneChar = Left(strFilenameMinusExt, Len(strFilenameMinusExt)-1)
strFilename = strFilenameMinusExtMinusOneChar & Cstr( intAppendix ) & "." & strExtension
intAppendix = intAppendix + 1
blFileExists = FileExists( strFileName )
If intAppendix > 1000 Then
Error 1000, "GenerateUniqueFilename has not been coded to deal with more than 1000 dbs with a the same name."
End If
Loop
If gblDebug Then Call sDebug("end GenerateUniqueFilename")
GenerateUniqueFilename = strFilename
End Function ' GenerateUniqueFilename
Function FileExists( strPathAndFile As String ) As Boolean
' Input: pathname is the filepath and filename eg "c:\temp\cat.txt"
' Return 1 if file exists, else return 0
If gblDebug Then Call sDebug("start FileExists (" & strPathAndFile & ")")
On Error Goto HandleFileExistsError
Dim blFileExists As Boolean
blFileExists = False
Dim fileName As String
If gblDebug Then Call sDebug("call dir")
fileName$ = Dir$(strPathAndFile$, 0) ' 0 for normal file, 16 for directory
If gblDebug Then Call sDebug("check what we got back...")
If fileName$ <> "" Then
blFileExists = True
Else
If gblDebug Then Call sDebug("check if we are on a server")
Dim session As New NotesSession()
If session.IsOnServer Then
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Print "fileExists: Warning - we are on a server you know - server name is [" & db.Server & "] is your file on the server?"
End If
' if session.CurrentAgent.
blFileExists = False
End If
NormalExit:
FileExists = blFileExists
Exit Function
HandleFileExistsError:
Dim strWarning As String
If Err = 76 Then '76 Path not found, eg if we pass in a path, not a file....
' guess the file doesn't exist, return false
blFileExists = False
Print "Warning file exists was code to check files.. are you checking a directory ? '" & strPathAndFile & "' )"
Resume NormalExit
Elseif Err = 5 Then'5 Illegal function call
strWarning = "Warning - when trying to check if the filename already exists, I could not access " &_
"the destination '" & strPathAndFile & "'. Check " &_
"if the machine this is running on can access that location."
Print strWarning
Error Err, Error & ":" & strWarning
Else
Error Err, " Error in sub FileExits - " & Error
End If
If gblDebug Then Call sDebug("end FileExists")
End Function
Name: Functions.TaskX.General
Last Modification: 25/10/2007 12:16:07
LotusScript Code:
Option Public
Option Declare
' Functions.TaskX.General
Dim strSafeFileName As String
' 03/08/2005 ATK GetIntegerFromRightOfString
' 13/05/2005 ATK MakeSafeFileName
' 10/05/2005 ATK Added CleanOutACL
' 29/04/2005 ATK Modified FileExists to not error out on directories
' ATK modfified AddToArray
' 12/04/2005 ATK Modified GetTextAtPosition for delimieters longer than 1 char "~~"
' 05/04/2005 ATK Modified ReplaceSubstring!!!!
' Added IncreaseCountField
' 03/02/2005 ATK Added GetNextAlphabetLetter
' ATK Added GetPrevAlphabetLetter
' ATK Added IsAlpha
' ATK Added TranslateIntToChar
' ATK Added Sub AddSectionToRTItem( doc As NotesDocument, strRTItemName As String, strTitle As String, strText As String )
' 25/01/2005 ATK Added GetGenericHTMLLinkToDoc
' 12/01/2005 ATK Added PrintOutFilesInDir
' 06/01/2004 ATK Modified Function GetTextAtPosition for first pos
' 06/12/2004 ATK Added Function OpenDirectoryDialog(blMultipleSelect, strTitle, _
' 26/11/2004 ATK Added GetAbbreviatedName( strNameInCanonical As String ) As String
' 19/11/2004 ATK Modified MailResults with Error handling!
' 15/11/2004 ATK Added fileExists( pathname As String )
' 25/10/2004 ATK Added DoesGroupExist
' ATK Added GetGroupDocument
' ATK Added ChooseAddressBook( strServer )
' 22/10/2004 ATK Added Sub GetAllGroupsInACL( strGroupsInACLArr As Variant )
' 22/10/2004 ATK Added Function GetAccessLevelAsString( ) As String
' 21/10/2004 ATK Added GenerateUniqueFilename
' 20/10/2004 ATK Updated RemoveNonAlphaNum to work
' 19/10/2004 ATK Added RemoveNonAlphaNum
' 18/10/2004 ATK Added QuickSort
' 14/10/2004 ATK Modified GetCommonName
' 8/10/2004 ATK Added IsAccessLevelAtLeast
' ATK Changed GoToURL to use location.replace
' 7/10/2004 ATK Added CleanUpOldDocs
' 27/09/2004 ATK Added IsAbbreviatedFormat
' Added IsCommonFormat
' 24/09/2004 ATK Modified EncodeURL( iString As String )
'
' 21/09/2004 ATK Updated MailResults make the link look nicer
' ATK Added new parameter to PoliceProcessError. Can be used for warnings etc.
' ATK Removed new parameter from PoliceProcessError.
' ATK Added new function PoliceProcessWarning
' 09/09/2004 ATK ConvertDateToYYYYMM
' ConvertDateToMMMYYYY
' GetMonthName
' Maybe I could split this script library into web and regular.
' 26/08/2004 ATK 2.6 Added option declare, and a good thing too as I
' discovered some spelling errors
' 26/08/2004 ATK 2.5 Added heaps of functions, to wit:
' Function SplitStringToChars( iString )
' Function CheckAlphaNum( iString, iException ) As Integer
' Function RemoveVowels(iString As String) As String
' Function DecodeURL( iString As String ) As String
' Function EncodeURL( iString As String ) As String
' Function GoToURL( iUrl As String) As String
' Function GetHTMLBackLinks(doc) As String
' GetMessageURL, GetMessageURLSmall, GetMessageURLMed, GetMessageURLLarge
' CleanUpOldMessageDocs
' GetRandomIntInRange
' Function GetCurrentDbInfo() As String
' Function GetArgFromQuery_String(iArgName, iQuery_String) As String
' Function HasRole( strRoleName As String, strFullUsername As String ) As Boolean
' Function GetAsHTMLComment( iString ) As String
' 25/08/2004 ATK 2.4 Added Function GetCurrentDbInfo() As String
' 20/08/2004 ATK 2.3 Removed PoliceMailError added PoliceProcessError
' 19/08/2004 ATK 2.2 Added Sub PoliceMailError( strApplication As String, strSection As String, strErrorNoAndString As String, contextDoc As NotesDocument)
' 19/08/2004 ATK 2.1 Added Function InsertText( rtItem As NotesRichTextItem, strTextToInsert As String ) As NotesRichTextItem
' 18/08/2004 AK 2.0 Added function Sub AddToArray( iArray As Variant, newValue As String )
' 10/08/2004 AK 1.9 Added function IsCanonicalFormat( strUsername as string ) as boolean
' 03/08/2004 AK 1.8 Added function PadStart( iString As String, iSize As Integer, iPadChar As St
' 02/08/2004 AK 1.7 Added function POLICEUpdateAuditCode
' 30/07/2004 AK 1.6 Added function GetCommonName( iLongName ) as STring
' 30/06/2004 AK 1.5 Added iGetViewOrDie, modified iGetView
' 18/06/2004 AK 1.4 Added Propercase function, Added PadOrCut function
' April 21 2004 version 1.3 AK
' updatate mailresults for outlook express chr(10) etc
' Mar 31 2004 version 1.2 AK
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As Str
' updated string to array
' updated igetdocumentcollection
'Function ProperCase(strString As String) As String
'Function ReplaceSubstring(src As String, search As String, replace As String) As String
'Function StringToArray(textstr As String, delimiter As String) As Variant
'Function BreakUpStringWithReturns( iString As String, iNumChars As Integer ) As String
'Function LeftByWord( iString As String, iNumChars As Integer )
'Function SearchForViewsNamed(db As NotesDatabase, partOfViewName As String) As Variant
'Function WhatKindOfArray( t As Variant ) As Integer
'Function GetCommonItemsInArrays(array1 As Variant, array2 As Variant) As Variant
'Function GetDatabasesWithTitle( iServerName As String, iTitle As String) As Variant
'Function GetDatabasesThatUseTemplate( iServerName As String, iNameOfTemplate As String) As Variant
'Function ConvertDate( DateString As String, FString As String)
'Function CountSubstrings( strBig As String, strLittle As String ) As Integer
'Function AreValuesInArray(FindArray, SearchArray)
'Function RemoveLastNChars(iString, iNumberOfChars ) As String
'Function ArrayToString( iArray As Variant, newSeparator As String ) As String
'Sub WriteToAFile(fileName As String, aMessage As String)
'Function GetFilePathFromFileNameAndPath( fileNameAndPath As String )
'Function GetTextAtPosition( bigString, posToFind As Integer, Delimeter As String ) As String
'Function LineCount( fileName As String ) As Integer
'Function GetMiddle( FullString, StartString As String, EndString As String) As String
'Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
'Function StringArrayIsEqual( array1() As String, array2() As String ) As Integer
'Function iGetView( db As NotesDatabase, ViewName As String ) As NotesView
'Function iGetDocumentCollection( db As NotesDatabase, SearchFormula As String ) As NotesDocumentCollection
Sub Initialize
End Sub
Function ReplaceSubstring( strSource As String, strSearch As String, strReplace As String) As String
'iSource = original string
'iSearch = what to iSearch for
'replace = replace string
' if we are replacing something like a single "\" with a double "\\" , then this never finishes...... need to fix that.
If (strSearch = strReplace) Then
ReplaceSubstring = strSource
Exit Function
End If
Dim intBegin As Integer
intBegin = 1
Dim intPos As Integer
intPos = Instr( intBegin, strSource, strSearch )
While intPos > 0
strSource = Left$( strSource, Instr( intBegin, strSource, strSearch) - 1) + strReplace + Right$( strSource, Len( strSource) - Instr( intBegin, strSource, strSearch ) - Len( strSearch) + 1 )
intBegin = Instr( intBegin + Len( strReplace ) + 1, strSource, strSearch )
If intBegin > 0 Then
intPos = Instr( intBegin, strSource, strSearch )
Else
intPos = 0
End If
Wend
ReplaceSubstring = strSource
End Function
Function StringToArray(textstr As String, delimiter As String) As Variant
' count is the counter for the number of array elements
Dim count As Integer
Dim ending As Integer
count = 0
'placeholder is used to mark the beginning of the string to be split
Dim placeholder As Integer
Dim splitstr As String
placeholder = 1
splitstr$ = delimiter
' txt$() is the array that will be returned
Dim txt$()
Redim txt$(0)
ending = Instr(placeholder, textstr, splitstr$)
'if ending = 0 then text does not contain a ; and the entire value should be returned
If ending = 0 Then
txt$(0) = textstr
End If
' do this until no more delimiters are found
While ending <> 0 And ending < Len(textstr)
Redim Preserve txt$(count)
txt$(count) = Mid$(textstr, placeholder, ending - placeholder )
count = count + 1
placeholder = ending + Len(splitstr$)
ending = Instr(placeholder, textstr, splitstr$)
If ending = 0 Then
Redim Preserve txt$(count)
txt$(count) = Mid$(textstr, placeholder, (Len(textstr)-placeholder) +1 )
End If
Wend
StringToArray = txt$
End Function
Function BreakUpStringWithReturns( iString As String, iNumChars As Integer ) As String
' returns the string broken up with return chars every iNumChars
Dim newString As String
Dim numberOfLoops As Long
Dim lineChunk As String
Do While Len(iString) > 0
' Get the string with full complete words up to the num chars
lineChunk = LeftByWord( iString, iNumChars ) & Chr(10) & Chr(13)
' Add the new chunk to the string we will return
newString = newString & lineChunk
' reduce the original string by the new chunk
If Len(iString) < Len(lineChunk) + 1 Then
iString = ""
Else
iString = Trim(Right( iString, Len(iString) - Len(lineChunk) + 1))
End If
numberOfLoops = numberOfLoops + 1
If numberOfLoops > 1000 Then
Print "The BreakUpStringWithReturns function cannot complete the task."
newString = newString & Chr(10) & Chr(13) & iString
Exit Do
End If
Loop
newString = RemoveLastNChars( newString, 2 )
BreakUpStringWithReturns = newString
End Function
Function LeftByWord( iString As String, iNumChars As Integer )
' eg LeftByWord("The man in the moon comes back", 13 )
' returns "The man in"
' so, get the left of the word up to iNumChars, eg "The man in th"
' then get the last space space at pos ..10
' then get the left of that "The man in"
Dim initialCut As String
Dim posOfLastSpace As Integer, oldPosOfLastSpace As Integer
Dim finalCut As String
If Len(iString) < iNumChars Then
finalCut = iString
Goto EndNow
End If
initialCut = Left( iString, iNumChars )
posOfLastSpace = Instr(initialCut, " ")
oldPosOfLastSpace = posOfLastSpace
Do While ( posOfLastSpace < Len(initialCut)) And posOfLastSpace > 0
oldPosOfLastSpace = posOfLastSpace
posOfLastSpace = Instr(posOfLastSpace + 1, initialCut, " " )
Loop
If oldPosOfLastSpace <> 0 Then
finalCut = Left( initialCut, oldPosOfLastSpace-1 )
Else
finalCut = initialCut
End If
EndNow:
LeftByWord = finalCut
End Function
Function SearchForViewsNamed(db As NotesDatabase, partOfViewName As String) As Variant
' returns an array of view names that contain
' the partOfViewName in the Title
Dim NUM_VIEWS_FOUND As Integer
NUM_VIEWS_FOUND = 0
partOfViewName = Lcase(partOfViewName)
Print "Searching for views with [" & partOfViewName & "] in the name"
Dim iNotesView As NotesView
Forall v In db.Views
Set iNotesView = v
If Instr( Lcase(iNotesView.Name), partOfViewName ) > 0 Then
Redim Preserve iViewArray(NUM_VIEWS_FOUND) As String
iViewArray(NUM_VIEWS_FOUND) = iNotesView.Name
NUM_VIEWS_FOUND = NUM_VIEWS_FOUND + 1
End If
End Forall
SearchForViewsNamed = iViewArray
End Function
Function WhatKindOfArray( t As Variant ) As Integer
%REM
This function takes a Variant as input variable and returns an integer :
-1 (minus one) if input is not an array
0 if it's an array, but not initialized yet
1 if it's a fully initialized array.
%END REM
' April 4th 2003
Dim res As Integer, n As Integer
res = False
On Error Goto errH
If Isarray( t ) Then
n = Ubound( t ) ' raises error 200 if not initialized
res = 1
Else
' not even an array
res = -1
End If
Goto theEnd
errH:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
res = 0
Else
res = -1
Print "Unexpected error n°" & Err " while testing array in whatKindOfArray function"
End If
Resume theEnd
theEnd:
whatKindOfArray = res
End Function
Function GetCommonItemsInArrays(array1 As Variant, array2 As Variant) As Variant
'return an array with the common elements
' eg from array1 = "Cat", "Dog", "Fish"
' eg array2 = "Cat", "Fish", "Canary"
' then return "Cat", "Fish"
Dim commonList() As Variant
Dim commonListSize As Integer
%REM
Dim iType As String
iType = Typename ( array1 )
If iType = "STRING( )" Then
Redim commonList As String
Elseif iType = "INTEGER( )" Then
Redim commonList As Integer
Else
Print "Unknown type of array."
End If
%END REM
Forall x In array1
Forall y In array2
If x = y Then
Redim Preserve commonList(commonListSize)
commonList(commonListSize) = x
commonListSize = commonListSize + 1
End If
End Forall
End Forall
If commonListSize > 0 Then
GetCommonItemsInArrays = commonList
End If
End Function
Function GetDatabasesWithTitle( iServerName As String, iTitle As String) As Variant
' returns an array of strings of database names and filenames
' where the title contains the string iTitle.
Dim dbdir As NotesDbDirectory
Dim xdb As NotesDatabase
Dim TEMPLATE_CANDIDATE As Integer
TEMPLATE_CANDIDATE = 1246 ' database or template
Dim listOfDbs() As String
Dim numberOfDbsFound As Integer
Dim totalCount As Integer
iTitle = Lcase(iTitle)
Set dbdir = New NotesDbDirectory( iServerName )
Set xdb = dbdir.GetFirstDatabase(TEMPLATE_CANDIDATE)
Do While Not xdb Is Nothing
totalCount = totalCount + 1
If totalCount Mod 10 = 0 Then
Print "Processed " & totalCount
End If
'===========================
If Instr(Lcase(xdb.Title), iTitle ) Then
Redim Preserve listOfDbs(numberOfDbsFound)
listOfDbs(numberOfDbsFound) = xdb.Title & "~" & xdb.FilePath
numberOfDbsFound = numberOfDbsFound + 1
End If
Set xdb = dbdir.GetNextDatabase()
Loop
If numberOfDbsFound > 0 Then
GetDatabasesWithTitle = listOfDbs
Erase listOfDbs
End If
End Function
Function GetDatabasesThatUseTemplate( iServerName As String, iNameOfTemplate As String) As Variant
Dim dbdir As NotesDbDirectory
Dim xdb As NotesDatabase
Dim TEMPLATE_CANDIDATE As Integer
TEMPLATE_CANDIDATE = 1246 ' database or template
Dim listOfDbs() As String
Dim numberOfDbsFound As Integer
Dim totalCount As Integer
Set dbdir = New NotesDbDirectory( iServerName )
Set xdb = dbdir.GetFirstDatabase(TEMPLATE_CANDIDATE)
Do While Not xdb Is Nothing
totalCount = totalCount + 1
If totalCount Mod 10 = 0 Then
Print "Processed " & totalCount
End If
'===========================
If xdb.DesignTemplateName = iNameOfTemplate Then
Redim Preserve listOfDbs(numberOfDbsFound)
listOfDbs(numberOfDbsFound) = xdb.Title & "~" & xdb.FilePath
numberOfDbsFound = numberOfDbsFound + 1
End If
Set xdb = dbdir.GetNextDatabase()
Loop
If numberOfDbsFound > 0 Then
GetDatabasesThatUseTemplate = listOfDbs
Erase listOfDbs
End If
End Function
Function ConvertDate( DateString As String, FString As String)
' convert a date sting into a date variant
'eg: DT = ConvertDate("2003-09-27 07:00:00", "YYYY-MM-DD")
Dim DD As String
Dim MM As String
Dim YY As String
Dim TT As String
Dim YPos As Integer
Dim YLen As Integer
Dim MPos As Integer
Dim MLen As Integer
Dim DPos As Integer
Dim DLen As Integer
Dim TPos As Integer
Dim DateOnly
' get the year postion
YPos = Instr(FString , "Y")
YLen = CountSubstrings( FString, "Y" )
YY = Mid(DateString , YPos , YLen )
' get the month
MPos = Instr(FString , "M")
MLen = CountSubstrings( FString, "M" )
MM = Mid(DateString , MPos , MLen )
' get the day
DPos = Instr(FString , "D")
DLen = CountSubstrings( FString, "D" )
DD = Mid(DateString , DPos , DLen )
' get the time
TPos = Instr(FString , " ")
TT = Mid(DateString , TPos , (Len(DateString) + 1) - TPos )
' put the date together and convert to a date
DateOnly = Datenumber ( Cint(YY) , Cint(MM) , Cint(DD) )
ConvertDate = Cdat(Cstr(DateOnly) & TT)
End Function
Function CountSubstrings( strBig As String, strLittle As String ) As Integer
' return the number of times that the smaller string appears in the bigger string
If strBig= "" Or strLittle = "" Then
CountSubstrings = 0
Exit Function
End If
Dim tempLine As String
Dim posLittle As Integer
Dim countLittle As Integer
tempLine = strBig
posLittle = Instr( tempLine, strLittle )
Do While posLittle > 0
countLittle = countLittle + 1
tempLine = Right( tempLine, Len( tempLine ) - posLittle )
posLittle = Instr( tempLine, strLittle )
Loop
CountSubstrings = countLittle
End Function
Function AreValuesInArray(FindArray, SearchArray)
' checks to see if values in a smaller array exist in a larger array
' returns true if all the values exist.
Dim FA As Integer
Dim SA As Integer
Dim foundFlag As Integer
For FA = 0 To Ubound(FindArray)
foundFlag = False
For SA = 0 To Ubound(SearchArray)
If Ucase(FindArray(FA)) = Ucase(SearchArray(SA)) Then
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
Exit For
End If
Next
AreValuesInArray = foundFlag
End Function
Function RemoveLastNChars(iString, iNumberOfChars ) As String
If Len(iString) = 0 Then
RemoveLastNChars =""
Else
RemoveLastNChars = Left( iString, Len(iString) - iNumberOfChars)
End If
End Function
Function ArrayToString( iArray As Variant, newSeparator As String ) As String
' iArray is the array to convert
' newSeparator is the new separator eg ","
' Take in an array of strings, or an array of integers and return a string
If Datatype(iArray) = 8 Then
ArrayToString = iArray
Exit Function
End If
If Isempty(iArray) Then
ArrayToString = ""
Exit Function
End If
If Isnull(iArray) Then
ArrayToString = ""
Exit Function
End If
If Datatype(iArray(Lbound(iArray))) = 8 Then '8 String V_STRING
Forall iBit In iArray
ArrayToString = ArrayToString & iBit & newSeparator
End Forall
Else
Forall iBit In iArray
ArrayToString = ArrayToString & Cstr(iBit) & newSeparator
End Forall
End If '--If Datatype(iArray(0)) = 8 Then
' Remove the last added bit
'Left( iString, Len(iString) - iNumberOfChars)
ArrayToString = Left(ArrayToString, Len(ArrayToString) - Len(newSeparator))
End Function
Sub WriteToAFile(fileName As String, aMessage As String)
Dim fileNum As Variant
Dim counter As Integer
fileNum = Freefile()
counter% = 0
Print fileName
Open fileName For Output As fileNum
Print # fileNum, aMessage
Close fileNum
End Sub
Function GetFilePathFromFileNameAndPath( fileNameAndPath As String )
' Given C:\notes\data\mydatabase.nsf returns C:\notes\data\
' does return the slash
Dim posOfSlash As String
Dim prevPosOfSlash As String
If fileNameAndPath = "" Then
GetFilePathFromFileNameAndPath = ""
Exit Function
End If
posOfSlash = Instr( fileNameAndPath, "\" )
prevPosOfSlash = posOfSlash
Do While posOfSlash >0
prevPosOfSlash = posOfSlash
posOfSlash = Instr( posOfSlash + 1, fileNameAndPath, "\" )
Loop
Dim session As New NotesSession()
Dim db As NotesDatabase
Dim vw As NotesView
Set db = session.CurrentDatabase
Dim strViewName As String
strViewName = "CitiesLookup"
strViewName = "ParametersLookup"
Set vw=db.GetView(strViewName)
If vw Is Nothing Then
Error 1000, "There is no view named " + strViewName + " in the db " + db.Title
Exit Function
End If
Dim strCitiesArr As Variant ' a string array
strCitiesArr = PerformDbLookupLS( vw, "database_code", 2)
' or
' strCitiesArr = PerformDbLookupLS( vw, "Australia", "CityName")
Msgbox Join(strCitiesArr, ", ")
GetFilePathFromFileNameAndPath = Left( fileNameAndPath, prevPosOfSlash )
End Function
Function GetTextAtPosition( strBigString, intPosToFind As Integer, strDelimeter As String ) As String
' Finds text at a certain position given the delimeter
'atk modified 12/04/2005. Added + lenstrDelim-1
If strBigString = "" Then
GetTextAtPosition = ""
Exit Function
End If
Dim RightSide As String
Dim pos As Integer
Dim lastPos As Integer
Dim count As Integer
Dim NumberOfRightMostChars As Integer
lastPos = 0
pos = 1
pos = Instr ( pos, strBigString , strDelimeter )
Do While pos > 0 And count < intPosToFind-1
count = count + 1
lastPos = pos
pos = Instr ( pos + 1, strBigString , strDelimeter )
Loop
' If we found at least one of the substring then
If lastPos > 0 Then
NumberOfRightMostChars = Len( strBigString ) - ( lastPos + Len(strDelimeter)-1 ) ' atk modified12/04/2005. Added + lenstrDelim-1
RightSide = Right( strBigString, NumberOfRightMostChars )
If pos > 0 Then
GetTextAtPosition = Left( RightSide, pos-lastPos-1 )
Else
GetTextAtPosition = RightSide
End If
Elseif lastPos = 0 And pos > 0 Then
' Must have been the first item in the string
GetTextAtPosition = Left( strBigString, pos -1 )
Elseif lastPos = 0 And pos = 0 And (intPosToFind = 0 Or intPosToFind = 1) Then
' must be the first item in the string, and no delimeters
GetTextAtPosition = strBigString
Else
GetTextAtPosition = ""
End If
End Function
Function LineCount( fileName As String ) As Integer
Dim fileNum As Integer
Dim count As Integer
Dim txt As String
count = 0
fileNum% = Freefile()
Open fileName For Input As fileNum%
' Read the first line which will have the column headers in it
Do While Not Eof(fileNum%)
' Read each line of the file.
Line Input #fileNum%, txt$
count = count + 1
Loop
Close fileNum%
LineCount = count
End Function
Function GetMiddle( FullString, StartString As String, EndString As String) As String
' get the string within two delimiters
Dim begin As Integer
Dim idx As Integer
Dim idx2 As Integer
' make sue the delimiter exists else retrun the full string
If Instr (FullString , StartString) = 0 Then
GetMiddle = FullString
Exit Function
End If
If Instr (FullString , EndString) = 0 Then
GetMiddle = FullString
Exit Function
End If
begin = 1
idx = Instr (begin , FullString , StartString)
idx2 = Instr (begin , FullString , EndString)
GetMiddle = Trim(Mid(FullString , idx + 1 , (idx2 - idx - 1) ))
End Function
Function StringArrayIsEqual( array1() As String, array2() As String ) As Integer
Dim i As Integer
If Ubound( array1 ) <> Ubound( array2) Then
StringArrayIsEqual = False
Exit Function
End If
Dim upper_bound As Integer
upper_bound = Ubound ( array1)
For i = 0 To upper_bound
If array1( i ) <> array2 ( i ) Then
StringArrayIsEqual = False
Exit Function
End If
Next
StringArrayIsEqual = True
End Function
Function iGetView( db As NotesDatabase, ViewName As String ) As NotesView
Dim session As New NotesSession
If db Is Nothing Then
Print "Database not found. ( Function: [iGetView]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
If ViewName ="" Then
Set iGetView = Nothing
Exit Function
End If
Set iGetView = db.GetView( ViewName )
If iGetView Is Nothing Then
Set iGetView = Nothing
Exit Function
End If
End Function
Function iGetDocumentCollection( db As NotesDatabase, SearchFormula As String ) As NotesDocumentCollection
' Simply pass in the searchFormula and this document
' collection either returns the collection or ends the agent
' ATK 24/08/2004 Removed 3xprint statements
Dim dc As NotesDocumentCollection
Dim dt As New notesDateTime ( "1/1/1980")
Set dc = db.search(SearchFormula, dt, 0)
Set iGetDocumentCollection = dc
End Function
Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
' use sendmail now or sendmailwithdoclink
' version 2.... I like it
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
' only send if we have names to send to
If Datatype( iTo ) = 8 Then '8 String V_STRING
If iTo= "" Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
Else
Dim someoneToSendTo As Integer
someoneToSendTo = False
Forall bit In iTo
If bit <> "" Then
someoneToSendTo = True
End If
End Forall
If someoneToSendTo = False Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
End If
Dim iMailDoc As New NotesDocument(db)
iMailDoc.From = iFrom ' Set who it comes from
iMailDoc.SendFrom = iFrom ' Set who it comes from
iMailDoc.Principal = iFrom ' Set the Username Sender (from)
iMaildoc.Subject = Subject
'===================================================
' Set the body of the email
Dim rtBody As New NotesRichTextItem( iMailDoc, "Body" ) ' for attachment
Call rtBody.AppendText( "Dear " & ArrayToString(iTo, " and ") & ",")
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "This mail has been created via an automatic process." )
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtBody.AppendRtitem( newRTItem )
End If
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "Regards, The Agent")
' Call rtBody.AddNewLine(1)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
'=========================================================
' Add a link to this database so that users can find where this email came from
Call rtBody.AppendText( "DB Title: " & db.Title & Chr(13) )
Call rtBody.AppendText( "DB Path: " & db.FilePath & Chr(13) )
Call rtBody.AppendText( "DB Server: " & db.Server & Chr(13) )
Call rtBody.AppendText( "Doclink: " )
Call rtBody.AppendDocLink( db, db.Title )
'==========================================================
' Send the mail
' try to catch the error no match found in name and address book.
On Error 4294 Goto HandleNoMatchInAddBook
Call iMaildoc.Send( False, iTo )
Exit Sub
HandleNoMatchInAddBook:
Print Err & " " & Error
If Datatype( iTo ) = 8 Then '8 String V_STRING
Print "MailResults sub: Warning: Tried to send to " & iTo
Else
Print "MailResults sub: Warning: Tried to send to " & ArrayToString(iTo, ", ")
End If
Resume ContinueNow
ContinueNow:
End Sub
Function ProperCase(strString As String) As String
Dim ReturnVal As Variant
Dim LowerCase As String
LowerCase = Lcase(strString)
ReturnVal = Evaluate("@ProperCase(" + Chr(34) + LowerCase + Chr(34) + ")")
ProperCase = ReturnVal(0)
End Function
Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
' eg iString = "BT", iLenMin = 3, iLenMax = 10, iPadChar = "X" - desired length =
' would return BTX
Do While Len(iString) < iLenMin
iString = iString & iPadChar
Loop
' it can be MAX chars at most
If Len(iString) > iLenMax Then
iString = Left( iString, iLenMax )'
End If' len > max
PadOrCut = iString
End Function
Function GetViewOrDie( db As NotesDatabase, strViewName As String ) As NotesView
' renamed from iGetViewOrDie
Dim session As New NotesSession
If db Is Nothing Then
If session.CurrentAgent Is Nothing Then
Error 1000, "Database not found for view '" & strViewName & "'. ( Function: "&_
"[GetViewOrDie])."
Else
Error 1000, "Database not found for view '" & strViewName & "'. ( Function: "&_
"[GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End If
End
End If
If strViewName ="" Then
Error 1000, "Cannot get view in db " & db.Title & " with a blank name passed in " &_
"Exiting ( Function: "&_
"[GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
Set GetViewOrDie = db.GetView( strViewName )
If GetViewOrDie Is Nothing Then
Error 1000, "Cannot get view in db " & db.Title & " with name " &_
"'" & strViewName & "' Exiting ( Function: [GetViewOrDie]. Agent: [" & session.CurrentAgent.Name & "] )."
End
End If
End Function
Function GetCommonName( iLongName As String ) As String
Dim intFirstSlash As Integer
Dim intCN As Integer ' the pos of the "CN"
intCN = Instr(iLongName, "CN=")
If intCN <= 0 Then
intCN = 1
Else
intCN = intCN + 3 '3 is the length of CN=
End If
intFirstSlash = Instr(iLongName, "/")
If intFirstSlash <= 0 Then
intFirstSlash = Len( iLongName )+1
End If
'Mid[$] ( expr , start [ , length ] )
Dim intLength As Integer
intLength = intFirstSlash - intCN
' Mid must start from 1 or greater as the left most, not 0
GetCommonName = Mid( iLongName, intCN, intLength)
End Function
Sub POLICEUpdateAuditCode( doc As NotesDocument, update_string As String )
Dim iSession As NotesSession
Set iSession = New NotesSession
Dim item As NotesItem
Dim AgentName As String
Dim thisAgent As NotesAgent
Set thisAgent = iSession.CurrentAgent
If thisAgent Is Nothing Then
AgentName = ""
Else
AgentName= "AgentName=" & thisAgent.Name & ". "
End If
update_string = "Updated by " & iSession.CommonUserName & ". " & AgentName & update_string & " " & Str ( Today )
Set Item = doc.GetFirstItem ( "audit_police_code" )
If item Is Nothing Then
Set item = New NotesItem ( doc , "audit_police_code" , update_string )
Else
Call item.AppendToTextList ( update_string )
End If
item.IsSummary = True
End Sub
Function PadStart( iString As String, iSize As Integer, iPadChar As String )
' eg iString = "BT", iSize, iPadChar = "X" - desired length =
' would return BTX
' add to max
Do While Len(iString) < iSize
iString = iPadChar & iString
Loop
PadStart = iString
End Function
Function IsCanonicalFormat( strUserName ) As Boolean
' check if we have a cn= at the start
If Instr(strUserName, "CN=") > 0 Then
IsCanonicalFormat = True
Else
IsCanonicalFormat = False
End If
End Function ' IsCanonicalFormat
Function InsertText( rtItem As NotesRichTextItem, strTextToInsert As String ) As NotesRichTextItem
' Still working on this function ATK 19/08/2004
'Put the subject at the start of the body as well as in the subject line of the email.
' Dim rtnav As NotesRichTextNavigator
' Set rtnav = bodyItem.CreateNavigator( )
' move the insertion point to be the beginning of the first paragraph with the rtnav object
' Call rtnav.FindFirstElement( 4 ) 'RTELEM_TYPE_TEXTPARAGRAPH (4)
' Call bodyItem.BeginInsert(rtnav, False) 'False for parameter 2 (default) puts the insertion position at the beginning of the element.
Call rtItem.AppendText( strTextToInsert )
' End put the subject at the start of the body
End Function
Sub AddToArray( iArray As Variant, newValue As String )
On Error Goto ErrorAddToArray
If Isempty(iArray) Then ' if array was declared as a variant
Redim iArray(0) As String
End If
If ( Ubound(iArray) = Lbound(iArray) ) And iArray(Ubound(iArray)) = "" Then ' will raise err 200 if uninit
' if we are a new array with nothing in it then do not increase size
iArray(Lbound(iArray)) = newValue
Else
Dim newSize As Integer
newSize = Ubound(iArray)+1
ContinueFromErr:
Redim Preserve iArray(newSize)
iArray(newSize) = newValue
'AddToArray = iArray
End If
Exit Sub
ErrorAddToArray:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
newSize = 0
Resume ContinueFromErr
Else
Error Err, Error
End If
End Sub ' add to array
Sub PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument)
%REM
' 21/09/2004 ATK added parameter strOtherInfo as string to pass in other information
' ATK removed parameter and created function PoliceProcessWarning
'PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument )
----------------------------------------------------------------------------------------------------
Purpose: Process unexpected errors. Send a message with error information.
Parameters: strSendTo - email address to send the error message to; person or a group
strSubject - subject of the mailed error message
strFunctionName - name of the function where the error occurred
docWithError - the document to linked to
----------------------------------------------------------------------------------------------------
'
' This sub taken from TheView
%END REM
Dim session As NotesSession
Dim db As NotesDatabase
Dim docMemo As NotesDocument
Dim item As NotesItem
Dim rtiBody As NotesRichTextItem
Set session = New NotesSession
Set db = session.CurrentDatabase
Set docMemo = New NotesDocument(db)
Set item = New NotesItem(docMemo, "Form", "Memo")
item.IsSummary = True
'===================================================================
' Set the send to
'===================================================================
Dim vRecipients(0 To 1) As String
vRecipients(0) = "#LotusNotesError"
vRecipients(1) = "_SP-AppDesigner"
Set item = New NotesItem(docMemo, "SendTo", vRecipients )
Set item = New NotesItem(docMemo, "Logo", "Plain Text")
Set item = New NotesItem(docMemo, "Subject", strSubject)
item.IsSummary = True
'===================================================================
' Set the error specific fields
'===================================================================
Set item = docMemo.ReplaceItemValue("Application", db.title)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("Subroutine", strFunctionName)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorLine", Erl)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorNumber", Err )
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorMessage", Error$ )
item.IsSummary = True
'===================================================================
' Set the Body
'===================================================================
Set rtiBody = New NotesRichTextItem(docMemo, "Body")
Call rtiBody.AppendText("An unexpected error was encountered processing. ")
Call rtiBody.AddNewLine(2)
If Not (docWithError Is Nothing) Then
Call rtiBody.AppendText(" Error Document -> ")
Call rtiBody.AppendDocLink(docWithError, "")
Call rtiBody.AddNewLine(1)
End If
Call rtiBody.AppendText(" Database Title = " & db.title & " ---> ")
Call rtiBody.AppendDocLink(db, "DB throwing this error.")
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Server Name = " & db.server)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" FilePath= " & db.filepath )
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Subroutine = " & strFunctionName)
Call rtiBody.AddNewLine(2)
Call rtiBody.AppendText(" Error " & Err & " : " & Error$ + " at line number " & Erl )
Call rtiBody.AddNewLine(1)
'===================================================================
' Send it off
'===================================================================
Call docMemo.Send(False)
' print the info to the server log or console window
Print "ERROR in " & db.title & " - " + strFunctionName + ". Error " & Err & ": " & Error$ + " at line " & Erl
End Sub
Function GetCurrentDbInfo() As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim iString As String
iString = Chr(10) & "Title of db:" & db.Title
iString = iString & Chr(10) & "Filename of db:" & db.FileName
GetCurrentDbInfo = iString
End Function
Function GetMessageURLSmall( iMessage As String ) As String
GetMessageURLSmall = "Message?OpenForm&msg=" & EncodeURL(Replace(iMessage, """", "'"))
End Function
Function GetMessageURLMedium( iMessage As String ) As String
' get the message document if it does not exist, create it
Dim MESSAGE_VIEW_NAME As String
MESSAGE_VIEW_NAME = "vwMessage"
Dim docMessage As NotesDocument
Dim vwMessage As NotesView
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Set vwMessage = iGetView(db, MESSAGE_VIEW_NAME)
If vwMessage Is Nothing Then
'if the view is not there, then just use the small one
GetMessageURLMedium= GetMessageURLSmall(iMessage & "<!-- note to developer. Could not find view with name '" & MESSAGE_VIEW_NAME & "' -->")
Exit Function
End If
Dim KEEP_DOC_NUMBER As Integer
KEEP_DOC_NUMBER = 50
' get the 1st, 2nd, 3rd, 4th or 5th - KEEP_DOC_NUMBER doc as we should have 5 of them
' but we don't want to get the same one all the time
Dim iRandomNumber As Integer
' we want between 1 and KEEP_DOC_NUMBER
iRandomNumber = GetRandomIntInRange( 1, KEEP_DOC_NUMBER )
If iRandomNumber < 1 Or iRandomNumber > KEEP_DOC_NUMBER Then
Print "Could not get random number between 0 and " & Cstr(KEEP_DOC_NUMBER)
iRandomNumber = KEEP_DOC_NUMBER - 5 ' my own random
End If
Set docMessage = vwMessage.GetNthDocument(iRandomNumber)
Dim var As Variant
If docMessage Is Nothing Then
' create it
Set docMessage = db.CreateDocument( )
docMessage.Form = "Message"
var = Evaluate("@Unique", docMessage)
docMessage.ID = var
End If
If docMessage.ID(0) = "" Then
var = Evaluate("@Unique", docMessage)
docMessage.ID = var
End If
docMessage.SearchString = "" ' clear the search string as this is a saved doc
docMessage.Message = iMessage
docMessage.Information = "Created in script library to show error/warning messages"
docMessage.MessageAuthorAN = "*"
Call docMessage.ComputeWithForm( False, False )
Call docMessage.Save( True, True )
' Clean up messages if necessary - housekeeping, don't delete our current message
Call CleanUpOldMessageDocs( vwMessage, docMessage, KEEP_DOC_NUMBER )
GetMessageURLMedium = MESSAGE_VIEW_NAME & "/" & docMessage.ID(0) & "?OpenDocument"
End Function
Function GetRandomIntInRange( iMin As Integer, iMax As Integer ) As Integer
GetRandomIntInRange = Int( Rnd()*(iMax-iMin+1) ) + iMin
End Function
Sub CleanUpOldMessageDocs( iVwMessage As NotesView, docDontDelete As NotesDocument, KeepNumber As Integer )
' eg Keepnumber = 20
' lets keep keepNumber messages in the db
' lets clean up if there is more than KeepNumber
Dim docMessage As NotesDocument, docMessageNext As NotesDocument
Set docMessage = iVwMessage.GetFirstDocument( )
Dim removedCount As Long
While Not docMessage Is Nothing
Set docMessageNext = iVwMessage.GetNextDocument( docMessage )'
If removedCount > KeepNumber Then ' leave keepNumber messages in the system
If docMessage.Id(0) <> docDontDelete.Id(0) Then ' dont delete the one we just created
Print "<br>Cleaning up other messages - removing the message starting with {" & EncodeURL( Replace(Left(docMessage.Message(0), 200 ),"""", "'")) & "}<br><br>"
Call docMessage.Remove( False )
End If ' check id
End If 'removedCount > keepnumber
Set docMessage = docMessageNext
removedCount = removedCount + 1
If removedCount > ( KeepNumber + 20 ) Then
Print "Cleaning up messages. Removed max, 20 documents. Getting out."
Set docMessage = Nothing
Else
End If
Wend
End Sub
Function GetMessageURLLarge( iMessage As String ) As String
' I can't think of what to do differently for
' large and medium messages.
GetMessageURLLarge = GetMessageURLMedium( iMessage )
End Function
Function GetMessageURL ( iMessage As String ) As String
'depending on the size of the message, show different things'
' for a very small message, then just show the MailingRequest form with
' the message at teh top for larger messages, save it to a document
' and return the URL of that document
Dim MESSAGE_SMALL As Long
Dim MESSAGE_MEDIUM As Long
Dim MESSAGE_LARGE As Long
MESSAGE_SMALL = 50
MESSAGE_MEDIUM = 100
MESSAGE_LARGE = 1000000
Dim lngMessageSize As Long
lngMessageSize = Len(iMessage)
If lngMessageSize < MESSAGE_SMALL Then
GetMessageURL = GetMessageURLSmall( iMessage )
Elseif lngMessageSize < MESSAGE_MEDIUM Then
GetMessageURL = GetMessageURLMedium( iMessage )
Else
GetMessageURL = GetMessageURLLarge( iMessage )
End If ' message size
End Function
Function GetHTMLBackLinks(doc) As String
' to be used on the print out results of an agent
Dim strPoliceLastURL As String
Dim strThisURL As String
Dim strQuery_String As String
strPoliceLastURL = doc.HTTP_Referer(0)
strThisURL = doc.Path_Info_Decoded(0)
strQuery_String = doc.Query_String(0)
If strQuery_String <> "" Then
strThisURL = strThisURL '& "?" & strQuery_String
End If
' use single quotes here, not doulble quotes as it will prob be used
' in a url in a quote delimeted by " " that is double quotes
Dim strHome As String
strHome = {<a href=''>Go Home</a>} ' yes, blank
Dim strHistoryBack As String
strHistoryBack = {<a href='javascript:history.go(-1);'>History-1</a>}
strHistoryBack = strHistoryBack & {<a href='javascript:history.go(-2);'>History-2</a>}
GetHTMLBackLinks = strHome & { <a href='} & strPoliceLastURL &_
{'>Go Back</a> <a href='} & strThisURL & {'>Try Again</a>} &_
{ } & strHistoryBack
End Function
Function GoToURL( iUrl As String) As String
' Prints out the html and javascript to change pages.
' includes its own "/"
' we will make sure that if we are using a small url
' that we convert "" to single ' quotes
' Changed to use location.replace, not location =
Dim iString As String
' check if the nsf is already in the name
Dim thisFileNameAndPath As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
thisFileNameAndPath = "/" & Replace(db.FilePath,"\","/")
If Instr( iUrl, thisFileNameAndPath ) > 0 Then
' leave the url alone as it has the name and path,
Else
' append the name at the beginning
iUrl = thisFileNameAndPath + "/" + iUrl
End If
iUrl = Replace(iUrl, |"|, |'| )
iString = |<script language="javascript">|
iString = iString & |location.replace("| & iUrl & |")|
iString = iString & |</script>|
GoToURL = iString
End Function
Function EncodeURL( iString As String ) As String
Dim vntResult As Variant
' Double quotes do not work in @URLEncode
iString = Replace( iString, """", "'" )
vntResult = Evaluate(|@URLEncode( "Domino"; "| & iString & |")|)
If Datatype(vntResult) <> 0 Then
EncodeURL = vntResult(0)
Else
EncodeURL = ""
End If
End Function
Function DecodeURL( iString As String ) As String
Dim vntResult As Variant
vntResult = Evaluate(|@URLDecode( "Domino"; "| & iString & |")|)
If Datatype(vntResult) <> 0 Then
DecodeURL = vntResult(0)
Else
DecodeURL = ""
End If
End Function
Function RemoveVowels(iString As String) As String
' remove a, e, i, o, u
'sourceArray = ["first second third"]
'replaceArray = ["first"]["second"]["1"]["third"]["2"]["3"]
'replacementArray = ["1"]["2"]["a"]["3"]["b"]["c"]
Dim removeThese(4) As String
removeThese(0) = "a"
removeThese(1) = "e"
removeThese(2) = "i"
removeThese(3) = "o"
removeThese(4) = "u"
Dim sourceString(0) As String
sourceString(0) = iString
Dim replaceWith(0) As String
replaceWith(0) = "" ' blank
Dim iVar As Variant
If Len(iString) = 0 Then
' do nothing as it is empty string
iVar(0) = iString
Else
iVar = Replace( sourceString, removeThese, replaceWith )
End If
RemoveVowels = iVar(0)
End Function ' RemoveVowels
Function CheckAlphaNum( iString, iException ) As Integer
' check if the string is alpha numeric
' allows spaces and "-" dashes
' returns 0 if there is no problem, otherwise
' returns the position of the offending character
' eg iException = "-"
' renamed this from IsAlphaNum as we are not returning a boolean
CheckAlphaNum = 0 ' default to zero, ie no non alphanum found
Dim startOfAlphaAsciiCode As Integer, endOfAlphaAsciiCode As Integer
Dim startOfNumAsciiCode As Integer, endOfNumAsciiCode As Integer
Dim asciiCodeException As Integer, asciiCodeSpace As Integer
' Set up the ascii codes to check
startOfAlphaAsciiCode = Asc("A") ' upper case A
endOfAlphaAsciiCode = Asc ("z") ' to lowercase z
startOfNumAsciiCode = Asc("0") ' zero
endOfNumAsciiCode = Asc ("9" )
asciiCodeSpace = Asc( " " )
If Len(iException) = 1 Then ' if there is nothing or a string
asciiCodeException = Asc(iException)
Else
asciiCodeException = asciiCodeSpace ' ie ignore this
End If
' Convert the input to an array of characters for processing
Dim ArrayOfChars As Variant ' (Len(iString)) As String
ArrayOfChars = SplitStringToChars (iString)
Dim charIdx As Integer ' the index of where we are at
' Loop through each character, exiting if we find even one error. Return the pos of invalid char
Dim lenOfArray As Integer
lenOfArray = Ubound(ArrayOfChars) + 1
Dim var1 As Variant
Dim asciiValueThisChar As Integer
Do While charIdx < lenOfArray And CheckAlphaNum = 0
' Check if Not ( isAlpha Or isNum or is Dash )
asciiValueThisChar = Asc(ArrayOfChars(charIdx))
charIdx = charIdx + 1
If Not ( _
( asciiValueThisChar >= startOfAlphaAsciiCode And asciiValueThisChar <= endOfAlphaAsciiCode ) Or _
( asciiValueThisChar >= startOfNumAsciiCode And asciiValueThisChar <= endOfNumAsciiCode ) Or _
asciiValueThisChar = asciiCodeException Or _
asciiValueThisChar = asciiCodeSpace ) Then
' failure
CheckAlphaNum = charIdx
End If '
Loop
'--Do While charIdx <= lenOfArray And IsAlphaNum = 0
CheckAlphaNum = CheckAlphaNum ' code here for ease of reading. either 0 as default or pos of invalid char
End Function ' IsAlphaNum
Function SplitStringToChars( iString )
' am not using split because it cannot take "" as the
' second parameter
' given "abc" returns
' array(0) = "a"
' array(1) = "b"
' array(2) = "c"
' given "abc def" returns
' array(0) = "a"
' array(1) = "b"
' array(2) = "c"
' array(3) = " "
' array(4) = "d"
' array(5) = "e"
Dim lenOfSource As Integer
lenOfSource = Len(iString)
Redim returnArray(0 To lenOfSource-1) As String
Dim i As Integer
For i = 1 To lenOfSource
' Mid ( iString , start [ , length ]
returnArray(i-1) = Mid ( iString , i, 1 )
Next
SplitStringToChars = returnArray
End Function
Function GetArgFromQuery_String(iArgName, iQuery_String) As String
' eg GetArgFromQuery_String("&user=", "OpenAgent&user=Anthony"
Dim lenOfArgWithValue As Integer
Dim lenOfValue As Integer
Dim argValue As String
If Instr(iQuery_String, iArgName) <= 0 Then
GetArgFromQuery_String = ""
Exit Function
End If
lenOfArgWithValue = Len(iQuery_String) - ( Instr(iQuery_String, iArgName) -1 )
lenOfValue = lenOfArgWithValue - Len(iArgName)
argValue = Right( iQuery_String, lenOfValue )
' check if there are any more args after this one, if there is an &
Dim hasAmp As Integer ' the pos of an ampersand char
hasAmp = Instr(argValue, "&" )
If hasAmp > 0 Then
argValue = Left( argValue, hasAmp-1 )
End If
GetArgFromQuery_String = DecodeURL(argValue)
End Function
Function HasRole( strRoleName As String, strFullUsername As String ) As Boolean
' strFullUserName, eg "CN=Anthony T Kendrick/OU=Staff/O=NSWPolice"
' I thikn that the role name should be encased in "[]" eg "[Admin]"
If Instr(strRoleName, "[" ) <=0 Then
strRoleName = "[" & strRoleName
End If
If Instr(strRoleName, "]") <=0 Then
strRoleName = strRoleName & "]"
End If
Dim strUsernameWarning As String
If Not IsCanonicalFormat( strFullUserName ) Then
strUsernameWarning = "Note that roles are " & _
"queried based on full user name eg, "&_
"of the form CN=FirstName Lastname/O=The Organisation. " &_
"It appears that the user name passed in '" & strFullUserName & "' " &_
"is not of canonical format"
Error 1000, strUsernameWarning & " Function: HasRole()"
End If
Dim session As New NotesSession()
Dim db As NotesDatabase
Dim roles As Variant
Set db = session.CurrentDatabase
' Default to false
HasRole = False
roles = db.QueryAccessRoles(strFullUsername)
If roles(0) = "" Then
HasRole = False
Else
Forall role In roles
If role = strRoleName Then
HasRole = True
Exit Function
End If
End Forall
End If
End Function ' HasRole
Function GetAsHTMLComment( iString ) As String
GetAsHTMLComment = Chr(10) & Chr(13) & "<!-- " & iString & "-->"
End Function
Function ConvertDateToYYYYMM ( dtADate As Variant ) As String
' eg given 05/08/2004 returns 200408
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
' Pad or Cut makes sure that the month is not "2", but "02"
ConvertDateToYYYYMM = Cstr( Year( dtADate )) & PadOrCut( Cstr( Month(dtADate )), 2, 2, "0" )
End Function
Function ConvertDateToMMMYYYY ( dtADate As Variant ) As String
' eg given 05/08/2004 returns August 2004
' Function PadOrCut( iString As String, iLenMin As Integer, iLenMax As Integer, iPadChar As String )
ConvertDateToMMMYYYY = GetMonthName( Month(dtADate )) & " " & Cstr( Year( dtADate ))
End Function
Function GetMonthName( intMonthNumber As Integer ) As String
' eg give 1, returns "January"
Dim strMonth As String
Select Case intMonthNumber
Case 1
strMonth = "January"
Case 2
strMonth = "February"
Case 3
strMonth = "March"
Case 4
strMonth = "April"
Case 5
strMonth = "May"
Case 6
strMonth = "June"
Case 7
strMonth = "July"
Case 8
strMonth = "August"
Case 9
strMonth = "September"
Case 10
strMonth = "October"
Case 11
strMonth = "November"
Case 12
strMonth = "December"
Case Else
strMonth = Cstr(intMonthNumber)
End Select
GetMonthName = strMonth
End Function
Sub PoliceProcessWarning( strSubject As String, strFunctionName As String, docWithError As NotesDocument, strOtherInfo As String )
%REM
' 21/09/2004 ATK Created from PoliceProcessError.
'PoliceProcessError( strSubject As String, strFunctionName As String, docWithError As NotesDocument )
----------------------------------------------------------------------------------------------------
Purpose: Process warnings. Send a message with error information.
Parameters: strSendTo - email address to send the error message to; person or a group
strSubject - subject of the mailed error message
strFunctionName - name of the function where the error occurred
docWithError - the document to linked to
----------------------------------------------------------------------------------------------------
' Does not print the log or console at the end like the process error function
' This sub taken from TheView
%END REM
Dim session As NotesSession
Dim db As NotesDatabase
Dim docMemo As NotesDocument
Dim item As NotesItem
Dim rtiBody As NotesRichTextItem
Set session = New NotesSession
Set db = session.CurrentDatabase
Set docMemo = New NotesDocument(db)
Set item = New NotesItem(docMemo, "Form", "Memo")
item.IsSummary = True
'===================================================================
' Set the send to
'===================================================================
Dim vRecipients(0 To 1) As String
vRecipients(0) = "#Errors in Apps"
vRecipients(1) = "_SP-AppDesigner"
Set item = New NotesItem(docMemo, "SendTo", vRecipients )
Set item = New NotesItem(docMemo, "Logo", "Plain Text")
Set item = New NotesItem(docMemo, "Subject", strSubject)
item.IsSummary = True
'===================================================================
' Set the error specific fields
'===================================================================
Set item = docMemo.ReplaceItemValue("Application", db.title)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("Subroutine", strFunctionName)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorLine", Erl)
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorNumber", Err )
item.IsSummary = True
Set item = docMemo.ReplaceItemValue("ErrorMessage", Error$ )
item.IsSummary = True
'===================================================================
' Set the Body
'===================================================================
Set rtiBody = New NotesRichTextItem(docMemo, "Body")
Call rtiBody.AppendText("An unexpected error was encountered processing. ")
Call rtiBody.AddNewLine(2)
If Not (docWithError Is Nothing) Then
Call rtiBody.AppendText(" Error Document -> ")
Call rtiBody.AppendDocLink(docWithError, "")
Call rtiBody.AddNewLine(1)
End If
Call rtiBody.AppendText(" Database Title = " & db.title & " ---> ")
Call rtiBody.AppendDocLink(db, "DB throwing this error.")
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Server Name = " & db.server)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Filename = " & db.filename)
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText(" Subroutine = " & strFunctionName)
Call rtiBody.AddNewLine(2)
Call rtiBody.AppendText(" Error " & Err & " : " & Error$ + " at line number " & Erl )
Call rtiBody.AddNewLine(1)
If strOtherInfo <> "" Then
Call rtiBody.AddNewLine(1)
Call rtiBody.AppendText( strOtherInfo )
Call rtiBody.AddNewLine(1)
End If
'===================================================================
' Send it off
'===================================================================
Call docMemo.Send(False)
End Sub
Function IsAbbreviatedFormat( strUserName As String ) As Boolean
'eg abbreviated "John B Goode/Sales/East/Acme/US"
If IsCanonicalFormat( strUserName ) = True Then
IsAbbreviatedFormat = False
Else
If Instr( strUserName, "/" ) > 0 Then
IsAbbreviatedFormat = True
Else
IsAbbreviatedFormat = False
End If
End If
End Function '-- IsAbbreviatedFormat
Function IsCommonFormat ( strUserName As String ) As Boolean
' eg common "John B Goode"
If Instr( strUserName, "/" ) Then
IsCommonFormat = False
Else
IsCommonFormat = True
End If
End Function '-- IsCommonFormat
Sub CleanUpOldDocs( iView As NotesView, docDontDelete As NotesDocument, KeepNumber As Integer )
' eg Keepnumber = 20
' lets keep keepNumber messages in the db
' lets clean up if there is more than KeepNumber
Dim doc As NotesDocument, docNext As NotesDocument
Set doc = iView.GetFirstDocument( )
Dim removedCount As Long
While Not doc Is Nothing
Set docNext = iView.GetNextDocument( doc )'
If removedCount > KeepNumber Then ' leave keepNumber of these docs in the system
If doc.Id(0) <> docDontDelete.Id(0) Then ' dont delete the one we just created
' Print "<br>Cleaning up other docs of this type - removing the doc starting with {" & EncodeURL( Replace(Left(docMessage.Message(0), 200 ),"""", "'")) & "}<br><br>"
Call doc.Remove( False )
End If ' check id
End If 'removedCount > keepnumber
Set doc = docNext
removedCount = removedCount + 1
If removedCount > ( KeepNumber + 20 ) Then
Print "Cleaning up docs. Removed max, 20 documents. Getting out."
Set doc = Nothing
Else
' do nothing
End If
Wend
End Sub
Function IsAccessLevelAtLeast ( required_level As String ) As Integer
' Returns true if the user has the level of access or greater requested.
' NOT case sensitive
' required_level = ["manager", "designer", "editor", "author", "reader", "depositor", "noaccess"]
%REM
ACLLEVEL_NOACCESS (0)
ACLLEVEL_DEPOSITOR (1)
ACLLEVEL_READER (2)
ACLLEVEL_AUTHOR (3)
ACLLEVEL_EDITOR (4)
ACLLEVEL_DESIGNER (5)
ACLLEVEL_MANAGER (6)
%ENDREM
Dim required As Integer
Dim session As New NotesSession
Dim db As NotesDatabase
Dim level As Integer
Set db = session.CurrentDatabase
IsAccessLevelAtLeast = False
Select Case Lcase( required_level)
Case "manager"
required = 6
Case "designer"
required = 5
Case "editor"
required = 4
Case "author"
required = 3
Case "reader"
required = 2
Case "depositor"
required = 1
Case "noaccess"
required = 0
Case Else
Print "Exiting. Error Cannot determine access level. Sub CheckAccessLevel(" & required_level & ")"
IsAccessLevelAtLeast = False
Exit Function
End Select
level = db.CurrentAccessLevel
If level >= required Then
IsAccessLevelAtLeast = True
End If
End Function
Sub QuickSort (lngLbound As Long,lngUbound As Long, varSortArray As Variant)
'Pass the lower bound of the array to lngLbound, the upper bound of the array to lngUbound and the array to varSortArray.
Dim varValue1 As Variant
Dim varValue2 As Variant
Dim lngTmpLbound As Long
Dim lngTmpUbound As Long
If lngUbound > lngLbound Then 'If there's nothing to sort, jump out
varValue1 = varSortArray(lngLbound) 'Initialize boundaries, nominate a value To sort
lngTmpUbound = lngUbound
lngTmpLBound = lngLbound
While (lngTmpLBound < lngTmpUbound) 'Repeat until lngTmpLBound and lngTmpUbound "meet in the middle"
While (varSortArray(lngTmpLBound) <= varValue1 And lngTmpLBound < lngUbound) 'Push in the boundaries while data is sorted
lngTmpLBound = lngTmpLBound + 1
Wend
While (varSortArray(lngTmpUbound) > varValue1)
lngTmpUbound = lngTmpUbound - 1
Wend
If lngTmpLBound < lngTmpUbound Then 'If there is data between lngTmpLBound and lngTmpUbound something is out of order - swap it
varValue2 = varSortArray(lngTmpLBound)
varSortArray(lngTmpLBound) = varSortArray(lngTmpUbound)
varSortArray(lngTmpUbound) = varValue2
End If
Wend
varValue2 = varSortArray(lngLbound) 'Swap the nominated and bottom values - why we came here
varSortArray(lngLbound) = varSortArray(lngTmpUbound)
varSortArray(lngTmpUbound) = varValue2
Call QuickSort (lngLbound, lngTmpUbound - 1, varSortArray) 'Recurse and sort data either side of upper bound
Call QuickSort ((lngTmpUbound + 1), lngUbound, varSortArray)
End If
End Sub
Function RemoveNonAlphaNum ( Byval strSource As String ) As String
' eg given You are 'da man 344
' returns You are da man 344
' alphaArray(0) =
' alphaUArray ' upper case
Dim numberArray(0 To 9) As String ' 9 is upper bound, not size
numberArray(0) = "0"
numberArray(1) = "1"
numberArray(2) = "2"
numberArray(3) = "3"
numberArray(4) = "4"
numberArray(5) = "5"
numberArray(6) = "6"
numberArray(7) = "7"
numberArray(8) = "8"
numberArray(9) = "9"
Dim alphaArray(0 To 25) As String
alphaArray(0) = "a"
alphaArray(1) = "b"
alphaArray(2) = "c"
alphaArray(3) = "d"
alphaArray(4) = "e"
alphaArray(5) = "f"
alphaArray(6) = "g"
alphaArray(7) = "h"
alphaArray(8) = "i"
alphaArray(9) = "j"
alphaArray(10) = "k"
alphaArray(11) = "l"
alphaArray(12) = "m"
alphaArray(13) = "n"
alphaArray(14) = "o"
alphaArray(15) = "p"
alphaArray(16) = "q"
alphaArray(17) = "r"
alphaArray(18) = "s"
alphaArray(19) = "t"
alphaArray(20) = "u"
alphaArray(21) = "v"
alphaArray(22) = "w"
alphaArray(23) = "x"
alphaArray(24) = "y"
alphaArray(25) = "z"
Dim alphaUArray(0 To 25) As String
alphaUArray(0) = "A"
alphaUArray(1) = "B"
alphaUArray(2) = "C"
alphaUArray(3) = "D"
alphaUArray(4) = "E"
alphaUArray(5) = "F"
alphaUArray(6) = "G"
alphaUArray(7) = "H"
alphaUArray(8) = "I"
alphaUArray(9) = "J"
alphaUArray(10) = "K"
alphaUArray(11) = "L"
alphaUArray(12) = "M"
alphaUArray(13) = "N"
alphaUArray(14) = "O"
alphaUArray(15) = "P"
alphaUArray(16) = "Q"
alphaUArray(17) = "R"
alphaUArray(18) = "S"
alphaUArray(19) = "T"
alphaUArray(20) = "U"
alphaUArray(21) = "V"
alphaUArray(22) = "W"
alphaUArray(23) = "X"
alphaUArray(24) = "Y"
alphaUArray(25) = "Z"
' Notes 6, use replace
Dim strBadChars As String
strBadChars = strSource
strBadChars = Replace( strBadChars, numberArray, "" )
strBadChars = Replace( strBadChars, alphaArray, "" )
strBadChars = Replace( strBadChars, alphaUArray, "" )
strBadChars = Trim( strBadChars )
' I tried to use a variant, instead of a String array and the Replace function
' died.
If Len(strBadChars) > 1 Then
Dim intUbound As Integer
intUbound = Len(strBadChars) - 1
Redim strBadCharsArr(0 To intUbound) As String
Dim i As Integer
For i = 0 To intUbound
strBadCharsArr(i) = Mid ( strBadChars, i+1, 1 )
Next
strSource = Replace( strSource, strBadCharsArr, "" )
Else
strSource = Replace( strSource, strBadChars, "" )
End If
RemoveNonAlphaNum = strSource
End Function
Sub GetAllGroupsInACL( strGroupsInACLArr As Variant )
' modify the strGroupsInACLArr array to include all of the groups in the acl
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim acl As NotesACL
Dim aclentry As NotesACLEntry
Set acl = db.ACL
Set aclentry = acl.GetFirstEntry()
Dim intACLGroupCount As Integer
intACLGroupCount = 0
Do While Not aclentry Is Nothing
If aclentry.IsGroup Then
Redim Preserve strGroupsInACLArr(0 To intACLGroupCount) As String
strGroupsInACLArr( intACLGroupCount ) = aclentry.Name
intACLGroupCount = intACLGroupCount + 1
End If ' is group
Set aclentry = acl.GetNextEntry( aclentry )
Loop
' end loop while not aclentry is nothing
End Sub
Function ChooseAddressBook( strServer As String ) As NotesDatabase
Dim session As New NotesSession()
Dim vAddBooks As Variant
vAddBooks = session.AddressBooks
Dim dbAddressBook As NotesDatabase
Dim intPubCount As Integer
Dim intBookIdx As Integer
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
intPubCount = intPubCount + 1
End If
Next
If intPubCount = 1 Then
For intBookIdx = 0 To Ubound(vAddBooks)
If Not vAddBooks(intBookIdx).IsOpen Then ' Might already be open
Call vAddBooks(intBookIdx).Open("","") ' must open first
End If ' isopen
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
Set dbAddressBook = vAddBooks(intBookIdx)
intBookIdx = Ubound(vAddBooks) 'jump out of for loop
End If
Next
Else
'============================================================
' There are multiple address books, so let the user choose
Dim intPubIdx As Integer
Redim strPubAddBooksArr(Ubound(vAddBooks)) ' a string to prompt user
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
strPubAddBooksArr(intPubIdx) = vAddBooks(intBookIdx).Title 'jump out of for loop
intPubIdx = intPubIdx + 1
End If
Next
Dim workspace As New NotesUIWorkspace
Dim response As Variant
response = workspace.Prompt (PROMPT_OKCANCELLIST, _
"Select an server to update", _
"Select an server to update", _
strPubAddBooksArr(0), strPubAddBooksArr)
If Isempty (response) Then
Set dbAddressBook = Nothing
Else
For intBookIdx = 0 To Ubound(vAddBooks)
Call vAddBooks(intBookIdx).Open("","") ' must open first
If vAddBooks(intBookIdx).IsPublicAddressBook = True Then
If vAddBooks(intBookIdx).Title = response Then
Set dbAddressBook = vAddBooks(intBookIdx) 'jump out of for loop
intBookIdx = Ubound(vAddBooks) ' jump out
End If ' Title
End If ' IsPublic
Next
End If
End If ' intPubcount
Set ChooseAddressBook = dbAddressBook
End Function
Function ConvertRoleToString( intRole As Integer) As String
%REM
ACLTYPE_UNSPECIFIED (0)
ACLTYPE_PERSON (1)
ACLTYPE_SERVER (2)
ACLTYPE_MIXED_GROUP (3)
ACLTYPE_PERSON_GROUP (4)
ACLTYPE_SERVER_GROUP (5)
%ENDREM
Dim strRole As String
Select Case intRole
Case 0
strRole = "Unspecified"
Case 1
strRole = "Person"
Case 2
strRole = "Server"
Case 3
strRole = "Mixed Group"
Case 4
strRole = "Person Group"
Case 5
strRole = "Server Group"
Case Else
Error 1000, "No string coded for a role type of " & intRole
End Select
ConvertRoleToString = strRole
End Function
Function ConvertAccessLevelToString( intAccessLevel As Integer ) As String
' eg to use this try " Your access level is " & ConvertAccessLevelToString( db.CurrentAccessLevel )
Dim strLevel As String
Select Case Lcase( intAccessLevel )
Case 6
strLevel = "Manager"
Case 5
strLevel = "Designer"
Case 4
strLevel = "Editor"
Case 3
strLevel = "Author"
Case 2
strLevel = "Reader"
Case 1
strLevel = "Depositor"
Case 0
strLevel = "No Access"
Case Else
Error 1000, "Exiting. Error cannot determine access level. Sub ConvertAccessLevelToString( )"
Exit Function
End Select
ConvertAccessLevelToString = strLevel
End Function
Function GetAccessLevelAsString( ) As String
Dim intCurrentLevel As Integer
Dim strCurrentLevel As String
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
intCurrentLevel = db.CurrentAccessLevel
GetAccessLevelAsString = ConvertAccessLevelToString( intCurrentLevel )
End Function
Function FileExists( strPathAndFile As String ) As Boolean
' Input: pathname is the filepath and filename eg "c:\temp\cat.txt"
' Return 1 if file exists, else return 0
On Error Goto HandleFileExistsError
Dim blFileExists As Boolean
blFileExists = False
Dim fileName As String
fileName$ = Dir$(strPathAndFile$, 0) ' 0 for normal file, 16 for directory
If fileName$ <> "" Then
blFileExists = True
Else
Dim session As New NotesSession()
If session.IsOnServer Then
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Print "fileExists: Warning - we are on a server you know - server name is [" & db.Server & "] is your file on the server?"
End If
' if session.CurrentAgent.
blFileExists = False
End If
NormalExit:
FileExists = blFileExists
Exit Function
HandleFileExistsError:
If Err = 76 Then '76 Path not found, eg if we pass in a path, not a file....
' guess the file doesn't exist, return false
blFileExists = False
Print "Warning file exists was code to check files.. are you checking a directory ? '" & strPathAndFile & "' )"
Resume NormalExit
Else
Error Err & " Error in sub FileExits - " & Error
End If
End Function
Function GetAbbreviatedName( strNameInCanonical As String ) As String
' remove the 0= and the CN=
' given CN=Anthony Kendrick/OU=45456464/OU=Staff/OU=NSWPolice
' returns "Anthony Kendrick/54844654/Staff/NSWPolice"
Dim strNewFormat As String
strNewFormat = strNameInCanonical
strNewFormat = Replace(strNewFormat, "OU=", "")
strNewFormat = Replace(strNewFormat, "CN=", "")
strNewFormat = Replace(strNewFormat, "O=", "")
GetAbbreviatedName = strNewFormat
End Function ' GetAbbreviatedName
Function OpenDirectoryDialog(blMultipleSelect, strTitle, _
strInitialDir, strInitialFile ) As String
' Simulate picking a diretory by getting a file
' and then stripping off the filename
' note there must be a file to select in the directory
Dim ws As New NotesUIWorkspace()
Dim vReturn
vReturn=ws.OpenFileDialog(False,"Please Select Directory", "*.*", "")
Dim strFileName As String
If Isempty(vReturn) Then
strFileName = ""
Else
strFileName =vReturn(0)
End If
OpenDirectoryDialog = GetFilePathFromFileNameAndPath( strFileName )
End Function
Function PrintOutFilesInDir( strDirectory As String )
Dim strTextFileName As String
Print "List of files in directory " & strDirectory
Dim intMaxFiles As Integer
intMaxFiles = 500
Dim intCounter As Integer
If fileExists( strDirectory ) = 1 Then
strTextFileName = Dir( strDirectory, 0 )
If strTextFileName = "" Then
Print "There are no files in the directory to process."
Else
Do While strTextFileName <> ""
Print "File listing '" & strTextFileName & "'"
' Get the next file in the directory
strTextFileName = Dir$()
intCounter = intCounter + 1
If intCounter > intMaxFiles Then
Print "Only showing a max of " & Cstr(intMaxFiles) " files. "
Exit Function
End If
Loop
End If
Print "Printing directories..."
intCounter = 0
strTextFileName = Dir( strDirectory, 16 ) ' 16 is directories
If strTextFileName = "" Then
Print "There are no directories in the directory to process."
Else
Do While strTextFileName <> ""
Print "File listing '" & strTextFileName & "'"
' Get the next file in the directory
strTextFileName = Dir$()
intCounter = intCounter + 1
If intCounter > intMaxFiles Then
Print "Only showing a max of " & Cstr(intMaxFiles) " files. "
Exit Function
End If
Loop
End If
Else
'Sub MailResults(iFrom As String, iTo As Variant, Subject As String, Body As Variant)
Dim strMessage As String
strMessage = "Possible error, does not look like the file/directory exists at " & strDirectory &_
". The current directory, ie where I am running on the server is " & Curdir$()
Print strMessage
End If
End Function
Function GetMemoIDFromPersonDoc ( docPerson As NotesDocument ) As String
Dim strMemoID As String
strMemoID = docPerson.ShortName(0)
If Isnumeric ( strMemoID ) = True Then
If Ubound( docPerson.ShortName ) > 0 Then
' try the other one
strMemoID = docPerson.ShortName( 1 )
End If
End If ' is numeric
GetMemoIDFromPersonDoc = strMemoId
End Function '--GetMemoIDFromPersonDoc (
Function GetSerialNumberFromPersonDoc ( docPerson As NotesDocument ) As String
Dim strSerialNum As String
strSerialNum = docPerson.ShortName(0)
If Isnumeric ( strSerialNum ) = False Then
If Ubound( docPerson.ShortName ) > 0 Then
' try the other one
strSerialNum = docPerson.ShortName( 1 )
End If
End If ' is numeric
GetSerialNumberFromPersonDoc = strSerialNum
End Function '--GetSerialNumberFromPersonDoc (
Function GetGenericHTMLLinkToDoc ( strID As String, strLinkText As String )
' return a string with the link
Dim strViewName As String
Dim strDocID As String
strViewName = "vwById"
strDocID = strID
Dim strURL As String
strURL = strViewName & |/| & strDocID & |?OpenDocument|
If strLinkText = "" Then
strLinkText = strURL
End If
GetGenericHTMLLinkToDoc =|<a href="| & strURL & |">| & strLinkText & |</a>|
End Function ' GetGenericHTMLLinkToDoc
Function GetNextAlphabetLetter( strAlphabetLetter As String ) As String
' Check for one and only one character
If Len(strAlphabetLetter) <> 1 Then
Error 1000, "I am expecting an alphabet letter of 1 character, but got " & strAlphabetLetter
End If
' Check we are in the correct range first
If Not IsAlpha(strAlphabetLetter) Then
Error 1000, "I am expecting an alphabet letter, but got " & strAlphabetLetter
End If
Dim strNextLetter As String
' Special cases are for z and Z
If Asc("Z") = Asc(strAlphabetLetter) Then
strNextLetter = "A"
Elseif Asc("z") = Asc(strAlphabetLetter ) Then
strNextLetter = "a"
Else
strNextLetter = Chr(Asc(strAlphabetLetter) + 1)
End If
GetNextAlphabetLetter = strNextLetter
End Function
Function IsAlpha( strString ) As Boolean
' check if the string is alpha
' allows spaces and "-" dashes
' returns 0 if there is no problem, otherwise
' returns the position of the offending character
Dim blStillAlpha As Boolean
blStillAlpha = True ' default to true
Dim startOfUpperAlphaAsciiCode As Integer, endOfUpperAlphaAsciiCode As Integer
Dim startOfLowerAlphaAsciiCode As Integer, endOfLowerAlphaAsciiCode As Integer
' Set up the ascii codes to check
startOfUpperAlphaAsciiCode = Asc("A") ' upper case A
startOfLowerAlphaAsciiCode = Asc("a") ' upper case A
endOfUpperAlphaAsciiCode = Asc ("Z") ' to lowercase z
endOfLowerAlphaAsciiCode = Asc ("z") ' to lowercase z
' Convert the input to an array of characters for processing
Dim ArrayOfChars As Variant ' (Len(iString)) As String
ArrayOfChars = SplitStringToChars (strString)
Dim charIdx As Integer ' the index of where we are at
' Loop through each character, exiting if we find even one error.
Dim lenOfArray As Integer
lenOfArray = Ubound(ArrayOfChars) + 1
Dim var1 As Variant
Dim asciiValueThisChar As Integer
Do While charIdx < lenOfArray And blStillAlpha = True
' Check if Not ( isAlpha Or isNum or is Dash )
asciiValueThisChar = Asc(ArrayOfChars(charIdx))
charIdx = charIdx + 1
If Not ( _
( asciiValueThisChar >= startOfUpperAlphaAsciiCode _
And asciiValueThisChar <= endOfUpperAlphaAsciiCode ) Or _
( asciiValueThisChar >= startOfLowerAlphaAsciiCode _
And asciiValueThisChar <= endOfLowerAlphaAsciiCode ) ) Then
' failure
blStillAlpha = False
End If '
Loop
'--Do While charIdx <= lenOfArray And IsAlphaNum = 0
IsAlpha = blStillAlpha ' code here for ease of reading. either 0 as default or pos of invalid char
End Function ' IsAlpha
Function TranslateIntToChar( intInput As Integer) As String
' eg given 1, return "A"
' eg given 2, return "B" etc
If intInput > 26 Then
Error 1000, "TranslateIntToChar: I was expecting an integer " & _
"smaller than 26, but got " & Cstr(intInput)
End If
If intInput < 1 Then
Error 1000, "TranslateIntToChar: I was expecting an integer " & _
"greater than 0, but got " & Cstr(intInput)
End If
' Return uppercase
Dim intStartOfAsciiRange As Integer, intInputAsciiRange As Integer
intStartOfAsciiRange = Asc("A") ' eg 65
' move the input to the ascii alphabet range for translation
intInputAsciiRange = intInput + intStartOfAsciiRange - 1
TranslateIntToChar = Chr(intInputAsciiRange)
End Function
Function GetPrevAlphabetLetter( strAlphabetLetter As String ) As String
' Check for one and only one character
If Len(strAlphabetLetter) <> 1 Then
Error 1000, "I am expecting an alphabet letter of 1 character, but got " & strAlphabetLetter
End If
' Check we are in the correct range first
'If Not IsAlpha(strAlphabetLetter) Then
' Error 1000, "I am expecting an alphabet letter, but got " & strAlphabetLetter
' End If
Dim strNextLetter As String
' Special cases are for z and Z
If Asc("A") = Asc(strAlphabetLetter) Then
strNextLetter = "Z"
Elseif Asc("a") = Asc(strAlphabetLetter ) Then
strNextLetter = "z"
Else
strNextLetter = Chr(Asc(strAlphabetLetter) - 1)
End If
GetPrevAlphabetLetter = strNextLetter
End Function
Sub AddSectionToRTItem( doc As NotesDocument, strRTItemName As String, strTitle As String, strText As String )
' Appends a section to the end of a rich text item
Dim session As New NotesSession
Dim rti As NotesRichTextItem
Set rti = doc.GetFirstItem( strRTItemName )
Dim rtstyle As NotesRichTextStyle
Set rtstyle = session.CreateRichTextStyle
rtstyle.Bold = True
Dim colorObject As NotesColorObject
Set colorObject = session.CreateColorObject
colorObject.NotesColor = COLOR_RED
Call rti.BeginSection(strTitle, rtstyle, colorObject, True)
Call rti.AppendText(strText)
Call rti.EndSection
Call doc.Save(True, True)
End Sub
Sub IncreaseCountField( docWithCountField As NotesDocument, strCountFieldName As String )
Dim intPreviousCount As Integer
Dim vPreviousValue As Variant
If docWithCountField.HasItem( strCountFieldName ) Then
vPreviousValue = docWithCountField.GetItemValue( strCountFieldName )(0)
If Datatype( vPreviousValue ) = 2 Then ' 2 is integer
intPreviousCount = vPreviousValue
Else
intPreviousCount = 0
End If ' datatype
Else
intPreviousCount = 0
End If ' has item
Call docWithCountField.ReplaceItemValue( strCountFieldName, intPreviousCount + 1 )
End Sub
Sub SendMail( strFrom As String, vTo As Variant, strSubject As String, Body As Variant)
' 18/04/2005 ATK copied strFrom MailResults
' version 2.... I like it
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
' only send if we have names to send to
If Datatype( vTo ) = 8 Then '8 String V_STRING
If vTo = "" Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
Else
Dim someoneToSendTo As Integer
someoneToSendTo = False
Forall bit In vTo
If bit <> "" Then
someoneToSendTo = True
End If
End Forall
If someoneToSendTo = False Then
Print "MailResults warning - no one to send mail to"
Exit Sub
End If
End If
Dim iMailDoc As New NotesDocument(db)
iMailDoc.From = strFrom ' Set who it comes from
iMailDoc.SendFrom = strFrom ' Set who it comes from
iMailDoc.Principal = strFrom ' Set the Username Sender (from)
iMaildoc.Subject = strSubject
'===================================================
' Set the body of the email
Dim rtBody As New NotesRichTextItem( iMailDoc, "Body" ) ' for attachment
Call rtBody.AppendText( "Dear " & ArrayToString(vTo, " and ") & ",")
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "This mail has been created via an automatic process." )
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtBody.AppendRtitem( newRTItem )
End If
' Call rtBody.AddNewLine(2)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
Call rtBody.AppendText( "Regards, The Agent")
' Call rtBody.AddNewLine(1)
Call rtBody.AppendText( Chr(10) & Chr(13) & Chr(10) & Chr(13) )
'=========================================================
' Add a link to this database so that users can find where this email came from
Call rtBody.AppendText( "DB Title: " & db.Title & Chr(13) )
Call rtBody.AppendText( "DB Path: " & db.FilePath & Chr(13) )
Call rtBody.AppendText( "DB Server: " & db.Server & Chr(13) )
Call rtBody.AppendText( "Doclink: " )
Call rtBody.AppendDocLink( db, db.Title )
'==========================================================
' Send the mail
' try to catch the error no match found in name and address book.
On Error 4294 Goto ShowMoreInformationAboutSendTo ' no match found in name and address book.
On Error 4295 Goto ShowMoreInformationAboutSendTo ' 4295 is Multiple matches found in name and address book.
Call iMaildoc.Send( False, vTo )
Exit Sub
ShowMoreInformationAboutSendTo:
Print Err & " " & Error
If Datatype( vTo ) = 8 Then '8 String V_STRING
Print "SendMail sub: Warning: Tried to send to " & vTo
Else
Print "SendMail sub: Warning: Tried to send to " & ArrayToString(vTo, ", ")
End If
Resume ContinueNow
ContinueNow:
End Sub
Sub SendMailWithDocLink( strFrom As String, vTo As Variant, strSubject As String, Body As Variant, docToLinkTo As NotesDocument )
Dim session As New NotesSession()
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim docMail As NotesDocument
Set docMail = New NotesDocument( db )
Dim rtiBody As NotesRichTextItem
Set rtiBody = New NotesRichTextItem ( docMail , "Body" )
' body could be a string
If Datatype( Body ) = 8 Then '8 String V_STRING
Call rtiBody.AppendText( Body )
Else
Dim newRTItem As NotesRichTextItem
Set newRTItem = Body
Call rtiBody.AppendRtitem( newRTItem )
End If
Call rtiBody.AddNewLine( 1 )
Call rtiBody.AppendDocLink( docToLinkTo, "" )
Call SendMail( strFrom, vTo, strSubject, rtiBody)
End Sub
Function CheckMandatoryFields( strFieldNamesArr As Variant, _
strFieldLabelsArr As Variant, uidocToCheck As NotesUIDocument ) As Boolean
' prompts for the user to fill in
' gives an error message with all mandatory fields
Dim docToCheck As NotesDocument
Set docToCheck = uidocToCheck.Document
Dim blAllFilledIn As Boolean
blAllFilledIn = True ' default to true
' Simple check at first
If Ubound( strFieldNamesArr ) <> Ubound(strFieldLabelsArr) Then
Print "something fishy going on ... field name list ( " & _
Cstr( Ubound( strFieldNamesArr ) ) & " ) and field labels ( " & _
Cstr( Ubound( strFieldLabelsArr ) ) & " ) list do not match in size"
End If
Dim intFieldIndex As Integer
Dim intNumberOfFields As Integer
intNumberOfFields = Ubound(strFieldNamesArr) + 1
'==========================================================
' Check if the fields exist and are filled in
'==========================================================
Dim strFailedField As String, strFailedLabel As String, strFieldName As String
Dim blThisOneFailed As Boolean
blThisOneFailed = False
Do While (intFieldIndex < intNumberOfFields) And (blAllFilledIn = True)
strFieldName = strFieldNamesArr(intFieldIndex)
If Not docToCheck.HasItem(strFieldName) Then
blThisOneFailed = True
Else
If Cstr(docTocheck.GetItemValue( strFieldName )(0)) = "" Then
blThisOneFailed = True
End If
End If
If blThisOneFailed = True Then
blAllFilledIn = False ' will cause it to exit the loop
strFailedField = strFieldName
strFailedLabel = strFieldLabelsArr( intFieldIndex)
End If
intFieldIndex = intFieldIndex + 1
Loop
' Show an error message of all fields
If blAllFilledIn = False Then
' go to the failed field
Call uidocToCheck.GotoField(strFailedField)
Msgbox "Please fill in the mandatory field for " & strFailedLabel & _
". The mandatory fields are: " & ArrayToString( strFieldLabelsArr, ", " )
End If
CheckMandatoryFields = blAllFilledIn
End Function
Sub CleanOutACL( aclFromDb As NotesACL )
Dim aclEntry As NotesACLEntry, aclEntryNext As NotesACLEntry
Set aclEntry = aclFromDb.GetFirstEntry()
Do While Not aclFromDb Is Nothing
Set aclEntryNext = aclFromDb.GetNextEntry(aclEntry)
If Not aclEntry.Name = "-Default-" Then ' cant remove default entry
Call aclEntry.Remove()
End If
Set aclEntry = aclEntryNext
Loop
' The acle must have at least one manager, so make sure default is manager if you are going to save here
'Set aclEntry = aclFromDb.GetEntry("-Default-")
'aclEntry.Level = 6 ' manager
' Call aclFromDb.Save()
End Sub
Function GenerateUniqueFilename( strFilename As String ) As String
' eg give the filename "\\anthonyspc\cat.txt"
' if a file already exists at that location, then returns something like
' returns "say \\anthonyspc\cat1.txt" or "\\anthonyspc\cat2.txt"
Dim intAppendix As Integer
intAppendix = 1
If strFilename = "" Then
Error 1000, "GenerateUniqueFilename - I was expecting a file to check if it exists. but nothing was passed in"
End If
Dim blFileExists As Boolean
blFileExists = FileExists( strFileName )
Dim strFilenameMinusExt As String
Dim strFilenameMinusExtMinusAppendix As String
Dim strExtension As String ' eg txt, "csv"
strExtension = Strrightback(strFileName, "." )
Dim strPrevAppendix As String
strPrevAppendix = ""
Do While blFileExists = True
' a db already exists with that filename, try another
'replace the last char with a number
' eg for cat.nsf, make it ca1.nsf, ca2.nsf
strFilenameMinusExt = Replace(strFilename, "." & strExtension, "")
strFilenameMinusExtMinusAppendix = Left(strFilenameMinusExt, (Len(strFilenameMinusExt)-Len(strPrevAppendix)))
strFilename = strFilenameMinusExtMinusAppendix & Cstr( intAppendix ) & "." & strExtension
strPrevAppendix = Cstr(intAppendix)
intAppendix = intAppendix + 1
blFileExists = FileExists( strFileName )
If intAppendix > 1000 Then
Error 1000, "GenerateUniqueFilename has not been coded to deal with more than 1000 dbs with a the same name."
End If
Loop
GenerateUniqueFilename = strFilename
End Function ' GenerateUniqueFilename
Function MakeSafeForFileName(strFileName As String) As String
Dim strSafeFileName As String
strSafeFileName = strFileName
strSafeFileName = Replace(strSafeFileName, " ", "")
strSafeFileName = Replace(strSafeFileName, ":", "")
strSafeFileName = Replace(strSafeFileName, "*", "")
strSafeFileName = Replace(strSafeFileName, "?", "")
strSafeFileName = Replace(strSafeFileName, {"}, {})
strSafeFileName = Replace(strSafeFileName, "<", "")
strSafeFileName = Replace(strSafeFileName, ">", "")
strSafeFileName = Replace(strSafeFileName, "|", "")
strSafeFileName = Replace(strSafeFileName, "/", "")
strSafeFileName = Replace(strSafeFileName, "\", "")
MakeSafeForFileName = strSafeFileName
End Function
Function MakeSafeForFilePath(strFilePath As String) As String
Dim strSafeFilePath As String
strSafeFilePath = strFilePath
strSafeFilePath = Replace(strSafeFilePath, " ", "")
strSafeFilePath = Replace(strSafeFilePath, ":", "")
strSafeFilePath = Replace(strSafeFilePath, "*", "")
strSafeFilePath = Replace(strSafeFilePath, "?", "")
strSafeFilePath = Replace(strSafeFilePath, {"}, {})
strSafeFilePath = Replace(strSafeFilePath, "<", "")
strSafeFilePath = Replace(strSafeFilePath, ">", "")
strSafeFilePath = Replace(strSafeFilePath, "|", "")
MakeSafeForFilePath = strSafeFilePath
End Function
Function IsArrayEmpty( strAnArr As Variant ) As Boolean
Dim blIsArrayEmpty As Boolean
On Error Goto errH
Dim intUbound As Integer
blIsArrayEmpty = False ' default to false, ie it is not empty
If Isarray( strAnArr ) Then
intUbound = Ubound( strAnArr ) ' raises error 200 if not initialized
End If ' isarray
Goto theEnd
errH:
If Err = 200 Then ' uninitialized dynamic array
'( it's actually an array, but does not have a single value in it
blIsArrayEmpty = True
Else
Error 1000, "Unexpected error n°" + Cstr(Err) + " while testing array in IsArrayEmpty function"
End If
Resume theEnd
theEnd:
IsArrayEmpty = blIsArrayEmpty
End Function
Function GetIntegerFromRightOfString( strSource As String ) As Integer
Dim strNumberFromRight As String
Dim strRightChar As String
strRightChar = Right( strSource, 1)
While Isnumeric( strRightChar )
strSource = Left(strSource, Len( strSource)-1 )
strNumberFromRight = strRightChar + strNumberFromRight
strRightChar = Right( strSource, 1)
Wend
GetIntegerFromRightOfString = Cint( strNumberFromRight )
End Function
Function ProperCasePlus(strString As String) As String
Dim ReturnVal As Variant
Dim LowerCase As String
LowerCase = Lcase(strString)
ReturnVal = Evaluate("@ProperCase(" + Chr(34) + LowerCase + Chr(34) + ")")
' change so that a name with a ' in it has the next initial uppercase
' do Tony O'neil become Tony O'Neil
If Instr( ReturnVal(0), "'" ) > 0 Then
Dim strLeftBit As String
Dim strRightVal As Variant
Dim strRightBit As String
strLeftBit = Strleft(ReturnVal(0), "'")
strRightVal = Evaluate("@ProperCase(" + Chr(34) + Strright(ReturnVal(0),"'") + Chr(34) + ")")
strRightBit = strRightVal(0)
ReturnVal(0) = strLeftBit + "'" + strRightBit
End If
ProperCasePlus= ReturnVal(0)
End Function
Function GetTextAtPositionForCSV( strBigString, intPosToFind As Integer, strDelimeter As String ) As String
' Finds text at a certain position given the delimeter
' atk modified for Csv files.. ie checks for ,"
' that is comma double quote or double quote at the start
'atk modified 12/04/2005. Added + lenstrDelim-1
If strBigString = "" Then
GetTextAtPositionForCSV = ""
Exit Function
End If
Dim RightSide As String
Dim pos As Integer
Dim lastPos As Integer
Dim count As Integer
Dim NumberOfRightMostChars As Integer
'==========================================================
' Setup an array of any double quotes as these will affect our count of commas
' they will exist becuase a comma is inside them
'==========================================================
Dim strStartQuotes As String, strEndQuotes As String
Dim strStartQuotesArr As Variant, strEndQuotesArr As Variant
Dim posDoubleQuote As Integer
posDoubleQuote = 0
posDoubleQuote = Instr(1, strBigString, {"}) ' instr starts at 1, not 0
Do While posDoubleQuote > 0
' The start quote
strStartQuotes = strStartQuotes + Cstr(posDoubleQuote)+ ","
' The end quote
posDoubleQuote = Instr(posDoubleQuote+1, strBigString, {"})
If posDoubleQuote > 0 Then
strEndQuotes = strEndQuotes + Cstr(posDoubleQuote)+ ","
End If
posDoubleQuote = Instr(posDoubleQuote+1, strBigString, {"})
Loop
' remove the last comma
strStartQuotes = RemoveLastNChars(strStartQuotes, 1)
strEndQuotes = RemoveLastNChars(strEndQuotes, 1)
' put into an array
If strStartQuotes <> "" Then
strStartQuotesArr = Split( strStartQuotes, ",")
strEndQuotesArr = Split( strEndQuotes, ",")
End If
'==============================================================
' loop through the text again, this time looking for the commas
'==============================================================
lastPos = 0
pos = 1
Dim idxQuote As Integer ' the quote index
Dim blIgnoreThisComma As Boolean
blIgnoreThisComma = False
Dim v1 As Variant, v2 As Variant
'========================================================
' Get the first valid delimeter
'========================================================
pos = Instr ( pos, strBigString , strDelimeter )
' check if we have a valid one, or invalid, that is if it is in a quoted string
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Do While blIgnoreThisComma = True And pos > 0
blIgnoreThisComma = False
pos = Instr ( pos+1, strBigString , strDelimeter )
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Loop
' Get the start pos. Store in variable lastpos
' get the end pos . Store in variable po
Do While pos > 0 And count < intPosToFind-1
lastPos = pos
pos = Instr ( pos + 1, strBigString , strDelimeter )
' check if we are in a quoted section
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
If blIgnoreThisComma = True Then
Do While blIgnoreThisComma = True And pos > 0
blIgnoreThisComma = False
pos = Instr ( pos + 1, strBigString , strDelimeter )
' check if we are in a quoted section
idxQuote = 0
If Isarray(strStartQuotesArr) Then
Forall strStartDQuote In strStartQuotesArr
v1 = Cint(strStartDQuote)
v2 = Cint(strEndQuotesArr(idxQuote))
If pos > Cint(strStartDQuote) And pos < Cint(strEndQuotesArr(idxQuote)) Then
blIgnoreThisComma = True
End If ' pos
idxQuote = idxQuote + 1
End Forall
End If ' is array
Loop
End If
If pos > 0 Then
' valid, so update count
count = count + 1
End If
Loop
' If we found at least one of the substring then
' lastPos will be the start of the text we want,
' and pos will be the end
If lastPos > 0 Then
NumberOfRightMostChars = Len( strBigString ) - ( lastPos + Len(strDelimeter)-1 ) ' atk modified12/04/2005. Added + lenstrDelim-1
RightSide = Right( strBigString, NumberOfRightMostChars )
If pos > 0 Then
GetTextAtPositionForCSV = Left( RightSide, pos-lastPos-1 )
Else
GetTextAtPositionForCSV = RightSide
End If
Elseif lastPos = 0 And pos > 0 Then
' Must have been the first item in the string
GetTextAtPositionForCSV = Left( strBigString, pos -1 )
Elseif lastPos = 0 And pos = 0 And (intPosToFind = 0 Or intPosToFind = 1) Then
' must be the first item in the string, and no delimeters
GetTextAtPositionForCSV = strBigString
Else
GetTextAtPositionForCSV = ""
End If
' And remove any double quotes
GetTextAtPositionForCSV = Replace(GetTextAtPositionForCSV, {"}, "")
End Function
Function PerformDbLookupLS( view As NotesView, sKey As String , vFind As Variant ) As Variant
'==================================
' PerformDbLookupLS function
'==================================
On Error Goto MailError
' There is a perform db lookup function that uses @functions
' that has a limit of 64k... This one uses ls
Redim strReturnValuesArr( 0 ) As Variant
' keep the view order, use view entry collection
Dim vec As NotesViewEntryCollection
Set vec = view.GetAllEntriesByKey( sKey, True )
Dim ve As NotesViewEntry
If vec.Count <> 0 Then ' as Long as we have results...
Set ve = vec.GetFirstEntry()
Redim strReturnValuesArr( 0 To vec.Count-1 ) As Variant
Dim i As Integer
i = -1
If Typename( vFind ) = "STRING" Then
Do While Not ve Is Nothing
i = i + 1
strReturnValuesArr(i) = Join(ve.Document.GetItemValue(vFind),";")
Set ve = vec.GetNextEntry(ve)
Loop
Else
' we want a view column number. hmmmm
Do While Not ve Is Nothing
i = i + 1
strReturnValuesArr(i) =ve.ColumnValues(vFind-1) ' -1 as cols are 0 based
Set ve = vec.GetNextEntry(ve)
Loop
End If ' typename is string
End If ' vec = 0
PerformDbLookupLS = strReturnValuesArr
ExitPoint:
Exit Function
MailError:
' debug, send email
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim docMemo As New NotesDocument(db)
' debug, send email
docMemo.subject = "Error in PerformDbLookupLS function"
docMemo.body = "An error was incurred by " + session.EffectiveUserName + " using the db " + _
session.CurrentDatabase.Title + " in the agent " + session.CurrentAgent.Name + Chr(13) + Chr(13) + _
" Error" & Str(Err) & " Line " & Str(Erl) & " : " & Error$ + Chr(13) + Chr(13) + _
Chr(10) + "Current function=" + Lsi_info(2) + _ ' The current function or sub
Chr(10) + "Current module=" + Lsi_info(3) + _ ' The current module
Chr(10) + "LS Version=" + Lsi_info(6) + _ ' The version of LotusScript running
Chr(10) + "Current Langugage=" + Lsi_info(9) +_ ' Current language (en for english)
Chr(10) + "Caller function=" + Lsi_info(12) ' The name of the function that called this one, "the caller"
Call docMemo.Send(False, "Domino Admin")
' end debug
Resume ExitPoint
End Function ' PerformDbLookupLS
Function getFieldString(doc As NotesDocument, fieldName As String) As String
getFieldString = ""
If doc Is Nothing Then Exit Function
If Not doc.HasItem(fieldName) Then Exit Function
getFieldString = Cstr(doc.GetFirstItem(fieldName).values(0))
End Function
Function StripHTML (strSource As String, bool_StripOrphans As Boolean) As String
%REM
This function will strip HTML tags from a passed in string,
and return the resulting string.
Orphan Tags ("<" & ">") will be handled based on the value of bool_StripOrphans.
The Orphan Tags will be removed if bool_StripOrphans is True,
and will be ignored otherwise.
%END REM
Dim intPosOpen As Integer
Dim intPosClose As Integer
Dim strTarget As String
strTarget$ = strSource
If bool_StripOrphans Then
' Strip out Orphan Tags
Do
intPosOpen% = Instr(strTarget$, "<")
intPosClose% = Instr(strTarget$, ">")
If intPosOpen% < intPosClose% Then
' Either the first open indicator occurs prior to the first close indicator,
' or doesn't exist at all.
If intPosOpen% = 0 Then
' The first open indicator doesn't exist.
' If the Orphan close indicator exists, then strip it out.
If (intPosClose% > 0) Then strTarget$ = StripFirstSubstr(strTarget$, ">")
Else
' The first open indicator exists, and occurs prior to the first close indicator.
' THIS INDICATES STANDARD MARKUP. STRIP IT OUT
strTarget$ = StripFirstSubstr(strTarget$, Mid$(strTarget$, intPosOpen%, (intPosClose% - intPosOpen%) + 1))
End If ' intPosOpen% = 0
Else
' Either the first close indicator occurs prior to the first open indicator,
' or doesn't exist at all.
If intPosClose% = 0 Then
' The first close indicator doesn't exist.
' If the Orphan open indicator exists, then strip it out.
If (intPosOpen% > 0) Then strTarget$ = StripFirstSubstr(strTarget$, "<")
Else
' The first close indicator occurs prior to the first open indicator,
' and is therefore an Orphan. Strip it out.
strTarget$ = StripFirstSubstr(strTarget$, ">")
End If 'intPosClose% = 0
End If ' intPosOpen% < intPosClose%
Loop While ((intPosOpen% + intPosClose%) > 0)
Else
' Orphan tags are to be ignored.
Do
intPosOpen% = Instr(strTarget$, "<")
If intPosOpen% > 0 Then
' An open indicator exists. Find the subsequent close indicator
intPosClose% = Instr(intPosOpen, strTarget$, ">")
Else
' No open indicator exists. Set the close position to zero and bail out.
intPosClose% = 0
End If ' intPosOpen% > 0
If intPosClose% > intPosOpen% Then
' The first open indicator exists, and occurs prior to the first close indicator.
' THIS INDICATES STANDARD MARKUP. STRIP IT OUT
strTarget$ = StripFirstSubstr(strTarget$, Mid$(strTarget$, intPosOpen%, (intPosClose% - intPosOpen%) + 1))
Else
' No close indicator exists. Set the open position to zero and bail out.
intPosOpen% = 0
End If ' intPosClose% > intPosOpen%
Loop While ((intPosOpen% + intPosClose%) > 0)
End If ' bool_StripOrphans
StripHTML$ = strTarget$
End Function ' StripHTML
Function StripFirstSubstr (strSource As String, strSubstr As String) As String
%REM
This function strips the first occurence of a substring from a string,
and returns the result.
If the substring is not contained within the source string,
this function returns the source string.
%END REM
If (Instr(strSource$, strSubstr$) > 0) Then
StripFirstSubstr$ = Strleft(strSource$, strSubstr$) & Strright(strSource$, strSubstr$)
Else
StripFirstSubstr$ = strSource$
End If ' (Instr(strSource$, strSubstr$) > 0)
End Function ' StripFirstSubstr
No comments:
Post a Comment