I have an agent in LotusScript that builds a neatly formatted table of document links and descriptions that functions as a monthly reminder digest. When I run it manually (Agent-Run), it sends a perfectly formed message that matches the code.
However, when I schedule the same agent, the output loses all of the table styling as well as the appended doclinks. This makes makes the outbound email useless. The server is in the ACL as Manager with all roles checked has the same/higher permissions than my ID. In agent properties, the Security settings are level 3 to allow restricted operations with full administration rights.
Option Public
Option Declare
Sub Initialize
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.currentdatabase
Dim docs, keydocs As NotesDocumentCollection
Dim keydoc, doc As NotesDocument
Dim dt As New NotesDateTime(Today)
Dim dtstr, key As String, svr As String, sendto As string
Dim mfgview, dptview As NotesView
Dim reldb As NotesDatabase
Set reldb = session.Getdatabase("Server", "db.nsf")
Dim relview As NotesView
Set relview = reldb.Getview("(Categorized docs-Rev_ob)")
Dim bkmdoc As notesdocument
Set mfgview = db.Getview("DutyRosterMaint") 'mfg dept
Set dptview = db.Getview("2-5 years dept") 'docs needed to be reviewed
Dim j, keydocct, keyct As Integer
Dim vardp, varnm As Variant
vardp = Evaluate({#DBColumn("":"Nocache";#DBName;"DutyRosterMaint"; 1)})'get dept name in array
keyct = UBound(vardp)
If keyct > 0 Then
Set keydoc = mfgview.GetFirstDocument
'Do Until keydoc Is Nothing
For j = 0 To keyct-1
key = vardp(j)
varnm = Evaluate({#DBLookup("":"Nocache";#DBName;"DutyRosterMaint";"}& key &{";2;[FailSilent])})
Set docs = dptview.Getalldocumentsbykey(key, true)
Dim dcct, i, cellnm As Integer
dcct = docs.count
If dcct>0 Then
Dim maildoc1 As New NotesDocument ( db )
Dim rtitem1 As New NotesRichTextItem ( maildoc1, "Body" )
Call rtitem1.AppendText ("Hello,")
Call rtitem1.AddNewLine ( 2)
Dim bodytxt As String
bodytxt = "This is an automated monthly email. "&_
"You are receiving this email because you are listed as the reviewer responsible for the documents below." &_
Chr$(13) & Chr$(13) &_
"The documents listed have not been revised in in 2 years (xx) or 5 years (all other types).Please determine if these documents are still necessary, accurate and suitable for use or coordinate with the appropriate individual to conduct the review." &_
Chr$(13) & Chr$(13) &_
"When done, the 'Set Review Date' button must be clicked on each document to reset the document review date. " &_
Chr$(13) & Chr$(13) &_
"If you have any questions or need assistance, please contact me or refer to BKM-0013 section VIII for additional guidance. " &_
Chr$(13) & Chr$(13) &_
"Thank you, "
Call rtitem1.AppendText (bodytxt)
Call rtitem1.AppendDocLink(bkmdoc, "xx-0013")
Call rtitem1.AppendText( " xx-0013")
Call rtitem1.AddNewLine ( 2)
Dim rtnav As NotesRichTextNavigator
Set rtnav = rtitem1.Createnavigator
Dim richStyle As NotesRichTextStyle
Set richStyle = session.CreateRichTextStyle
richStyle.Bold = True
richStyle.Underline = True
richStyle.FontSize = 12
Call rtitem1.Appendstyle(richStyle)
Call rtitem1.AppendText (key)
Set richStyle = session.CreateRichTextStyle
richStyle.Bold = False
richStyle.Underline = False
richStyle.FontSize = 10
Call rtitem1.Appendstyle(richStyle)
Call rtitem1.AddNewLine ( 1)
Dim rtt As NotesRichTextTable
Dim styles(0 To 5) As NotesRichTextParagraphStyle
'link
Set styles(0) = session.CreateRichTextParagraphStyle
styles(0).Alignment = 0
styles(0).Firstlineleftmargin = 0
styles(0).Leftmargin = 0
styles(0).RightMargin = RULER_ONE_CENTIMETER * 0.7
'approval date
Set styles(1) = session.CreateRichTextParagraphStyle
styles(1).Alignment = 0
styles(1).Firstlineleftmargin = 0
styles(1).Leftmargin = 0
styles(1).RightMargin = RULER_ONE_CENTIMETER * 2
'docnum
Set styles(2) = session.CreateRichTextParagraphStyle
styles(2).Alignment = 0
styles(2).Firstlineleftmargin = 0
styles(2).Leftmargin = 0
styles(2).RightMargin = RULER_ONE_CENTIMETER * 2
'title
Set styles(3) = session.CreateRichTextParagraphStyle
styles(3).Alignment = 0
styles(3).Firstlineleftmargin = 0
styles(3).Leftmargin = 0
styles(3).RightMargin = RULER_ONE_CENTIMETER * 7.5
'rev
Set styles(4) = session.CreateRichTextParagraphStyle
styles(4).Alignment = 0
styles(4).Firstlineleftmargin = 0
styles(4).Leftmargin = 0
styles(4).RightMargin = RULER_ONE_CENTIMETER * 0.8
'last editor
Set styles(5) = session.CreateRichTextParagraphStyle
styles(5).Alignment = 0
styles(5).Firstlineleftmargin = 0
styles(5).Leftmargin = 0
styles(5).RightMargin = RULER_ONE_CENTIMETER * 4
Set rtt = rtnav.Getfirstelement(RTELEM_Type_Table)
Call rtitem1.Appendtable(dcct+1, 6,,, styles)
maildoc1.Form = "Memo"
If varnm(0) = "" THen
maildoc1.SendTo = "Test"
Else
maildoc1.SendTo = varnm
End if
Dim devnm(2) As Variant
devnm(1) = "Test"
maildoc1.SendTo = devnm
maildoc1.CopyTO = "Test"
maildoc1.Subject = "Process Document Review Due for: " & key
Set doc = docs.Getfirstdocument()
'link
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 1)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Link")
Call rtitem1.EndInsert
'approval date
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 2)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Approval Date")
Call rtitem1.EndInsert
'docnum
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 3)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Doc Num")
Call rtitem1.EndInsert
'title
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 4)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Title")
Call rtitem1.EndInsert
'rev
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 5)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Rev")
Call rtitem1.EndInsert
'last editor
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , 6)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("Last Editor")
Call rtitem1.EndInsert
cellnm = 7
For i = 1 To dcct
If doc.Status(0) = "Approved" then
'link
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendDocLink(doc, doc.DocNum(0))
Call rtitem1.EndInsert
'approval date
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+1)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(doc.DisplayAppDate(0))
Call rtitem1.EndInsert
'docnum
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+2)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(doc.DocNum(0))
Call rtitem1.EndInsert
'title
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+3)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(doc.Subject(0))
Call rtitem1.EndInsert
'rev
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+4)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(CStr(doc.Revision(0)))
Call rtitem1.EndInsert
'last editor
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+5)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(doc.LastEditor(0))
Call rtitem1.EndInsert
Else
If doc.Revision(0) > 1 Then
Dim reldc As NotesDocument
Set reldc = relview.Getdocumentbykey(doc.DocNum(0), True)
If Not (reldc Is Nothing) Then
'link
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendDocLink(reldc, reldc.DocNum(0))
Call rtitem1.EndInsert
'approval date
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+1)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(reldc.DisplayAppDate(0))
Call rtitem1.EndInsert
'docnum
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+2)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText("*"&reldc.DocNum(0))
Call rtitem1.EndInsert
'title
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+3)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(reldc.Subject(0))
Call rtitem1.EndInsert
'rev
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+4)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(CStr(reldc.Revision(0)))
Call rtitem1.EndInsert
'last editor
Call rtnav.Findnthelement(RTELEM_TYPE_TABLECELL , cellnm+5)
Call rtitem1.Begininsert(rtnav)
Call rtitem1.AppendText(reldc.LastEditor(0))
Call rtitem1.EndInsert
End If
End If
End if
Set doc = docs.getnextdocument(doc)
cellnm = cellnm +6
Next
svr = UCase(db.Server)
If InStr(svr, "DEV") > 0 Or svr = "" Then
Call rtitem1.Addnewline(1)
If varnm(0) = "" Then
sendto = "Test"
Else
sendto = "Test"
End If
Call rtitem1.Addnewline(3)
Call rtitem1.AppendText( "-------------------------------------------------------------------------------------------------")
Call rtitem1.Addnewline(1)
Call rtitem1.AppendText( "Bypassed delivery for testing from being delivered to : " & sendto)
maildoc1.sendto = "Test"
Call maildoc1.Send( true )
Else
Call maildoc1.Send( true )
End If
End If
'Set keydoc = mfgview.getnextdocument(keydoc)
'Loop
next
MsgBox "Notifications have been sent successfully."
End If
End Sub
Related
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.
I have two databases: one holds the employee summary info, and the other one holds the serial number of the employee. On the database1, I have this agent that lets you import text file which contains updated records of the employee. But, In order for this agent to import a text file records successfully, the text file to be import must have a serial number record same as on the database2. It's working by the way, but I need to create a log when importing, still got no idea on how to resolve this. The logs(date imported, success and fail file imported) must be viewed on the fields. Can you help me out? Here's my code:
LoadAPMSAWDdoc
Sub LoadAPMSAWDdoc(Rname As Variant, directory As Variant, Datef As Variant)
Dim session As New NotesSession
Dim Tdoc As NotesDocumentCollection
Dim dateTime As New NotesDateTime ("01/01/2000")
'12/20/2005
Dim LocView As notesview
Dim LocDoc As NotesDocument
Dim subsidiary As String
Print "Loading APMSAWD - Award Information"
Set cdb = Session.CurrentDatabase
'12/20/2005
'StaffServerName = cdb.Server
Set LocView = cdb.GetView("LsvLocationProfile")
'02/07/2006
'Set LocDoc = LocView.getdocumentbykey(cdb.Server)
Set LocDoc = LocView.getfirstdocument
StaffServerName = LocDoc.z_ExtServer(0)
'SearchFormula$ = "Select Form = ""dfAward"" & #Date(s_Created) != #Date(#Today) "
If (ibmmy = True) And (ibmgdc = True) Then
SearchFormula$ = "Select Form = ""dfAward"" "
ElseIf (ibmmy = True) Then
SearchFormula$ = "Select Form = ""dfAward"" & I_GDCEmployee = ""IBM MY"""
Else
SearchFormula$ = "Select Form = ""dfAward"" & I_GDCEmployee = ""IBM GDC"""
End If
Set Tdoc = cdb.Search( SearchFormula$, DateTime, 0 )
If Tdoc.Count <> 0 Then
Call Tdoc.RemoveAll(True)
End If
'Get an unused file number
file_no% = Freefile()
Open (Trim(directory + "apmsawd.txt")) For Input As file_no%
Set db = Session.CurrentDatabase
Select Case Datef
Case "DMY" : Cdatf = "dd/mm/yyyy"
Case "MDY" : Cdatf = "mm/dd/yyyy"
Case "YMD" : Cdatf = "yyyy/mm/dd"
Case Else :
Print "LoadAPMSAWDdoc - Unknown system date format"
Exit Sub
End Select
Do While Not Eof(file_no%)
Line Input #file_no%, tmp
SerialNo = Trim$(Mid$(tmp,1,6))
AB = 0
For i = 29 To 0 Step -1
x1 = 8 + (i * 50)
x2 = 11 + (i * 50)
x3 = 41 + (i * 50)
x4 = 49 + (i * 50)
temp = Strconv(Trim$(Mid$(tmp,x2,30)),3)
If temp <> "" Then
Redim Preserve ACode(AB)
Redim Preserve ADes(AB)
Redim Preserve ADate(AB)
Redim Preserve AAmt(AB)
Acode(AB) = Trim$(Mid$(tmp,x1,3))
ADes(AB) = temp
If Trim$(Mid$(tmp,x3,8)) <> "" Then
AD1 = Setdate(Trim$(Mid$(tmp,x3,8)), "mm/dd/yy", Datef)
ADate(AB) = Cdat(Format(AD1, Cdatf))
'Datenumber ( Val(Trim$(Mid$(tmp,x3+6,2))) , Val(Trim$(Mid$(tmp,x3+3,2))) , Val(Trim$(Mid$(tmp,x3,2))) )
Else
ADate(AB) = Null
End If
AAmt(AB) = Val(Trim$(Mid$(tmp,x4,9)))
AB = AB + 1
Else
Exit For
End If
Next
subsidiary = Filter(CStr(SerialNo))
If (subsidiary = "AMY" And ammmy = True) Or (subsidiary = "ADC" And aaadc = True) Then
Set doc = New NotesDocument(db)
doc.Form = "dfAward"
doc.E_StaffSerialNo = SerialNo
doc.I_GDCEmployee = subsidiary
If AB = 0 And Trim$(Mid$(tmp,1461,30)) = "" Then
Redim Preserve ACode(AB)
Redim Preserve ADes(AB)
Redim Preserve ADate(AB)
Redim Preserve AAmt(AB)
ACode(0) = ""
ADes(0) = ""
ADate(0) = Null
AAmt(0) = Null
End If
doc.E_AwardType = ADes
doc.E_AwardDate = ADate
doc.E_AwardAmt = AAmt
doc.G_AuthorDisp = Rname
doc.s_created = Now
Call doc.Save (True, True)
End If
Loop
Close file_no%
Print "Award information imported"
End Sub
I'm sorry if I only posted some functions coz my code is too long and can't fit here.
First of all: It is VERY bad practice, to permanently delete all documents that match a search criteria just to directly afterwards add them back.
Deletion stubs will explode and this database will become slower and slower and at some point will not be usable anymore.
Better build a key to identify the document, get the document using the key and then update if necessary...
I usually build a list with all keys / unids (or documents, if there are not to much of them) and remove any document found in the "source" (text document in your case) from that list after processing.
Any document left in the list after running through the import file can be deleted...
Dim lstrUnids List as String
Set doc = Tdoc.GetFirstDocument()
While not doc is Nothing
lstrUnids( doc.E_StaffSerialNo(0) ) = doc.UniversalID
set doc = TDoc.GetNextDocument(doc)
Wend
But now back to your Question:
To write a simple Log you can use the NotesLog- Class. You can either log to a database (Template: Agent Log ), log to a mail or log to the Agents log (complicated to read) or even to a file.
Just do it like this:
Dim agLog as New NotesLog( "MyImportLog" )
Call agLog.OpenNotesLog( Server , logdbPath )
...
Call agLog.LogMessage( "Award information imported" )
...
Call agLog.Close() 'IMPORTANT !!!!
I need help writing some a loop to create a command button for every cell in a range.
I achieved creating as many buttons as I need. my problem is setting the .OnAction property for each of them.
Every button will send an email through Lotus Notes to a specified address, with subject and body of the mail stored in adjacent cells. That code already works, here it is the procedure to send the email:
Sub Send(ByVal MailAddress, Subject, Message As String)
Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
Set Session = CreateObject("Lotus.NotesSession")
Call Session.Initialize
'Call Session.Initialize("password")
UserName = Session.UserName
Set Maildb = Session.GetDatabase("", "C:\Lotus\Notes\Data\names.nsf")
'Set Maildb = Session.GetDatabase("", MailDbName)
If Not Maildb.IsOpen = True Then Call Maildb.Open
Set MailDoc = Maildb.CreateDocument
Call MailDoc.ReplaceItemValue("Form", "Memo")
Call MailDoc.ReplaceItemValue("SendTo", MailAddress)
Call MailDoc.ReplaceItemValue("Subject", Subject)
Set Body = MailDoc.CreateRichTextItem("Body")
Call Body.AppendText(Message)
MailDoc.SaveMessageOnSend = True
Call MailDoc.ReplaceItemValue("PostedDate", Now())
Call MailDoc.Send(False)
Set Maildb = Nothing
Set MailDoc = Nothing
Set Body = Nothing
Set Session = Nothing
End Sub
Now, what I'd like to do is to create the buttons when the workbook opens, iterating through the first compiled column of my sheet. Next, I'll add/delete buttons when adding/deleting rows to the sheets. To do so I have at the moment the following code:
Private Sub Workbook_Open()
Dim L As Integer
Dim t As Range
Dim btn As Button
Dim arg As String
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Sheets(1).Activate
L = Application.WorksheetFunction.CountA(Range("C:C"))
For i = 2 To L
Set t = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top + 5, t.Width, 20)
'arg = "'Invia Range("J1").Value , Cells(i, t.Column + 2).Value , Cells(i, t.Column+3).Value '"
With btn
.OnAction = arg
.Caption = "Invia"
.Name = "Btn" & i
End With
Next i
End Sub
My problem is I'm not able to write the string to pass to OnAction property in the correct way.
That should be the call to procedure Send with 3 parameters:
1) MailAddress: found in cell J1 (static)
2) Subject: found in columns C at the current row (i) of the loop
3) Body: found in column D at the current row (i) of the loop
Can't get it to work.
I'm quite new to VBA and I'm getting crazy with all those quotes, single quotes and double quotes.
May someone kindly help me?
Mhanks in advance,
Marco
arg = "'Send ""{1}"", ""{2}"", ""{3}"" '"
arg = Replace(arg,"{1}", Range("J1").Value)
arg = Replace(arg,"{2}", Cells(i, t.Column + 2).Value)
arg = Replace(arg,"{3}", Cells(i, t.Column+3).Value)
.OnAction = arg
I have an Add button in the dialog form to add items, its quantity, price , currency and list in the field below. There is a currency field in the form. it is a drop down list with many currencies. The currency should be same on adding the items. if there is currency change, message box should appear. below is the part of the code for add button event. "cur" is the currency field.
Sub Click(Source As Button)
'On Error Goto errhandle
Dim work As New notesuiworkspace
Dim uidoc As notesuidocument
Dim doc As notesdocument
Dim item As String, weight As String
Dim qty As String, price As String
Dim sbtotal As String
Dim gtotal As String
Set uidoc = work.currentdocument
Set doc =uidoc.Document
item = uidoc.FieldGetText("Item")
qty = uidoc.FieldGetText("Qty")
price = uidoc.FieldGetText("Price")
cur = uidoc.FieldGetText("cur")
sbtotal= uidoc.FieldGetText("SubTotal")
Call uidoc.Refresh
'weight = uidoc.FieldGetText("W_Qty")
'adj = uidoc.fieldGetText("Adj")
remark = uidoc.FieldGetText("Remarks")
If item = "" Or qty = "" Or price = "" Then
Msgbox "Please complete the data entry ", 16, "Error - Incomplete Data Entry"
Exit Sub
End If
recordNo = uidoc.fieldgettext("ww")
If recordNo = "" Then
recordNumber = 0
Else
pos = Instr(recordNo,";")
If pos > 0 Then
number = Right(recordNo , pos -1)
Else
number = Left(recordNo , pos +1)
End If
recordNumber = Cint(number)
End If
recordNumber = recordNumber + 1
'to append text
Call uidoc.FieldAppendText("no" ,";" & Cstr(recordNumber))
Call uidoc.FieldAppendText("Item1" ,";" & item)
Call uidoc.FieldAppendText("Q1" , ";" & Cstr(qty))
Call uidoc.FieldAppendText("amt" , ";" & Cdbl(price))
Call uidoc.FieldAppendText("C1" , ";" & Cstr(cur))
Call uidoc.FieldAppendText("TSubTotal" , ";" & Cdbl(sbtotal))
'clear entering data
uidoc.FieldClear("Remarks")
uidoc.FieldClear("Item")
uidoc.FieldClear("Qty")
uidoc.FieldClear("Price")
'uidoc.FieldClear("W_Qty")
Call uidoc.FieldSetText("SubTotal","0.00")
uidoc.refresh
Dim subtotal As Double
subtotal = 0
Forall stotal In doc.TSubTotal
If stotal <> "" Then
subtotal = subtotal + Cdbl(stotal)
End If
End Forall
total = subtotal '+ Cdbl(curdoc.SubTotal(0))
Call uidoc.FieldSetText("GrandTotal",Format(total,"#,##0.00"))
uidoc.refresh
uidoc.gotofield"Item"
End Sub
Please help me. Thanks.
Create a new hidden field called selectedCurrency. The initial value of this field should be empty.
In your Add button code, you need to first check selectedCurrency, and if it is blank you should set it equal to cur.
Then, also in the code for the Add button, you need to compare selectedCurrency and cur, and if they are not equal you should display your message box.
I'd fix the currency outside the code for the Add button, and also make it required before Add can be started.
I use the below script in querysave event of a form. The logic is when I save the form the sequence should get displayed in the view in two columns. like "115-" in one column and the sequence "00001", "00002", ... in the second column. The first two documents gets saved without any issue. When I save try to save 3rd and more documents, its displaying "00002" only every time after that. I am not able to identify what is the mistake. Can somebody help please.
Sub Querysave(Source As Notesuidocument, Continue As Variant)
Dim SESS As New NotesSession
Dim w As New NotesUIWorkspace
Dim uidoc As NotesUIdocument
Dim Doc As NotesDocument
Dim RefView As NotesView
Dim DB As NotesDatabase
Dim RefDoc As NotesDocument
Set DB = SESS.CurrentDatabase
Set uidoc = w.CurrentDocument
Set Doc = uidoc.Document
Set RefView = DB.GetView("System\AutoNo")
Dim approvedcnt As Integer
approvedcnt = Cint(source.fieldgettext("appcnt"))
If uidoc.EditMode = True Then
Financial_Year = Clng(Right$(Cstr(Year(Now)),3)) + 104
If Month(Now) >= 4 Then Financial_Year = Financial_Year + 1
DocKey = Cstr(Financial_Year)& "-"
New_No = 0
Set RefDoc = RefView.GetDocumentByKey(DocKey , True)
If Not(RefDoc Is Nothing) Then New_No = Clng(Right$(RefDoc.SETTLEMENT_NO(0),5))
New_No = New_No + 1
autono = DocKey & "-" & Right$("00000" & Cstr(New_No) ,5)
Application ="ST"
Latest_No = Application + autono
Doc.SETTLEMENT_NO = Latest_No
Doc.FinFlag="Finish"
Call SESS.SetEnvironmentVar("ENV_ST_NO",Right$("00000" & Cstr(DefNo&) ,5))
'Call uidoc.FieldSetText("SETTLEMENT_NO",Latest_No)
Call uidoc.Refresh
Else
Exit Sub
End If
get_ex_rate
get_cv_local
Call uidoc.FieldSetText("Flag1", "A")
If approvedcnt = 12 And uidoc.FieldGetText("STATUS") = "APPROVE" Then
Call uidoc.fieldsettext("Flag2", "B")
End If
Dim answer2 As Integer
answer2% = Msgbox("Do you want to save this document?", 1, "Save")
If answer2 = 1 Then
Print "Saving"
End If
If answer2 = 2 Then
continue=False
Exit Sub
End If
uidoc.Refresh
uidoc.close
End Sub
I imagine your call to GetDocumentByKey is getting the wrong document or not the next one in sequence. Make sure the view is sorted properly and perhaps call the refresh method on the view before calling GetDocumentByKey.