title image


Smiley dann viel Spaß beim Testen
Hallo minipli,



anbei ein Script für eine Aktionsschaltfläche in der $Inbox.



Gruß

FPN60



Dim session As New NotesSession

Dim doc As NotesDocument

Dim rtitem As Variant

Dim filename As String

Dim filepath As String

Dim fnlen As Integer

Dim fplen As Integer

Dim error53 As Variant

Dim error4005 As Variant

Dim attr As Integer



Const ErrFileNotFound = 53

Const ErrCannotCreateFile = 4005



On Error Goto ErrHandle

On Error ErrFileNotFound Goto ErrHandle53

On Error ErrCannotCreateFile Goto ErrHandle4005



fnlen = Len( session.CurrentDatabase.FileName )

fplen = Len( session.CurrentDatabase.FilePath )

filepath = Mid$( session.CurrentDatabase.FilePath, 1, fplen - fnlen) & "attachments\"



Set doc = session.DocumentContext



If doc Is Nothing Then Exit Sub



Set rtitem = doc.GetFirstItem( "Body" )



If ( rtitem.Type = RICHTEXT ) Then

Forall o In rtitem.EmbeddedObjects



If ( o.Type = EMBED_ATTACHMENT ) Then

filename = o.Source

error53 = False

error4005 = False

attr = Getattr ( filepath & filename ) 'Will error to 53 if file does not exist

If error53 Then

Call o.ExtractFile( filepath & filename )

Else

error53 = False

filename = Inputbox$ ( "Please enter a new file name, " & filename & " already exists.", "File Already Exists", "new" & filename )

If filename = "" Then Exit Sub

attr = Getattr ( filepath & filename ) 'Will error to 53 if file does not exist



If error53 Then

Call o.ExtractFile( filepath & filename )

Else

Msgbox "Unable to complete request, file already exists."

Exit Sub

End If

End If



If error4005 Then Call o.ExtractFile( filepath & filename )



Call rtitem.AddNewLine( 1 )

Call rtitem.AppendText("[file: " & filename & " detached to: " & filepath & filename & "]")



Call o.Remove

Call doc.Save( False, True )



End If

End Forall

End If

Exit Sub



Errhandle53:

' This is file not found, good error, meaning this filename does not already exist...

error53 = True

Resume Next



Errhandle4005:

' directory does not exist so we will create it...

If error4005 Then

'second time through - fatal error - can't really imagine this situation...

Msgbox "Unable to complete request, directory does not exist."

Exit Sub

Else

'first time through - make the directory if possible

Mkdir filepath

error4005 = True

End If

Resume Next



Errhandle:

Messagebox "Error" & Str(Err) & ": " & Error$

Exit Sub





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: