DominoArea.org [Archive]

Bonjour,
voici un code qui permet l'insertion d'une image dans la signature de mail en fonction de la version de Lotus Notes:

initialement j'ai une base contenant les cartes de visites au format GIF des utilisateurs, le but est de detache la carte et l'inserer dans le calendar Profile de la boite mail du User

J'utilise des bibliotheque detaille dans d'autres post du forum:
Bien sur cet agent est sauvegarde dans la plus ancienne version de Notes et les methodes utilisées sont compatibles avec les version superieure à 6.0

voici le code :

Code : Tout sélectionner

Dim sess As notessession
Dim db As NotesDatabase
Dim ws As NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim docUser As NotesDocument
Dim dbMailUser As NotesDatabase
Dim docCalendarProf As NotesDocument
Dim c As Integer
Dim f As Integer
Dim dataUser As String
Dim vueConfig As notesview
Dim docConfig As notesdocument
Dim repSignature As String
Dim itemFile As NotesItem
Dim strFileName As String
Dim langue As String
Dim richitemsig As notesrichtextitem

'file import en Dorsal
Const SIG_CD_IMAGESEGMENT = 124%
Const SIG_CD_IMAGEHEADER = 125%
Const SIG_CD_GRAPHIC = 153%
Const SIG_CD_BEGIN = 221% + &H0600% ' includes length
Const SIG_CD_END = 222% + &H0600% ' includes length

Const CDIMAGETYPE_GIF= 1%
Const CDIMAGETYPE_JPEG = 2%
Const CDIMAGETYPE_BMP = 3% ' Notes 6

Const MAX_SEG = &H2800%
Const MAX_ITEM = &HA000&

Const wAPIModule = "NNOTES" ' Windows/32
Const wUIModule = "NNOTESWS"

Declare Private Function NSFItemAppend Lib wAPIModule Alias "NSFItemAppend" _
( Byval hNT As Long, Byval F As Integer, Byval N As String, Byval nN As Integer _
, Byval T As Integer, Byval V As Long, Byval nV As Long) As Integer
Declare Sub NEMDisplayError Lib wUIModule Alias "NEMDisplayError" _
( Byval E As Long)
Declare Private Function OSMemoryAllocate Lib wAPIModule Alias "OSMemoryAllocate" _
( Byval T As Integer, Byval S As Long, hM As Long) As Integer
Declare Private Function OSMemoryLock Lib wAPIModule Alias "OSMemoryLock" _
( Byval hM As Long) As Long
Declare Private Function OSMemoryUnlock Lib wAPIModule Alias "OSMemoryUnlock" _
( Byval hM As Long) As Long
Declare Private Function OSMemoryFree Lib wAPIModule Alias "OSMemoryFree" _
( Byval hM As Long) As Integer
Declare Private Sub Poke Lib wAPIModule Alias "Cmovmem" _
( S As Any, Byval P As Long, Byval N As Long)


Type SegmentData
   Data(MAX_SEG / 4 - 1) As Long
End Type


Class ItemBuffer
   
   Private address As Long
   Private hM As Long
   Private hNT As Long
   Private itemname As String
   Private seg As SegmentData
   Private pointer As Long
   
   Public Sub New(hNT As Long, itemname As String)
      Me.hNT = hNT
      Me.itemname = itemname
      OSMemoryAllocate 0, MAX_ITEM + MAX_SEG + 256, hM
      address = OSMemoryLock(hM)
      pointer = address
   End Sub
   
   Public Sub Delete
      If hM = 0 Then Exit Sub
      OSMemoryUnlock hM
      OSMemoryFree hM
      hM = 0
   End Sub
   
   Public Sub Put(V As Variant)
      Select Case Typename(V)
      Case "INTEGER" : n& = 2
      Case "LONG" : n& = 4
      Case Else : Exit Sub
      End Select
      Poke V, pointer, n&
      pointer = pointer + n&
   End Sub
   
   Public Sub Read(f As Integer, n As Integer)
      On Error 62 Resume Next ' allow input past EoF
      Get #f%, , seg
      On Error Goto 0
      Poke seg, pointer, n
      pointer = pointer + n
   End Sub
   
   Public Sub Record(V As Variant)
      If pointer - address > MAX_ITEM Then Save
      Me.Put V
   End Sub
   
   Public Sub Save
      s% = NSFItemAppend( hNT, 0, itemname, Len(itemname), 1, address, pointer - address)
      If Not s% = 0 Then NEMDisplayError s%
      pointer = address
   End Sub
End Class


Code : Tout sélectionner

Sub RecupConfig
   repsignature = sess.getenvironmentstring("Directory",True)
End Sub


Code : Tout sélectionner

Sub Invert(n As Integer)
   h$ = Right$("000" & Hex$(n), 4)
   n = Cint("&H" & Right$(h$, 2) & Left$(h$, 2))
End Sub

Code : Tout sélectionner

Sub CreateImageItem(doc As NotesDocument, itemname As String, imagefile As String)
   Dim hNT As Long
   hNT = doc.Handle
   If hNT = 0 Then Error 1000, "No document handle"
   
   f% = Freefile()
   Open imagefile For Binary Access Read As #f%
   fsize& = Lof(f%)
   If fsize& = 0 Then Error 1000, "Can't open file " & imagefile
   segs& = -Int(-fsize& / MAX_SEG) ' round up
   
   Get #f%, , v%
   Select Case v%
   Case &H4947 : ftype% = CDIMAGETYPE_GIF
      Get #f%, 7, imgx%
      Get #f%, 9, imgy%
   Case &HD8FF : ftype% = CDIMAGETYPE_JPEG
      p& = 3
      n% = 0
      While Not (t% = &HC0FF Or t% = &HC2FF) ' SOFn
         p& = p& + n%
         Get #f%, p&, t% ' marker type
         p& = p& + 2
         Get #f%, p&, n% ' length
         Invert n%
      Wend
      If t% = &HC0FF Or t% = &HC2FF Then
         Get #f%, p& + 3, imgy%
         Invert imgy%
         Get #f%, p& + 5, imgx%
         Invert imgx%
      Else
         Error 1000, "Can't understand JPEG format"
      End If
   Case &H4D42 : ftype% = CDIMAGETYPE_BMP ' Notes 6
      Get #f%, 19, imgx%
      Get #f%, 23, imgy%
   Case Else : Error 1000, "Unrecognized image format"
   End Select
   Seek #f%, 1
   
   Dim buf As New ItemBuffer(hNT, itemname)
   With buf
      .Record SIG_CD_BEGIN
      .Put 1% ' version
      .Put SIG_CD_GRAPHIC
      
      .Record SIG_CD_GRAPHIC
      .Put 28& ' length
      .Put 0& ' dest
      .Put 0& ' crop
      .Put 0& ' off1
      .Put 0& ' off2
      .Put 0% ' resized
      .Put 1% ' version
      .Put 0% ' junk
      
      .Record SIG_CD_IMAGEHEADER
      .Put 28& ' length
      .Put ftype%
      .Put imgx%
      .Put imgy%
      .Put fsize&
      .Put segs&
      .Put 0& ' flags
      .Put 0& ' junk
      
      For i& = 1 To segs&
         If i& = segs& Then dsize% = fsize& Mod MAX_SEG Else dsize% = MAX_SEG
         ssize% = dsize% + (dsize% And 1) ' round up
         .Record SIG_CD_IMAGESEGMENT
         .Put Clng(ssize% + 10) ' length
         .Put dsize%
         .Put ssize%
         .Read f%, ssize%
      Next
      
      .Record SIG_CD_END
      .Put 1% ' version
      .Put SIG_CD_GRAPHIC
      
      .Save
   End With
   Close #f%
End Sub

Code : Tout sélectionner

Sub Initialize
   'recuperation doc courant
   Set sess = New NotesSession
   Set db = sess.currentdatabase
   Set ws = New NotesUIWorkspace
   Set uidoc =  ws.currentdocument
   Set docUser = uidoc.Document
   'recuperation de la boite mail de l'utilisateur
   Set dbMailUser = DBOpenMailbox(False)
   If dbMailUser Is Nothing Then
      Msgbox "Boite aux lettres introuvable",16," TRAITEMENT IMPOSSIBLE"
      Exit Sub
   End If
   'recuperation calendar profile
   Set docCalendarProf = dbMailUser.GetProfileDocument( "CalendarProfile")
   If docCalendarProf Is Nothing Then
      Error 9999,"Document profil ''Préférence'' Introuvable"
      Exit Sub
   End If
   ' verification signature existe
   langue = sess.GetEnvironmentString("Langue")
   If docCalendarProf.EnableSignature(0)="1" Then
      If langue = "EN" Then
         i = Messagebox("You have already a signature in your mailbox. Do you want to continue?",36,"Beware")
      Else   
         i = Messagebox("Vous avez déjà une signature d'enregistrée.Voulez-vous continuer?",36,"Attention")
      End If
      
      If i = 7 Then Exit Sub
   End If
   
   Call recupConfig
   
   'creation repertoire signature
   If RepExist(RepSignature) = False Then
      Call CreateDirectory(RepSignature)
   End If
   Set itemFile = docUser.GetFirstItem("$File")
   strFileName = itemFile.Values(0)
   'detachement du gif dans le repertoire crée
   f =  FileDetach(docUser, "Carte",RepSignature ,strFileName)
   If f <> 1 Then
      Msgbox "Problème lors du détachement de votre signature sur votre disque",16," TRAITEMENT IMPOSSIBLE"
      Exit Sub
   End If
   
   ' modifcation du calendar profile,'test version
   If (sess.NotesBuildVersion < 200) And (sess.NotesBuildVersion > 189) Then 'version 6
      Call docCalendarProf .replaceItemValue("EnableSignature","1")
      Call docCalendarProf .replaceItemValue("SignatureOption","2")
      Call docCalendarProf .replaceItemValue("Signature_2",RepSignature+strFileName)
      Call docCalendarProf .computewithform(True, False)
      Call docCalendarProf .save(True,True)
   Else
      If (sess.NotesBuildVersion < 400) And (sess.NotesBuildVersion > 300) Then 'version 8
         Call docCalendarProf .replaceItemValue("EnableSignature","1")
         Set  richitemsig = docCalendarProf.GetFirstItem("Signature_Rich")
         CreateImageItem docCalendarProf, "Signature_Rich", RepSignature+strFileName
         Call docCalendarProf .computewithform(True, False)
         Call docCalendarProf .save(True,True)
      Else
         Msgbox "Votre version de client est trop ancienne, merci de contacter votre administrateur",16," TRAITEMENT IMPOSSIBLE"
         Exit Sub
      End If
   End If
   
   'message d'avertissement
   If uidoc.EditMode = False Then
      uidoc.EditMode = True
      Call uidoc.FieldSetText("FlagSign","1")
      Call uidoc.Refresh
      Call uidoc.save
      uidoc.EditMode = False
   Else
      Call uidoc.FieldSetText("FlagSign","1")
      Call uidoc.Refresh
      Call uidoc.save
   End If
   
   If langue = "EN" Then
      Messagebox"Your signature is added to your mailbox",64,"Signature"
   Else   
      Messagebox"Votre signature est bien ajoutée dans votre boite mail",64,"Signature"
   End If
End Sub

Pour toute question n'hesitez pas à demander