Détacher les fichiers attachés

[Michael DELIQUE]

d'apres une fonction posté par ex_Stagiaire

Code : Tout sélectionner

Public Function FileDetach(wDoc As notesdocument, Byval wChamp As String,wDirectory As String,wFileName As String) As String
         'Déclaration Variable
   Dim rtitem As NotesRichTextItem
   
   On Error Goto ErreurHandle
   
   FileDetach = ""
   
   If wDoc Is Nothing Then
      Error 9999,"wDoc is Nothing"
   Else
      If wDoc.HasEmbedded = False Then
         Exit Function
      End If
   End If
   
   If Trim(wChamp) <> "" Then
      Set rtitem = wDoc.GetFirstItem(wChamp)
      If rtitem Is Nothing Then
         Error 9999,"rtitem => ''"+wChamp+"'' is nothing"
         Exit Function
      Else
         If (rtitem.Type <> RICHTEXT) Then
            Error 9999,"'"+wChamp+"'' is not NotesRichTextItem"
            Exit Function
         End If
      End If
   End If
   
   If Trim(wDirectory) = "" Then
      Error 9999,"wDirectory empty"
      Exit Function
   Else
      If Right(Trim(wDirectory),1)<>"\" Then
         wDirectory = Trim(wDirectory)+"\"
      Else
         wDirectory = Trim(wDirectory)
      End If
   End If
   
   If Trim(wFileName) = "" Then
      Error 9999,"wFileName empty"
      Exit Function
   End If
   
   If Trim(wChamp) <> "" Then
      Forall Attachement In rtitem.EmbeddedObjects
         Select Case Attachement.Type
         Case 1454,    EMBED_ATTACHMENT
            If Trim(Attachement.Name) = Trim(wFileName)Then
               Call Attachement.ExtractFile(wDirectory+Attachement.Name)
               FileDetach = Attachement.Name
               Set rtitem = Nothing
               Exit Function
            End If
         Case 1453,EMBED_OBJECT
            
         Case 1452, EMBED_OBJECTLINK
            
         End Select
      End Forall
   End If
   
   Forall Attachement In wDoc.EmbeddedObjects
      Select Case Attachement.Type
      Case 1454,    EMBED_ATTACHMENT
         If Trim(Attachement.Name) = Trim(wFileName)Then
            Call Attachement.ExtractFile(wDirectory+Attachement.Name)
            FileDetach = Attachement.Name
            Set rtitem = Nothing
            Exit Function
         End If
      Case 1453,EMBED_OBJECT
         
      Case 1452, EMBED_OBJECTLINK
         
      End Select
   End Forall
   
   Set rtitem = Nothing

   Exit Function
ErreurHandle:
   Msgbox "("+Structure_Log+" : "+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"   Set rtitem = Nothing
   FileDetach = ""
   Exit Function
End Function

[Michael DELIQUE]

une autre version

Code : Tout sélectionner

Public Function FileDetach(wDoc As notesdocument, Byval wChamp As String,wDirectory As String,wFileName As String) As String
         'Déclaration Variable
   Dim rtitem As NotesRichTextItem
   
   On Error Goto ErreurHandle
   
   FileDetach = ""
   
   If wDoc Is Nothing Then
      Error 9999,"wDoc is Nothing"
   Else
      If wDoc.HasEmbedded = False Then
         Exit Function
      End If
   End If
   
   If Trim(wChamp) <> "" Then
      Set rtitem = wDoc.GetFirstItem(wChamp)
      If rtitem Is Nothing Then
         Error 9999,"rtitem => ''"+wChamp+"'' is nothing"
         Exit Function
      Else
         If (rtitem.Type <> RICHTEXT) Then
            Error 9999,"'"+wChamp+"'' is not NotesRichTextItem"
            Exit Function
         End If
      End If
   End If
   
   If Trim(wDirectory) = "" Then
      Error 9999,"wDirectory empty"
      Exit Function
   Else
      If Right(Trim(wDirectory),1)<>"\" Then
         wDirectory = Trim(wDirectory)+"\"
      Else
         wDirectory = Trim(wDirectory)
      End If
   End If
   
   If Trim(wFileName) = "" Then
      Error 9999,"wFileName empty"
      Exit Function
   End If
   
   If Trim(wChamp) <> "" Then
      Forall Attachement In rtitem.EmbeddedObjects
         Select Case Attachement.Type
         Case 1454,    EMBED_ATTACHMENT
            If Trim(Attachement.Name) = Trim(wFileName)Then
               Call Attachement.ExtractFile(wDirectory+Attachement.Name)
               FileDetach = Attachement.Name
               Set rtitem = Nothing
               Exit Function
            End If
         Case 1453,EMBED_OBJECT
            
         Case 1452, EMBED_OBJECTLINK
            
         End Select
      End Forall
   End If
   
   Forall Attachement In wDoc.EmbeddedObjects
      Select Case Attachement.Type
      Case 1454,    EMBED_ATTACHMENT
         If Trim(Attachement.Name) = Trim(wFileName)Then
            Call Attachement.ExtractFile(wDirectory+Attachement.Name)
            FileDetach = Attachement.Name
            Set rtitem = Nothing
            Exit Function
         End If
      Case 1453,EMBED_OBJECT
         
      Case 1452, EMBED_OBJECTLINK
         
      End Select
   End Forall
   
   Set rtitem = Nothing
   
   Exit Function
ErreurHandle:
   Msgbox "("+Cstr(Getthreadinfo (1))+" Call by "+Cstr(Getthreadinfo(10))+")"+Chr(10)+"Erreur " + Str(Err) + " : "+Chr(10) + Cstr(Error)+". "+Chr(10)+"Ligne N° "+Cstr(Erl),16," ERREUR !"
   
   Set rtitem = Nothing
   FileDetach = ""
   Exit Function
End Function