Create your own Lotus Notes template storage database with revision history

Sub Click(Source As Button)
REM        Code Name = CreateTemStorDoc - Serv/Local 
REM               LS Program Type = View Action Button
REM                 Database Name = TemplateW.nsf
REM                        Date = 12-12-2001
REM                      Company = IBM/Lotus
REM                       Author = Don Russell
REM                                   Rev = B
REM Purpose = LS agent to get a list of databases in a 
  Directory and attach the chosen one. 
REM Rev B - Change search for previous rev doc to a 
  Keyed Lookup for much faster search and use
REM new Categorized hidden view called (HERevTempAllbyTitle)
	On Error Goto GeneralErr ' put at very top before Dimension statements
	Dim workspace As New NotesUIWorkspace
	Dim ViewH As Notesview
	Dim view As Notesview
	Dim CurUIview As NotesUIview
	Dim session As New Notessession
	Dim Fetchdb As Notesdatabase
	Dim Curdb As Notesdatabase
	Dim CurUIDoc As NotesUIDocument
	Dim Doc1,Doc2 As NotesDocument
	Dim Stordoc As NotesDocument
	Dim StanResD() As Notesdocument
	Dim ritmv,ritmv0,ritmv1 As NotesRichTextItem
	Dim items As String
	Dim dbFileN,dbFileP,dbServ As String
	Dim DelDBAns As String
	Dim FetchTitle,dbtSearchTitleDef,FetchTemName,FetchCreateDate,
	  FetchTempSize,dbtERevTitle As String
	Dim CurServer,dbtServer As String
	Dim formula As String
	Dim userchuz As Variant
	Dim userchui As Integer
	Dim i, j, k, Nod, RDim, Upperbound As Integer
	'Set up and dimension carriage returns for messageboxes
	Dim crlf As String
	Dim cr As String
	Dim lf As String
	cr$=Chr(13) ' Carriage return
	lf$=Chr(10) ' line feed
	crlf$=Chr(13) & Chr(10) ' Carriage return/line feed
	Dim itmv As Variant
	Dim itms() As String
	Dim version As String
	version = session.NotesVersion
	Set Curdb = session.CurrentDatabase
	Set Stordoc = New NotesDocument(Curdb)
	Stordoc.Form = "Template Storage Form"
	CurServer = Curdb.Server
	dbtServer = Inputbox("Leave Blank if local or use Default Server 
	  name if on the Template Warehouse Server","Where did the 
	    attached Template reside?",CurServer)
	Dim dbdir As New NotesDbDirectory(dbtServer)
	'--------------------------------------------------------------'Line 50
	' Cycle through DBs in directory to gather all Title Names and store 
	  in array itms
	'-------------------------------------------------------------------------
	i =1
	Nod = 0 ' Number of DBs in Directory (Initialize)
	While (i < 3)
		Set Fetchdb = dbdir.GetFirstDatabase(TEMPLATE)
		j=0
		While Not (Fetchdb Is Nothing)
			If ( i > 1) Then
				If ( j = 0) Then
					' ReDim only once when i =2 and j = 0
					RDim=Nod - 1 ' Dimension starts at zero so 
					  Dimension # is one less than # of Docs
					Redim StanResD(RDim) As Notesdocument
					Redim itms(RDim) As String
				End If
			'----------------------------------------------------------------
			' 1st Loop of I - do not get properties from DB, just count the DBs
				itms(j) = Fetchdb.Title
				j=j+1
			End If
		'--------------------------------------------------------------
			If ( i = 1) Then
				Nod = Nod+1 ' count the number of DBs (nod) in this dir for 
				   the first loop of I only
			End If
			Set Fetchdb = dbdir.GetNextDatabase
		Wend
		i = i +1
	Wend
	'---------------------------------------------------------------------------
	' Now Set the UI Doc to the current UI doc and choose a DB Title
	'---------------------------------------------------------------------------
	userchuz = workspace.Prompt(PROMPT_OKCANCELLISTMULT,
	  "Database Template List", "Do not attach Templates that have Default = 
	  No Access and LEIS Developers must be Manager in the ACL. Now Please 
	  select the Database Template to attach from the list","", itms)  'Line60
	If (userchuz(0) <> "") Then
		'Continue
		Goto Cont01
	Else
	'No Choice was made
		Exit Sub
	End If
Cont01:
	'--------------------------------------------------------------------
	'Now cycle through the DBs and stop at the chosen one.
	'--------------------------------------------------------------------
	K=0
	upperBound = Ubound(userchuz)
	While (K <= upperbound)
		Set Fetchdb = dbdir.GetFirstDatabase(TEMPLATE)
		j=0
		While Not (Fetchdb Is Nothing)
			itms(j) = Fetchdb.Title
			' y is set to "0" if the following string does compare.
			y = Strcomp(itms(j),userchuz(k), 5)
			If (y = 0) Then
				Goto Cont03 ' Choice is found - proceed to attach it
			Else
			' Choice is not found keep looking
			End If
			j=j+1
			Set Fetchdb = dbdir.GetNextDatabase
		Wend 'Line 100
	' Choice not found
		Exit Sub
Cont03:
		dbServ = Fetchdb.Server
		dbFileN = Fetchdb.FileName
		dbFileP = Fetchdb.FilePath
		If Fetchdb.IsOpen Then  ' Only Open DB if it is not already 
		  open or error will occur
		Else
			On Error Goto DBOpenErr ' DB open error Send E-mail 
			  and resume next DB
			Call Fetchdb.Open(dbServ,dbFileP)
		End If
		On Error Goto GeneralErr
		Dim dbcopy As NotesDatabase
		Set dbcopy = Fetchdb.CreateCopy _
		( "","c:\temp\"+dbFileN)
		Set ritmv = Stordoc.CreateRichTextItem("TemplateDB")
		Call ritmv.EmbedObject(EMBED_ATTACHMENT,"","c:\temp\"+dbFilen)
		Goto AttachDone
		k=k+1
	Wend
AttachDone:
	'Msgbox Fetchdb.Title, , Fetchdb.FileName
	FetchTitle=Fetchdb.title
	FetchTemName=Fetchdb.TemplateName
	FetchCreateDate = Fetchdb.Created
	FetchTempSize = Fetchdb.Size
	Set item = StorDoc.ReplaceItemValue("TempTitle",FetchTitle)
	Set item = StorDoc.ReplaceItemValue("TempName",FetchTemName)
	Set item = Stordoc.ReplaceItemValue("TempFileName",dbFileN)
	Set item = StorDoc.ReplaceItemValue("TempCreatedDate",
	  FetchCreateDate)
	Set item = StorDoc.ReplaceItemValue("TempSize",FetchTempSize)
	Set item = StorDoc.ReplaceItemValue("TempRev","")
	'-----------------------------------------------------------------------------
	message$ = " " & cr$ _
	& " Do you want to retrieve other field data from prior rev doc? " + cr$ _
	& " "  + cr$ _
	& " Click Yes to Proceed "  + cr$ _
	& " Click No to Save new Rev document "
	boxType& = 36 ' MB_YESNO + MB_ICONQuestion
	answer% = Messagebox(message$, boxType&, _ 
	"Retrieve Field Data from older Revision ")
	              ' 6 is the return value for pressing Yes - 7 is the 
	                return value for pressing No
	If(answer% = 6) Then
		' Answer is 6 = Yes (Retrieve data from prior Rev Doc)
		Goto ContToGetData
	Else
		' Answer must be 7 = No (Do not retrieve data from prior Rev Doc)
		Goto AllDone
	End If
ContToGetData: 'Line 150
	dbtSearchTitleDef = FetchTitle
ContSearch:
	dbtERevTitle = Inputbox("Change the default Title to the Title of the 
	  prior Rev  ","You Must Qualify the The Search String for the Prior Rev 
	  Template Title Name where Data will be copied From ",dbtSearchTitleDef)
' Keyed Lookup thru all the Docs in the current hidden view called 
  (HERevTempAllbyTitle)
	Set viewH=Curdb.getview("(HERevTempAllbyTitle)") ' Hidden View of all 
	  docs by template db title
	viewH.AutoUpdate = False ' If a status field is changed when doc is 
	 processed, then this will keep the doc in the view so next doc can be found.
' find doc by a keyed lookup to the hidden view on the first sorted column which 
  is Col. 1 - Template title
	formula = dbtERevTitle
	Set doc1 = viewH.GetDocumentByKey(formula)
	If (doc1 Is Nothing) Then
		message$ = "   " & cr$ _
		& " Your New Template should have the word Template and Rev in 
		  the Title Name " & cr$ _
		& " Your New Template Title Name for this Doc is: " & cr$ _
		& FetchTitle & cr$ _
		& " The Prior Rev Template Title Name typed in that was not found 
		  is: " & cr$ _
		& formula & cr$ _
		& " To Re-Type the Prior Rev Template Name and search again 
		  click - OK " & cr$ _
		& " To stop creating this new template storage doc click - Cancel  "
		'Set up the box type - See chart below
		boxType& = 33 ' MB_OKCANCEL + MB_ICONQUESTION
		answer% = Messagebox(message$, boxType&, _ 
		"The Prior Rev Doc Cannot Be Found.")
		                  ' 1 is the return value for pressing OK
		If(answer% = 1) Then
			dbtSearchTitleDef = formula
			Goto ContSearch ' OK - Type Prior Rev Template Name again
		Else
			Exit Sub ' If another box type is used with a choice, then an 
			  alternative path may be taken.
		End If
	End If
				' Copy TempIsWeb field to new doc				
	Set item = doc1.GetFirstItem("TempIsWeb")
	item = doc1.GetItemValue("TempIsWeb")
	items=Cstr(item(0))
	Call Stordoc.ReplaceItemValue("TempIsWeb",items)
				' Copy ShortDocComment field to new doc
	Set item = doc1.GetFirstItem("ShortDocComment")
	item = doc1.GetItemValue("ShortDocComment")
	items=Cstr(item(0))
	Call Stordoc.ReplaceItemValue("ShortDocComment",items)
				' Copy TemplatePic RichText field to new doc
	Set ritmv0 = Doc1.GetFirstItem("TemplatePic")
	Call ritmv0.CopyItemToDocument(Stordoc,"TemplatePic")
				' Copy DocComments RichText field to new doc
	Set ritmv0 = Doc1.GetFirstItem("DocComments")
	Call ritmv0.CopyItemToDocument(Stordoc,"DocComments")
				' Copy Synonyms field to new doc
	Set item = doc1.GetFirstItem("Synonyms")
	item = doc1.GetItemValue("Synonyms")
	items=Cstr(item(0))
	Call Stordoc.ReplaceItemValue("Synonyms",items) 'Line 200
	Goto AllDone
AllDone:
	'--------------------------------------------------------------------------------
	Call Stordoc.Save(False, False)
	Call dbcopy.remove
	DelDBAns = Inputbox("Delete the DB Template from Server = " + 
	   dbtServer + " dir? (No or Blank = No Del)","Delete the Database 
	   Template ","Yes")
	yy = Strcomp(DelDBAns, "Yes", 5)
	If (yy = 0) Then
		Fetchdb.remove ' Remove the DB Template from the Server directory
	End If
	Set CurrentDocument = Stordoc
	Set CurUIDoc = workspace.CurrentDocument
	Set CurUIDoc = workspace.EditDocument(True,Stordoc,False) 
	  ' The EditDocument method brings the back end doc into the front end.
	Call CurUIDoc.GotoField("TempRev")
	Goto TEnd
GeneralErr:
	message$ = " " & cr$ _
	& " An error was encountered in executing. " & cr$ _
	& "  Error # = " + Str(Err)+ cr$ _
	& "  Error String = " + Error$ + cr$_
	& "  Error Line # = " + Str(Erl) + cr$_
	& " Report this error to your DB Designer with the following 
	  information " + cr$ _
	& " The Notes Version Running this DB = " + version + cr$ _
	& " Error in LotusScript Code" + cr$ _
	& " Type and Name = View Action Button --CreateTemStorDoc 
	  - Serv/Local -- " + cr$ _
	& " View name = (HERevTempAllbyTitle)" + cr$ _
	& " Agnet Database Title = " + Curdb.Title + cr$ _
	& " Agent Database Filename = " + Curdb.Filename + cr$ _
	& " Agent Database Directory Path = " + Curdb.Filepath + cr$ _
	& " Fetch Database Title = " + Fetchdb.Title + cr$ _
	& " Fetch Database Filename = " + Fetchdb.Filename + cr$ _
	& " Fetch Database Directory Path = " + Fetchdb.Filepath + cr$ _
	& "" + cr$_
	& " Click OK to continue - Cancel to quit "
	boxType& = 17 ' MB_OKCANCEL + MB_ICONStop
	answer% = Messagebox(message$, boxType&, _ 
	"Error in execution of LS Code!")
	If(answer% = 1) Then
		Goto ContResN ' OK - Continue with next statement in LotusScript
	Else
		Exit Sub ' Cancel so quit out.
	End If
ContResN:
	Resume Next
DBOpenErr:
	message$ = " " & cr$ _
	& " An error was encountered in executing. " & cr$ _
	& "  Error # = " + Str(Err)+ cr$ _
	& "  Error String = " + Error$ + cr$_
	& "  Error Line # = " + Str(Erl) + cr$_
	& " The Template DB cannot be opened for copy and 
	  attachment " + cr$ _
	& " Report this error to your DB Designer with the following 
	  information " + cr$ _
	& " The Notes Version Running this DB = " + version + cr$ _
	& " Error in LotusScript Code" + cr$ _
	& " Type and Name = View Action Button --CreateTemStorDoc - 
	  Serv/Local -- " + cr$ _
	& " View name = (HERevTempAllbyTitle)" + cr$ _
	& " Fetch Database Title = " + Fetchdb.Title + cr$ _
	& " Fetch Database Filename = " + Fetchdb.Filename + cr$ _
	& " Fetch Database Directory Path = " + Fetchdb.Filepath + cr$ _
	& "" + cr$_
	& " Click OK to continue - Cancel to quit "
	boxType& = 17 ' MB_OKCANCEL + MB_ICONStop
	answer% = Messagebox(message$, boxType&, _ 
	"Error in execution of LS Code!")
	If(answer% = 1) Then
		Goto ContN ' OK - Continue with next statement in LotusScript
	Else
		Exit Sub ' Cancel so quit out.
	End If
ContN:
	Resume Next
TEnd:
End Sub