Tip

Automatically reattach after modification of an attachment - Part III

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

There are Comments. Add yours.

 
TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

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:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.