NotesRegistration Lotusscript function for create ft index - lotus-notes

My main purpose is to create a user into names.nsf on website, which only "admin" account can do the registration for user.
The admin account have right to call web agent below is attached photo of setting
I have problem on
1. createftindex = mail ftindex not functioning
2. grouping = possible to add two group? for example [Everyone] group and [software] group
Does my coding part for below this is wrong?
reg.Mailcreateftindex=True
reg.Grouplist="Everyone"
Option Public
Option Declare
Sub Initialize
' this agent use on [register] button locate on [request form] xpages
Dim s As New NotesSession, db As NotesDatabase, a As NotesAgent
Dim doc As NotesDocument
Set db = s.Currentdatabase
Set a = s.Currentagent
Set doc = s.Documentcontext ' uidoc
Dim certid As String ' full path of cert id
Dim certpasswd As String
Dim OU As String
Dim lastname As String
Dim firstname As String
Dim middleinit As String
Dim usrIdpath As String
Dim mailsvr As String
Dim mailfile As String
Dim userpasswd As String
Dim internetpath As String
Dim userID As String
Dim depvw As NotesView, depdoc As NotesDocument
Set depvw = db.Getview("Department sort by dept")
Set depdoc = depvw.Getdocumentbykey(doc.Dept(0), True)
If Not depdoc Is Nothing Then
certid = depdoc.IdPath(0) ' full path of cert id
certpasswd = depdoc.IdPassword(0) ' Cert id password(password)
OU = "" 'depdoc.Dept(0) ' Application (department to register)
lastname= doc.Name(0) ' current document selected mail (person)
firstname = "" ' [din't used]
middleinit = "" ' [din't used]
usrIdpath = depdoc.DptIdStor(0) +doc.SelectMail(0)+ ".id" ' user path
' id cannot have . in between for example, test1.Apple
' remove "." replace with empty and remove the empty space
userID = remapChr(doc.SelectMail(0))
mailsvr = depdoc.MailSvr(0) ' mail svr
' Mail file name also cannot have . in between for example, mail/test1.apple, reason window not understand it
mailfile = depdoc.MailLocation(0)+userID ' Mail\Person
userpasswd= depdoc.UserPassword(0) ' User password
internetpath = doc.SelectMail(0)+depdoc.InternetPath(0) ' mail address
End If
Dim reg As New NotesRegistration
Dim dt As Variant
dt = DateNumber(Year(Today)+1, Month(Today), Day(Today))
reg.RegistrationServer = mailsvr '"CN=ServerOne/O=dev"
reg.CreateMailDb = True '
reg.CertifierIDFile = certid '"C:\IBM\Domino\data\office.id"
reg.Expiration = dt
reg.IDType = ID_HIERARCHICAL
reg.MinPasswordLength = 1 ' password strength
reg.IsNorthAmerican = True
reg.OrgUnit = OU ' "" empty ..will just follow certid registration
reg.RegistrationLog = "log.nsf"
reg.UpdateAddressBook = True
reg.StoreIDInAddressBook = True
reg.MailInternetAddress = internetpath '"desmond#devsv1.pcs.com.my"
reg.Shortname=userID ' 'Set shortname []
reg.Mailowneraccess =2 ' '[editor access]
reg.Mailcreateftindex=True ' '[Indexing]
reg.Mailaclmanager ="LocalDomainAdmins" ' 'Add LocalDomainAdmins into mail acl
reg.Grouplist="Everyone" ' 'Everyone
Call reg.RegisterNewUser(lastname, _ ' last name
usridpath, _ '"C:\IBM\Domino\data\ +name+.id" ' file to be created
mailsvr, _ '"CN=ServerOne/O=dev" ' mail server
firstname, _ ' ' first name
middleInit, _ ' ' middle initial
certpasswd, _ '"office" ' certifier password
"", _ ' location field
"", _ ' comment field
mailfile, _ '"mail\person.nsf" ' mail file
"", _ ' Forwarding domain
userpasswd, _ '"password", _ ' user password
NOTES_DESKTOP_CLIENT) ' user type
' call name nsf and open for edit for forcing user must change password first time
Dim ndb As NotesDatabase
Dim viwUser As NotesView
Dim docUser As NotesDocument
Set ndb = New NotesDatabase( mailsvr, "names.nsf" )
Set viwUser = ndb.GetView("People by Email")
Set docUser = viwUser.GetDocumentByKey(userID,True)
Call docUser.ReplaceItemValue( "HTTPPasswordForceChange" , "1" )
Call docUser.Save( True, True, True )
Print "Please wait ...... Registration in progress"
End Sub
Function remapChr (oldString)
' to replace all special character with a empty space after that trim to remove all special character in system
Dim oldChr, newChr, newString As String
oldChr = {! "" # $ % & ' ( ) * + , - . / : ; = > ? # [ \ ] ^ _}
newChr = " {"
oldChr = Split(oldChr, " ")
newChr = Split(newChr, " ")
newString = Trim(Replace(LCase(oldString), oldChr, newChr))
remapChr = newString
End Function

Related

Finding a phrase in a string variable

I am trying to find a phrase inside of a variable that contains html. I then want to replace it with a new phrase.
I tried InStr but the phrase is not found. I also tried using wildcards at tht beginning and end of the phrase. I also tried doing an if like also with and without wildcards.
The purpose is to allow a tester to do a batch change on expected results and/or test steps by entering a sentence or phrase they want changed.
The only problem I'm having is being able to programmatically find the sentence within the variable.
Problem area is in bold
Dim qcURL As String
Dim qcID As String
Dim qcPWD As String
Dim qcDomain As String
Dim qcProject As String
Dim preActVal As String
Dim postActVal As String
Dim FindSt As String
Dim currentString As String
Dim thisSheet As Worksheet
'Toggle debugging mode'
Dim isDebugOn As Boolean
isDebugOn = True 'set to true to turn off Active X
''On Error GoTo ErrHandler:
FOLDER_PATH = "BAT\PC2P - Claims - Med"
Set thisSheet = ThisWorkbook.Sheets("ShellUpdater")
TestID = thisSheet.Range("B1").Value
stField = thisSheet.Range("B2").Value
**FindSt = thisSheet.Range("B3").Value**
ReplaceSt = thisSheet.Range("B4").Value
testLocation = thisSheet.Range("B5").Value
'ActiveX Forms
If isDebugOn = False Then
'qcURL = GetOptionMetric("qcURL", 1, "Enter ALM URL") ''popup to get url from user
qcURL = "<<URL>>"
'qcDomain = GetOptionMetric("qcDomain", 1, "Enter your ALM Domain")
''popup to get domain from user
qcDomain = "<<DOMAIN>>"
'qcProject = GetOptionMetric("qcProject", 1, "Enter your ALM Project")
''popup to get project from user
qcProject = "<<PROJECT>>"
qcID = GetOptionMetric("qcID", 1, "Enter your ALM MSID")
qcPWD = GetOptionPassword("qcPWD", 1, "Enter your ALM Password")
Else
qcURL = "<<URL>>"
qcID = "<<USERNAME>>"
qcDomain = "<<DOMAIN>>"
qcProject = "<<PROJECT>>"
qcPWD = InputBox("THIS IS IN DEEBUG MODE")
If qcPWD = vbNullString Then Exit Sub
If qcPWD = "" Then Exit Sub
End If
'END ActiveX Forms
'Connect to ALM
Set tdConnection = CreateObject("TDApiOle80.TDConnection")
tdConnection.InitConnectionEx qcURL
tdConnection.Login qcID, qcPWD
tdConnection.Connect qcDomain, qcProject
''Check if batch updating or single case
Dim testObject As ITest
If InStr(TestID, "All") > 0 Then
Dim TestFact As testFactory
Set tMng = tdConnection.TreeManager
Set srcFolder = tMng.NodeByPath("Subject\" & testLocation)
Set tstFact = srcFolder.testFactory
Set tstList = tstFact.NewList("")
For Each shellTest In tstList
Set DSFact = shellTest.DesignStepFactory.NewList("")
For Each dStep In DSFact
Select Case stField
Case "StepExpectedResult"
**currentString = dStep.StepExpectedResult**
**stposition = InStr(currentString, FindSt)**
If stposition > 0 Then
dStep.StepExpectedResult = preActVal & Replace(currentString, FindSt, ReplaceSt) & postActVal
End If
Case "StepDescription"
currentString = dStep.StepDescription
stposition = InStr(currentString, FindSt)
If stposition > 0 Then
dStep.StepDescription = preActVal & Replace(currentString, FindSt, ReplaceSt) & postActVal
End If
End Select
dStep.Post
Next dStep
Next shellTest
Else
Dim myTest
'Find the Test in test plan
Set thisTest = GetTest(Trim(TestID), testLocation, "\")
Set myTest = tdConnection.testFactory.Item(TestID)
End If
Try this:
Sub replace_string()
FindSt = "but also need rendering provider first name"
ReplaceString = "I LIKE BANANAS"
currentString = "All fields populate from the correctly populated provider<<<\!Renderingproviderlastname>>>, but also need rendering provider first name"
stPosition = Replace(currentString, FindSt, ReplaceString)
MsgBox stPosition
End Sub

Error Sending automation mail after registration using lotus script

Question:
1. My question why after registration of an user still not listed in domino directory?
Case:
I am using xPages form call lotus script agent.
All my script is using lotus script to register an user.
After Complete register an email, need to send automation notification mail to user as welcome mail.
when i complete registration, i want to send mail, it give me an error message:
1.unable to deliver message 'ChunWH#devsvr1.pcs.com.my'
2.User 'ChunWH#devsvr1.pcs.com.my' not listed in Domino Directory
Register user Agent
Option Public
Option Declare
Sub Initialize
On Error GoTo ErrorHandler
Dim s As New NotesSession, db As NotesDatabase, a As NotesAgent
Dim doc As NotesDocument
Set db = s.Currentdatabase
Set a = s.Currentagent
Set doc = s.Documentcontext ' uidoc
Dim maildoc As NotesDocument, body As NotesMIMEEntity
Dim stream As NotesStream
Dim groups
groups = Null
groups = group(groups,"Everyone")
Dim certid As String ' full path of cert id
Dim certpasswd As String
Dim OU As String
Dim lastname As String
Dim firstname As String
Dim middleinit As String
Dim usrIdpath As String
Dim mailsvr As String
Dim mailfile As String
Dim userpasswd As String
Dim internetpathLength As String
Dim internetpath As String
Dim remapuserID As String
Dim depvw As NotesView, depdoc As NotesDocument
Set depvw = db.Getview("Department sort by dept")
Set depdoc = depvw.Getdocumentbykey(doc.Dept(0), True)
If Not depdoc Is Nothing Then
certid = depdoc.IdPath(0)
certpasswd = depdoc.IdPassword(0)
OU = ""
lastname= doc.Name(0)
firstname = ""
middleinit = ""
usrIdpath = depdoc.DptIdStor(0) +doc.SelectMail(0)+ ".id"
' remove "." replace with empty and remove the empty space
remapuserID = remapChr(doc.SelectMail(0)) ' this is remapuserID
mailsvr = depdoc.MailSvr(0) ' mail svr
' Mail file name also cannot have . in between for example, mail/test1.apple, reason window not understand it
mailfile = depdoc.MailLocation(0)+ remapuserID ' Mail\Person
userpasswd= depdoc.UserPassword(0)
internetpath = doc.SelectMail(0)+depdoc.InternetPath(0) ' mail address
internetpathLength = Len(depdoc.InternetPath(0)) ' not used
End If
Dim reg As New NotesRegistration
Dim dt As Variant
dt = DateNumber(Year(Today)+1, Month(Today), Day(Today))
reg.RegistrationServer = mailsvr
reg.CreateMailDb = True '
reg.CertifierIDFile = certid
reg.Expiration = dt
reg.IDType = ID_HIERARCHICAL
reg.MinPasswordLength = 1
reg.IsNorthAmerican = True
reg.OrgUnit = OU
reg.RegistrationLog = "log.nsf"
reg.UpdateAddressBook = True
reg.Storeidinaddressbook = false
reg.MailInternetAddress = internetpath
reg.Shortname=doc.SelectMail(0)
reg.Mailowneraccess =2
reg.Mailcreateftindex=True
reg.Mailaclmanager ="LocalDomainAdmins"
reg.Grouplist=groups
Call reg.RegisterNewUser(lastname, _
usridpath, _
mailsvr, _
firstname, _
middleInit, _
certpasswd, _
"", _
"", _
mailfile, _
"", _
userpasswd, _
NOTES_DESKTOP_CLIENT)
Dim acl As NotesACL
Dim aclEntry As NotesACLEntry
Dim dbUser As NotesDatabase
Set dbUser = New NotesDatabase(mailsvr,mailfile) ' mail/person.nsf
Set acl = dbUser.aCL
Set aclEntry = acl.Getentry( "LocalDomainAdmins" )
If Not (aclEntry Is Nothing) Then
aclEntry.UserType = ACLTYPE_PERSON_GROUP
Call acl.Save()
End if
' call name nsf and open for edit for forcing user must change password first time
Dim ndb As NotesDatabase
Dim viwUser As NotesView
Dim docUser As NotesDocument
Set ndb = New NotesDatabase( mailsvr, "names.nsf" )
Set viwUser = ndb.GetView("People by Email")
Set docUser = viwUser.GetDocumentByKey(doc.SelectMail(0),True)
Call docUser.ReplaceItemValue( "HTTPPasswordForceChange" , "1" )
Print "Force user change password is updated"
Call docUser.Save( True, True, True )
Print "Please wait ...... Registration in progress"
Call doc.Replaceitemvalue("S_Process", "Pending")
Call doc.Save(True, False)
Dim agt As NotesAgent
Set agt=db.getagent("(Welcome Mail)")
Call agt.Runonserver()
EndOfRoutine:
Exit Sub 'or exit function
ErrorHandler:
Print Err & ", " & Error & " in line " & Erl
Resume EndOfRoutine
End Sub
Function remapChr (oldString)
' to replace all special character with a empty space after that trim to remove all special character in system
Dim oldChr, newChr, newString As String
oldChr = {! "" # $ % & ' ( ) * + , - . / : ; = > ? # [ \ ] ^ _}
newChr = " {"
oldChr = Split(oldChr, " ")
newChr = Split(newChr, " ")
newString = Trim(Replace(LCase(oldString), oldChr, newChr))
remapChr = newString
End Function
Function group(groupArr, newReason$)
If IsArray(groupArr) Then
If groupArr(0) = "" Then
groupArr(0) = newReason
Else
Dim counter%
counter = UBound(groupArr) + 1
ReDim Preserve groupArr(counter)
groupArr(counter) = newReason
End If
group = groupArr
Else
Dim tempgroupArr() As String
ReDim tempgroupArr(0)
tempgroupArr(0) = newReason
group = tempgroupArr
End If
End Function
Sending mail Agent
Sub Initialize
On Error GoTo ErrorHandler
Print "Welcome Mail Agent started..."
' This agent is a sub agent for register user, which let register agent call
Dim s As New NotesSession, db As NotesDatabase, a As NotesAgent
Dim doc As NotesDocument
Set db = s.Currentdatabase
Set a = s.Currentagent
Set doc = s.Documentcontext ' uidoc
Dim maildoc As NotesDocument, body As NotesMIMEEntity
Dim stream As NotesStream
Dim receiver$
Dim tmpallve As NotesViewEntry
Dim viwUser As NotesView
Dim viwVe As NotesViewEntry
Dim viwVc As NotesViewEntryCollection
Dim docUser As NotesDocument
Set viwUser = db.GetView("(Request sort by S_Process)")
'Set docUser = viwUser.GetDocumentByKey("Pending",True)
Set viwVc = viwUser.Allentries
If viwVc.Count = 0 Then
Print "No item found in this list"
Exit Sub
End If
Set viwVe = viwVc.Getfirstentry()
Do While Not viwVe Is Nothing ' loop to all entry
Set docUser = viwVe.Document
receiver$ = docUser.SelectMail(0) + "#devsvr1.pcs.com.my"
' send mail
Set maildoc = db.Createdocument()
Call maildoc.Replaceitemvalue("Form", "Memo")
Call maildoc.Replaceitemvalue("Subject", "Welcome")
Call maildoc.Replaceitemvalue("SendTo", receiver)
Set body = maildoc.Createmimeentity
s.Convertmime = False
Set stream = s.Createstream()
stream.Writetext(|<html><body>|)
stream.Writetext(|<p>Your application for registration ....</p>|)
stream.Writetext(|<p>Welcome. Pleaase....</p>|)
stream.Writetext(|<p><em>(No signature requried on this computer generated document)</em></p>|)
stream.Writetext(|<p>*** This is a system generated email. | + _
|Please do not reply to this email. ***</p>|)
Call stream.Writetext(|</body></html>|)
Call body.Setcontentfromtext(stream, "text/html;charset=UTF-8", 1725)
Call maildoc.Send(False)
s.Convertmime = True
Call docUser.Replaceitemvalue("S_Process", "Processed")
Call docUser.Save(True, False)
Set tmpallve = viwVc.Getnextentry(viwVe)
Set viwVe = tmpallve
Loop
Print "Welcome Mail Agent finished..."
EndOfRoutine:
Exit Sub 'or exit function
ErrorHandler:
Print Err & ", " & Error & " in line " & Erl
Resume EndOfRoutine
End Sub
new update of image on 25/09/2017
(after set config router_debug=3 set config DebugRouterLookup=3 )
i try send manually will be fine...but using code directly send after registration will be fail. Not only that, i also try on sleep(2) , wait 2 second just send mail..it seem like my thought of not directly create mail account mail also not valid..not sure which part is wrong?
I suspect that your issue is one of time and caching. The Domino server maintains a Name Lookup Cache that only gets refreshed, well, occasionally (I have never figured out how occasionally that is but 5-10 minutes generally does the trick). This affects both the email functions and the web login functions. What I have done with my registration systems is have the agent that does the ID creation leave a document in it database that is in the status "Pending welcome email". Then another agent finds those docs and if they are more then 15 minutes old it attempts the email. if the email goes through then the status is changed to "Complete".
Note, you can reset the cache with the console command show nlcache reset and that almost always results in the user being able to get mail and login from a browser. But I have not been able to get that to work from a scheduled agent run on the server or a web agent.
Can you take a look at the Person Document? See if that address is properly registered on the document.
You may also try to enable router_debug=3 and DebugRouterLookUp=3 and we may see where did it try to lookup the address.

force notes user to change password / internet password on next login using lotus script

Actually i already create an agent to create user ID with default password. I want to force user change the internet password and Notes ID password for the next login. Is there a way using lotus script method to change it? or Admin still need to go each of the user profile to tick that function.
Here is my agent code that create ID
Sub Initialize
' this agent use on [register] button locate on [request form] xpages
Dim s As New NotesSession, db As NotesDatabase, a As NotesAgent
Dim doc As NotesDocument
Set db = s.Currentdatabase
Set a = s.Currentagent
Set doc = s.Documentcontext ' uidoc
Dim certid As String 'full path of cert id
Dim certpasswd As String
Dim OU As String
Dim lastname As String
Dim firstname As String
Dim middleinit As String
Dim usrIdpath As String
Dim mailsvr As String
Dim mailfile As String
Dim userpasswd As String
Dim internetpath As String
Dim depvw As NotesView, depdoc As NotesDocument
Set depvw = db.Getview("Department sort by dept")
Set depdoc = depvw.Getdocumentbykey(doc.Dept(0), True)
If Not depdoc Is Nothing Then
certid = depdoc.IdPath(0) ' full path of cert id
certpasswd = depdoc.IdPassword(0) ' Cert id password(password)
OU = "" '
lastname= doc.Name(0) ' current document selected mail (person)
firstname = "" ' [din't used]
middleinit = "" ' [din't used]
usrIdpath = depdoc.DptIdStor(0) +doc.SelectMail(0)+ ".id" ' user path
mailsvr = depdoc.MailSvr(0) ' mail svr
mailfile = depdoc.MailLocation(0)+doc.SelectMail(0) ' Mail\Person
userpasswd= depdoc.UserPassword(0) ' User password
internetpath = doc.SelectMail(0)+depdoc.InternetPath(0) ' mail address
End If
Dim reg As New NotesRegistration
Dim dt As Variant
dt = DateNumber(Year(Today)+1, Month(Today), Day(Today))
reg.RegistrationServer = mailsvr '"CN=ServerOne/O=dev"
reg.CreateMailDb = True '
reg.CertifierIDFile = certid '"C:\IBM\Domino\data\office.id"
reg.Expiration = dt
reg.IDType = ID_HIERARCHICAL
reg.MinPasswordLength = 1 ' password strength
reg.IsNorthAmerican = True
reg.OrgUnit = OU ' "" empty ..will just follow certid registration
reg.RegistrationLog = "log.nsf"
reg.UpdateAddressBook = True
reg.StoreIDInAddressBook = True
reg.MailInternetAddress = internetpath
Call reg.RegisterNewUser(lastname, _ ' last name
usridpath, _ '"C:\IBM\Domino\data\ +name+.id" ' file to be created
mailsvr, _ '"CN=ServerOne/O=dev" ' mail server
firstname, _ ' first name
middleInit, _ ' middle initial
certpasswd, _ '"office" ' certifier password
"", _ ' location field
"", _ ' comment field
mailfile, _ '"mail\person.nsf" ' mail file
"", _ ' Forwarding domain
userpasswd, _ '"password", _ ' user password
NOTES_DESKTOP_CLIENT) ' user type
Print "Please wait ...... Registration in progress"
End Sub
Question 1: how to force user change notes password next login
Question 2: how to force user change internet password next login
Question 3: Is it possible every times create a notes ID will auto save to ID vault? For my understanding, ID vault is a database that store all ID in. If i am wrong, please let me know. Thanks!
Not sure reg ID Vault, but for password change, I think you can just set the field HTTPPasswordForceChange = "1"?
I answered your question no 2 in your other question.
Question 1 and 3 are closely related:
First of all set up an ID- Vault in your domain. It really is a MUST HAVE nowadays in domino. And it is a easy 1-2-3 step when following the administrator help. After setting up the vault the ID will automatically be uploaded to it as soon as you register users for a certifier that has the vault assigned via hierarchical policy.
That said: I would NEVER store user ids in the address book as EVERYBODY can access it from there and pretend to be that user (given he can quess your default password / the given password).
To force a user to change the Notes- password after first login I also use the id vault: Whenever you change a users' password using the vault it will automatically force the user to change it after the next login:
And it is a simple one-line- code:
Call s.Resetuserpassword( mailsvr, "CN=User/O=dev", userpasswd )
The hardest thing here is to get the rights correct in your vault (set the option to be allowed to use the vault programmatically for the signer of your code and the agent it runs on)

NotesReplicationEntry - Lotus Notes

I am trying to set Selective Replication using LotusScript but I cannot get it to save. The log shows no errors and the script completes without error. The replica gets created but not with my Selective Replication set.
%REM
Agent createRenewalDB
Created Dec 14, 2016 by
Description: Comments for Agent
%END REM
Option Public
Use "xxx Routines"
Sub Initialize
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim s As New NotesSession
Dim flag As Boolean
Dim renDb As NotesDatabase
Dim renFP As String
Dim renHubDb As NotesDatabase
Dim sQuote As String
Dim nowt As String
Dim pos As Long
Dim client As String
Dim frm As String
Dim L As Long
Dim P1 As String
Dim P2 As String
Dim item As NotesItem
Dim renYN As String
Dim agent As NotesAgent
Set agent = s.CurrentAgent
Print("createRenewalDB starting")
Set db = s.Currentdatabase
Set doc = db.GetDocumentByID(agent.ParameterDocID)
'Print("got doc")
client = doc.getItemValue("Client")(0)
nowt = ""
sQuote = """"
pos = 1
Dim tmp1 As String
'Print("set vars")
tmp1 = doc.getItemValue("SearchFormula")(0)
'Print("got search formula")
frm = StrLeft(StrRight(tmp1,"ix_client;"),")")
'### strip out quotation marks
Do Until pos = 0
L = Len(frm)
pos& = InStr(1,frm,sQuote)
If pos <> 0 Then
P1 = Left(frm,pos - 1) ' Part 1 of the text string
P2 = Right(frm,L- pos )
frm = P1 & nowt & P2
End If
Loop
'Print("stripped out the rubbish")
'#### Setup a new Renewals document if none exixts and Renewals has been selected
Set item = doc.getfirstitem("EnabledApps")
renYN = item.text
If InStr(renYN, "32") > 0 Then
'##### Get the Renewals Quotes Db
Set renHubDb = Get_Specific_Db_Object("Renewal Quotes", "xxx-01")
If renHubDb Is Nothing Then
MsgBox("Fail: Could not get the Renewals Quotes database on Hub, exiting renewals created.")
Exit Sub
End If
renFP = doc.getItemvalue("Renewals")(0)
'Msgbox("Renewals to be set up " + renFP)
Set renDb = s.GetDatabase("",renFP,False)
If renDb Is Nothing Then '#### No replica, so create one
Print("Creating a replica for " + client)
Set renDb = renHubDb.CreateReplica("xxx-01",renFP)
renDb.Title = client
Dim rep As NotesReplication
Dim re As NotesReplicationEntry
Dim server As String
server = "xxx-xxx-01"
Set rep = renDb.ReplicationInfo '## Get the replication info
Set re = rep.GetEntry("-",server,True) '## get the replication entry - true creates it
re.Formula = "SELECT #Contains(client;" &"""" & frm & """" & ")" '## add the selective replication
Print("selective replication formula " + re.Formula)
'## save both
Call re.Save
Call rep.Save()
Print(re.Formula) '## formula is still set correctly at this point
End If
If renDb Is Nothing Then
MsgBox("Could not create a replicate for " + client)
Exit Sub
End If
Else
MsgBox("No Renewals " + renYN)
End If
Print("###########################################Finished creating the replica - agent")
End Sub
Any thoughts?
Lotus Notes 9.0.1
Lotus Domino 9.0.1
Code is in an agent that has Full Admin Access Set on the Security Tab.
Thanks
Graeme

Lotus Notes Agent - Remove Embedded Images?

I have an agent someone shared years ago which takes attached files, saves them to my hard drive, and removes them from the email. I use it to keep my emails for a while but stay under my corporate mailbox quota. I get a LOT of attachments.
I'm now finding that a lot of the remaining large emails have embedded images rather than "attached files". Can anyone share a script that would actually be able to do the same (save to hard drive, remove from email) with an embedded image?
FWIW, here is the agent I use for detaching attachments. Props to original author, don't know who that was.
Dim sDir As String
Dim s As NotesSession
Dim w As NotesUIWorkspace
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Dim doc As NotesDocument
Sub Initialize
Set s = New NotesSession
Set w = New NotesUIWorkspace
Set db = s.CurrentDatabase
Set dc = db.UnprocessedDocuments
Set doc = dc.GetFirstDocument
Dim rtItem As NotesRichTextItem
Dim RTNames List As String
Dim DOCNames List As String
Dim itemCount As Integer
Dim sDefaultFolder As String
Dim vtDir As Variant
Dim iCount As Integer
Dim j As Integer
Dim lngExportedCount As Long
Dim attachmentObject As Variant
Dim text As String
Dim subjectLine As String
Dim attachmentMoved As Boolean
' Prompt the user to ensure they wish to continue extracting the attachments
Dim x As Integer
x = Msgbox("V4 This action will extract all attachments from the " & Cstr (dc.Count) & " document(s) you have selected, and place them into the folder of your choice." & _
Chr(10) & Chr(10) & "Would you like to continue?", 32 + 4, "Export Attachments")
If x <> 6 Then Exit Sub
' Set the folder where the attachments will be exported
sDefaultFolder = s.GetEnvironmentString("LPP_ExportAttachments_DefaultFolder")
If sDefaultFolder = "" Then sDefaultFolder = "F:"
vtDir = w.SaveFileDialog( False, "Export attachments to which folder?", "All files|*.*", sDefaultFolder, "Choose Folder and Click Save")
If Isempty(vtDir) Then Exit Sub
sDir = Strleftback(vtDir(0), "\")
Call s.SetEnvironmentVar("LPP_ExportAttachments_DefaultFolder", sDir)
' Loop through all the selected documents
While Not (doc Is Nothing)
iCount = 0
itemCount = 0
lngExportedCount = 0
Erase RTNames
Erase DocNames
' Find all of the RichText fields in the current document. If any have an embedded object, add the item to the RTNames array.
Forall i In doc.Items
If i.Type = RICHTEXT Then
If Not Isempty(i.EmbeddedObjects) Then
'Msgbox i.Name,64,"Has embedded objects"
End If
Set rtItem = doc.GetfirstItem(i.Name)
'Set rtItem = i
If Not Isempty(rtItem.EmbeddedObjects) Then
RTNames(itemCount) = Cstr(i.Name)
itemCount = itemCount +1
End If
End If
End Forall
' Loop through the RTNames array and see if any of the embedded objects are attachments
attachmentMoved = False
For j = 0 To itemCount-1
Set rtItem = Nothing
Set rtItem = doc.GetfirstItem(RTNames(j))
Forall Obj In rtItem.EmbeddedObjects
If ( Obj.Type = EMBED_ATTACHMENT ) Then
' The embedded object is an attachment. Export it to the chosen directory
Call ExportAttachment(Obj)
' Append to the bottom of the file details on the extracted file and its new location.
Call rtItem.AddNewline(1)
Call rtitem.AppendText("---------------------------------------" + Chr(13) + Chr(10))
text = """" + sDir + "\"+ Obj.Name + """" + Chr(13) + Chr(10) + Chr(9) + "Extracted by: " + s.UserName + " on " + Str$(Today()) + ". "
Call rtitem.AppendText(text )
Call rtItem.AddNewline(1)
' Remove the object from the file and save the document.
Call Obj.Remove
Call doc.Save( False, True ) 'creates conflict doc if conflict exists
attachmentMoved = True
Else
Forall verb In Obj.Verbs
'Msgbox verb, 64, "VERB"
End Forall
End If
End Forall
' If the document had an attachment moved, update the subject line
If attachmentMoved = True Then
Dim item As Notesitem
Set item = doc.GetFirstItem("Subject")
subjectLine = item.Text + "- ATTACHMENT MOVED"
Set item = doc.ReplaceItemValue("Subject", subjectLine)
Call doc.Save( False, True ) 'creates conflict doc if conflict exists
End If
Next
Set doc = dc.GetNextDocument(doc)
Wend
Msgbox "Export Complete.", 64, "Finished"
End Sub
Sub ExportAttachment(o As Variant)
Dim sAttachmentName As String
Dim sNum As String
Dim sTemp As String
' Create the destination filename
sAttachmentName = sDir & "\" & o.Source
' Loop through until the filename is unique
While Not (Dir$(sAttachmentName, 0) = "")
' Get the last three characters of the filename - "_XX"
sNum = Right(Strleftback(sAttachmentName, "."), 3)
' Ensure the first of the three characters is an underscore and the next two are numeric. If they are, add one to the existing number and insert it back in.
If Left(sNum,1) = "_" And Isnumeric(Right(sNum, 2)) Then
sTemp = Strleftback(sAttachmentName, ".")
sTemp = Left(sTemp, Len(sTemp) - 2)
sAttachmentName = sTemp & Format$(Cint(Right(sNum,2)) + 1, "##00") & "." & Strrightback(sAttachmentName, ".")
Else
sAttachmentName = Strleftback(sAttachmentName, ".") & "_01." & Strrightback(sAttachmentName, ".")
End If
Wend
' Save the file
Call o.ExtractFile( sAttachmentName )
End Sub
This is very problematic to do with the script as it currently stands as MIME encoded images won't show up as any type of attachment using the EmbeddedObjects Property.
If the images are stored inline as part of a MIME message, the Notes client will turn them into an attachment for viewing, but programmatically the can only be accessed as parts of the MIME message. It should be achievable to grab the correct part of a multi-part MIME message with the image encoded (using the MIMEEntity classes), stream this out to disc and reconstitute the original file(s) then remove the MIMEEntity that represented it (and took up the space).
More info on the
IBM Support Site
NotesMIMEEntity Class Documentation

Resources