Lotus Script Code

HCL Domino Domino Forum
1

I am not a developer by an means but I am trying to take the code for a written agent and use it elsewhere but there is part of the code I need left out. The following goes through a mail database and takes new emails and detaches any files to a particular directory if it has a 3 digit numeral in the title. It then creates a folder with that number in the directory. I would just like to change it so that it takes any attachment from any email and puts it in that main directory. Here is the code:

Sub Initialize

On Error Goto oops



Set s = New NotesSession

Set db = s.CurrentDatabase

Set view = db.GetView("($Inbox)")	



Dim attachmentObject As Variant

Dim folderName As String



sDir = "/folder/inbound"



Set doc = view.GetFirstDocument

While  (Not doc Is Nothing)		

	folderName = Right$(doc.Subject(0), 3)

	If IsNumeric(folderName) Then

		Forall i In doc.Items

			If i.Type = ATTACHMENT Then

				Set attachmentObject = doc.GetAttachment(i.Values(0))

				Call ExportAttachment(attachmentObject, folderName)

			End If

		End Forall

	End If

	

	Set tempdoc = doc

	Set doc = view.GetNextDocument(doc)

	Call tempdoc.Removefromfolder("($Inbox)")

	Call tempdoc.Putinfolder("History")

Wend





Exit Sub

oops:

Msgbox "folder.nsf " & Error$ & " on " & Cstr(Erl)

Resume done

done:

End Sub

Sub ExportAttachment(o As Variant, folderName As String)

On Error Goto oops



Dim sAttachmentName As String

Dim folderCheck As String

Dim testFileName As String



On Error Resume Next

folderCheck = Dir$ (sDir & "/" & folderName, 16)

On Error Goto oops

If folderCheck = "" Then

	MkDir sDir & "/" & folderName

End If



sAttachmentName = sDir & "/" & folderName & "/" & o.Source



testFileName = ""

On Error Resume Next

testFileName = Dir$ (sAttachmentName, 0)

On Error Goto oops



If testFileName = "" Then

	Call o.ExtractFile( sAttachmentName ) 

End If



Exit Sub

oops:

Msgbox "Export sub: " & Error$ & " on " & Cstr(Erl)

Resume done

done:

Can anyone tell me what I need to change so that it just takes any attachment and places it in the /inbound directory?

Thanks

2

Subject: Something you should think about…

What if the file names are not unique?

Create a naming convention. Is it important to track by user?

Here is some code:

…

	pstrFullPath$=Cstr({c:\inbound\} & yrfile & {\}& categ & {\})

'Function createPath(pstrFullPath As String) As Boolean

	If createPath(pstrFullPath$) = False Then 

		Msgbox "failed to create directory!: " & pstrFullPath$

		Exit Sub

	Else

		Call createPath(pstrFullPath$)

	End If

	

	Set rtitem = doc.GetFirstItem( "Body" )

	fileCount = 0 

	plainText=""

	

	If ( rtitem.Type = RICHTEXT ) Then

		'stop

		

		If Isempty(rtitem.EmbeddedObjects)=False Then

			Forall o In rtitem.EmbeddedObjects

REM Note how many files we have processed

				fileCount = fileCount + 1

'Presuming the doc has an attachment, now the below line

'has an error, probably because dbug isnt Dim and set

				agentLog.LogAction("file count:"+Cstr(fileCount)) 

				If ( o.Type = EMBED_ATTACHMENT ) Then

					

					

					FileName=datestring & o.Source					

					'stop

					If FileExists(pstrFullPath$ & FileName)=True Then

						Call agentLog.LogAction("File exists: " & FileName)													

						'stop

						Call GetUniqueFileName(pstrFullPath$, FileName)

					End If

					

					txtFile= GetUniqueFileName(pstrFullPath$, FileName)

					Call o.ExtractFile(pstrFullPath$ & txtFile)

				End If

				

			End Forall

		Else

			plainText = rtitem.GetFormattedText( False, 0 )

			

			FileName=datestring & categ & ".txt"

			

			txtFile =	pstrFullPath$ & FileName

			

			

			If FileExists(pstrFullPath$ & FileName)=True Then

				'stop

				Call agentLog.LogAction("File exists: " & FileName)						

				FileName= GetUniqueFileName(pstrFullPath$, FileName)

				txtFile =	pstrFullPath$ & FileName

			End If

			

			fnum = Freefile

			

			Open txtFile For Output As fnum

			Print #fnum, rtitem.GetFormattedText(False, 0);

			Close fnum 

			

			

		End If

		

	End If

	

	Set doc=dc.getnextdocument(doc)

Wend

…

Function FileExists (FileName As String) As Variant

On Error 53 Resume Next



Dim FileDir As String

FileExists = False



FileDir = Dir$(FileName, 0)



If Len(FileDir) > 0 Then

	FileExists = True

End If

End Function

Function StringReplaceSubstring(_

SourceString As String,_

StringToReplace As String,_

StringReplaceWith As String) As String

'END FUNCTION DECLARATION*

Dim StringLeft,StringRight,StringWhole As String

Dim intPosition,intRepLen As Integer

StringReplaceSubstring = ""

intRepLen = Len(StringToReplace)

intPosition = Instr(1,SourceString,StringToReplace,1)

While intPosition <> 0

	StringReplaceSubstring = StringReplaceSubstring & Left$(SourceString,intPosition-1) & StringReplaceWith

	SourceString = Mid$(SourceString,intPosition+intRepLen,32000)

	intPosition = Instr(1,SourceString,StringToReplace,1)

Wend

StringReplaceSubstring = StringReplaceSubstring & SourceString

End Function

Function createPath(pstrFullPath As String) As Boolean

'// GLOBAL VARIABLES:

'//

'//

'// 02/22/2000 - Dallas Gimpel

'//

'// DESCRIPTION:

'// Given a path as input, this function will attempt to traverse the path and create the

'// necessary directory structure on the local hard drive assuming OS to be Win32.

'//

'// OUTPUT:

'// Function returns true if it is able to create the given directory structure, otherwise

'// it returns false

On Error Goto errorHandler



Const MB_ICONEXCLAMATION = 48

Const MB_OK = 0

Const ATTR_DIRECTORY = 16

Dim i As Integer

Dim strRoot As String

Dim strDirStruct As String

Dim varAllDirs As Variant



createPath = False

If Not(Instr(pstrFullPath$, ":\") = 2) Then

	Msgbox "The path could not be interpreted - unable to continue.", MB_OK + MB_ICONEXCLAMATION, "Unable to continue . . ."

	Goto functionExit

End If



strRoot$ = Left(pstrFullPath$, 1) & ":\"

If Dir$(strRoot$, ATTR_DIRECTORY) = "" Then '// the root directory is invalid

	Msgbox "The root directory is invalid - unable to continue.", MB_OK + MB_ICONEXCLAMATION, "Unable to continue . . ."

	Goto functionExit

End If



strDirStruct$ = strRoot$

varAllDirs = Split(pstrFullPath$, "\")

For i = (Lbound(varAllDirs) + 1) To Ubound(varAllDirs)

	strDirStruct$ = strDirStruct & varAllDirs(i)

	If Dir$(strDirStruct$, ATTR_DIRECTORY) = "" Then '// directory doesn't exist - create it

		Mkdir strDirStruct$

	End If

	strDirStruct$ = strDirStruct & "\"

Next i



createPath = True

functionExit:

Exit Function

errorHandler:

Msgbox "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & ".", , "Error encountered . . ."

Print "Error " & Err & ": " & Error$ & " encountered at line " & Erl & " of " & Getthreadinfo(1) & " . . ."

Stop

Resume functionExit

End Function

Function GetUniqueFileName (filePath As String, fileName As String) As String

Stop

Dim splitName As Variant

Dim fileExistsString As String

Dim fileNum As Integer

Dim uniqueName As String



fileNum = 0

uniqueName = fileName

CheckName:

’ fileExistsString = Dir$( filePath & uniqueName, 0)

’ If FileExists(pstrFullPath$ & uniqueName)=False Then

If FileExists(filePath & uniqueName)=False Then

’ If Len(fileExistsString) = 0 Then

	Goto ExitFunction

Else

	fileNum = fileNum + 1

	splitName = Split(fileName, ".", 2)

	uniqueName = splitName(0) + " (" + Cstr(fileNum) + ")." + splitName(1)

	Goto CheckName

End If

ExitFunction:

GetUniqueFileName = uniqueName

End Function