Automatically reattach after modification of an attachment - Part III

This script gives your databases the functionality to detach / edit / attach an attachment with one single click. Part III

This Content Component encountered an error

This is Part III of script that gives your databases the functionality to detach / edit / attach an attachment with one single click.
Here is a downloadable sample database.

 Click here for Part I
Click here for Part II
Public Sub RemoveByName ( ObjName As String , InItem As String ) '// Removes an attachment ( by name ) from an item '// Called by : Method '// Calls : none Dim s As New NotesSession, ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument, doc As NotesDocument Dim rtitem As Variant Set uidoc = ws.CurrentDocument If Not uidoc.editMode = True Then '// if the currently opened document isn't in editMode uidoc.editMode = True '// switch to editMode End If %REM *** Following line of code edited by S Blake, 18/8/2000: changed from uidoc.Save to uidoc.SaveNewVersion, to ensure that there is a backup of the document in case the user did not want to do a Notes save after they'd done an MS-office save. Note that to do this, the Form needs to have Versioning enabled (preferably to "Prior Versions become Responses" and "Manual - File, New Version" option Call uidoc.SaveNewVersion '***End S Blake 18/8/2000 amendment*** %END REM Set doc = uidoc.document Call uidoc.SaveNewVersion Call uidoc.Close ' save & close the ui document. its necessary if you want to manipulate RTFields Set rtitem = doc.GetFirstItem( InItem ) If ( rtitem.Type = RICHTEXT ) Then Set object = rtitem.GetEmbeddedObject( ObjName ) Call object.Remove '// Remove the attachment from the document doc.SaveOptions = " 0" Call doc.Save( True, True) End If Call ws.EditDocument( True, doc ) '// switch back to the frontend and show the changes End Sub Private Function FileLastModified ( strPath As String ) As String '// Retrieves the Date Last Modified from the file '// Called by : DetachAndEdit '// Calls : Dim FileHandle As Long Dim FileData As WIN32_FIND_DATA Dim Filename As String Dim LocalFileTime As FILETIME Dim LocalSystemTime As SYSTEMTIME FileHandle = FindFirstFile ( WorkDir & strPath & vbNullChar, FileData) FileTimeToLocalFileTime FileData.ftLastWriteTime, LocalFileTime FileTimeToSystemTime LocalFileTime, LocalSystemTime FileLastModified = Trim( Left$(FileData.cFileName, Instr(FileData.cFileName, vbNullChar) - 1) & " " _ & LocalSystemTime.wDay & "." _ & LocalSystemTime.wMonth & "." _ & LocalSystemTime.wYear & ", "_ & LocalSystemTime.wHour & ":" _ & Format$(LocalSystemTime.wMinute, "00") _ & ":" & Format$(LocalSystemTime.wSecond, "00") ) FindClose FileHandle End Function Public Sub Attach ( FileName As String , InItem As String ) '// Attaches a file from the filesystem to an item on the currently opened document '// Called by : Method '// Calls : none Dim s As New NotesSession, ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument, doc As NotesDocument Dim ni As Variant Dim no As Variant, cUNID As String Set uidoc = ws.CurrentDocument Set doc = uidoc.document Call uidoc.Save Call uidoc.Close ' save & close the ui document. its necessary if you want to manipulate RTFields Set ni = doc.GetFirstItem( InItem ) Set no = ni.EmbedObject( EMBED_ATTACHMENT , "" , WorkDir & FileName ) Call doc.Save( True , False ) doc.SaveOptions = "0" Call ws.EditDocument( True , doc ) End Sub Private Function FindExecutableByExtension( FullPath As String ) As Variant '// Finds the location of an application for a file '// Called by : Sub DetachAndEdit '// Calls : none Dim success As Long Dim pos As Long Dim sResult As String Dim RetVal As String sResult = Space$ ( MAX_PATH ) lpFile$ = ExtractFileName ( FullPath ) lpDirectory$ = Left$ ( FullPath , Len( FullPath ) - Len( lpFile$ ) ) success = FindExecutable ( lpFile$ , lpDirectory$ , sResult ) Select Case success Case ERROR_FILE_NO_ASSOCIATION: msg = "no association" Case ERROR_FILE_NOT_FOUND: msg = "file not found" Case ERROR_PATH_NOT_FOUND: msg = "path not found" Case ERROR_BAD_FORMAT: msg = "bad format" Case Is >= ERROR_FILE_SUCCESS: pos = Instr ( sResult , Chr$ ( 0 ) ) If pos Then RetVal = Left$ ( sResult , pos - 1 ) End If End Select FindExecutableByExtension = RetVal End Function Private Function DetachByName (InItem As String, AttName As String, path As String, overwrite As Integer) As Variant '// Detaches an attachment by name '// Called by : Sub DetachAndEdit '// Calls : Function IsDriveAvailable, Function IsPathAvailable, Function GetAttachmentByName Dim session As New NotesSession Dim ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument Set uidoc = ws.CurrentDocument Set doc = uidoc.Document Dim rtitem As Variant Set rtitem = doc.GetFirstItem( InItem ) If IsDriveAvailable(Left(path,3)) Then Chdrive Left(path,3) IsPathAvailable(path) Chdir path i% = 1 j% = GetAttachmentByName( InItem, AttName) If j% > count(InItem) Then DetachByName = False Exit Function Else If ( rtitem.Type = RICHTEXT ) Then Forall o In rtitem.EmbeddedObjects If j% = i% Then Call o.ExtractFile(o.Name) End If i% = i% + 1 End Forall End If End If DetachByName = True Else DetachByName = False End If End Function Private Function GetAttachmentByName (InItem As String, AttName As String) As Variant '// Gets an attachment by a given FileName '// Called by : Function DetachByName '// Calls : Dim Array As New ArraySets Dim ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument Dim rtitem As Variant Dim Whereis As Integer Set uidoc = ws.CurrentDocument Set doc = uidoc.Document Set rtitem = doc.GetFirstItem( InItem ) notesEmbeddedObject = rtitem.EmbeddedObjects Call Array.Init If ( rtitem.Type = RICHTEXT ) Then Forall o In rtitem.EmbeddedObjects Array.AddElement(o.name) End Forall Else End If WhereIs = Array.Search(AttName) GetAttachmentByName= WhereIs End Function Private Function GetNthAttachment (InItem As String, Position As Integer) As Variant '// Gets an attachment by number of position in the field '// Called by : '// Calls : If count(InItem) < Position Then GetNthAttachment = True Exit Function Else Dim Array As New ArraySets Dim ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument Dim rtitem As Variant Set uidoc = ws.CurrentDocument Set doc = uidoc.Document Set rtitem = doc.GetFirstItem( InItem ) notesEmbeddedObject = rtitem.EmbeddedObjects Call Array.Init If ( rtitem.Type = RICHTEXT ) Then Forall o In rtitem.EmbeddedObjects Array.AddElement(o.name) End Forall Else End If GetNthAttachment = Array.Value(Position) End If End Function Private Function Count ( InItem As String ) As Integer '// Counts the elements in the Item '// Called by : '// Calls : Dim session As New NotesSession Dim ws As New NotesUIWorkspace Dim uidoc As NotesUIDocument Dim rtitem As Variant Dim i As Integer Set uidoc = ws.CurrentDocument Set doc = uidoc.Document Set rtitem = doc.GetFirstItem( InItem ) notesEmbeddedObject = rtitem.EmbeddedObjects i = 0 If ( rtitem.Type = RICHTEXT ) Then Forall o In rtitem.EmbeddedObjects i = i +1 End Forall Else End If count = i End Function Private Function InstrBack (IString As String , SearchFor As String ) As Integer '// Get the position of SearchFor in IString from the right of IString '// Called by : Function ExtractFileName '// Calls : i% = 1 flag% = 0 Do Until flag% = 1 If Left$ ( Rightbp$ ( IString , i% ) , 1 ) = SearchFor Then flag% = 1 Else i% = i% + 1 End If Loop InstrBack = ( i% - 1 ) End Function Private Function ExtractFileName( FilePath As String ) As String '// Extract the FileName from FullPath '// Called by : Function FindExecutableByExtension '// Calls : Function InstrBack ExtractFileName = Rightbp$( FilePath , InstrBack ( FilePath , "" ) ) End Function Private Function IsDriveAvailable(drivNam$) As Variant '// Does Drive exists '// Called by : Function IsPathAvailable, Function DetachAll '// Calls : none On Error Goto Errors IsDriveAvailable = False If Dir$(drivNam, 8) <> "" Then IsDriveAvailable = True End If TheEnd: Exit Function Errors: Resume TheEnd End Function Private Function IsPathAvailable(path As String) As Variant '// Determine if a path exist; if not create path '// Called by : Function DetachAll '// Calls : Function IsDriveAvailable Dim session As New NotesSession Dim MyPath$, tmpPath$ Dim result%, pos% On Error Resume Next If IsDriveAvailable(Left(path,3)) Then Chdrive Left( path, 1 ) Chdir path result = False pos = 1 If Curdir + "" <> path Then If Right( path, 1 ) <> "" Then path = path + "" If path = "" Then Goto Exit_CheckDir Chdrive Left( path, 1 ) Do While pos <> 0 pos = Instr( pos, path, "" ) If pos > 0 Then tmpPath = Left( path, pos-1 ) Mkdir tmpPath Chdir tmpPath pos = pos + 1 End If Loop If Curdir + "" = path Then result = True End If Else result = True End If Else End If Exit Function Exit_checkDir: IsPathAvailable = result Exit Function End Function Private Sub ShellAndWait ( Byval RunProg As String ) '// Starts an external application and wait for the application to end '// Called by : '// Calls : Dim proc As PROCESS_INFORMATION Dim StartInf As STARTUPINFO StartInf.cb = Len ( StartInf ) RetVal = CreateProcessA ( 0&, RunProg , 0& , 0& , 1&, NORMAL_PRIORITY_CLASS , 0& , 0& , StartInf , proc ) RetVal = WaitFor

End of Part III. Click below to review Part I or Part II.
Part I
Part II

This was first published in February 2002

Dig deeper on Domino Resources - Part 3

0 comments

Oldest 

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

-ADS BY GOOGLE

SearchWinIT

Search400

  • iSeries tutorials

    Search400.com's tutorials provide in-depth information on the iSeries. Our iSeries tutorials address areas you need to know about...

  • V6R1 upgrade planning checklist

    When upgrading to V6R1, make sure your software will be supported, your programs will function and the correct PTFs have been ...

  • Connecting multiple iSeries systems through DDM

    Working with databases over multiple iSeries systems can be simple when remotely connecting logical partitions with distributed ...

SearchEnterpriseLinux

SearchVirtualDataCentre.co.UK

Close