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
