Discussion :

[salas99]

Bonjour,

J'ai utilisé le tutoriel suivant concernant l'affichage de photos dans un formulaire en mode continu :
http://dolphy35.developpez.com/artic.../formcontinus/
Cela fonctionne parfaitement. Merci au créateur !!!

En revanche, je bute sur un problème similaire dans un sous-état en mode continu.

Je m'explique :
J'ai un formulaire de saisie d'un film, qui est relié à un formulaire de saisie des acteurs (en mode continu). Là, tout fonctionne avec le tutoriel (qui me permet de saisir mes acteurs tout en affichant leur photo selon la procédure du tuto et surtout sans stocker les images dans la base).

Dans mon formulaire de saisie des films, j'ai un bouton me permettant d'ouvrir un état (une jaquette du film relié à la table Film) dans lequel il y a un sous-état relié à une table "Jouer" reliée au film, d'une part, et aux acteurs d'autre part - dans un film il y a plusieurs acteurs.
Les acteurs qui jouent dans le film apparaissent dans le sous-état (nom + photo). Et c'est là que ça bloque. Comment faire apparaître les photos dans mon sous-état sans avoir à stocker celles-ci dans la base ? Je précise qu'il y a toujours 6 photos à afficher, jamais plus.

En outre, pour l'affiche du film, j'ai réussi à faire afficher l'affiche du film sans stocker le fichier image dans la base. Donc, je me dis que cela doit être faisable pour le sous-formulaire mais étant débutant en VBA, j'ai du mal...

Dors et déjà, merci pour votre gentillesse qui m'a permis d'avancer. Et merci d'avance pour les éventuelles solutions que vous pourrez m'apporter.


Salas99

[ClaudeLELOUP]

Bonjour,

J'utilise Access2000 (donc antérieure à celle utilisée dans le tutoriel cité).
Tu trouveras ici : http://claudeleloup.developpez.com/t...plic-ploc/#LII
une autre méthode (Arkham46) qui fonctionne tant pour un formulaire en continu que pour un état.

[salas99]

Bonjour,

Ce module est parfait, c'est une merveille. En effet, tout fonctionne parfaitement.

Mes photos portant le nom et prénom de chaque acteur, j'ai adapté la source du cadre d'objet indépendant de la manière suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=ImageToOLE([CurrentProject].[path] & "\Acteurs\" & [PrénomActeur] & " " & [NomActeur] & ".jpg";[OleImg];-1;-1)

Cela fonctionne très bien (bien entendu, il ne faut pas de doublons).

En revanche, sur 5 000 photos, j'en ai à peu près 2 000 en format png.
J'ai commencé à les enregistrer sous le format jpg.
Je m'interroge toutefois sur la possibilité d'indiquer dans la source qu'une photo peut avoir une extension ".jpg" ou ".png".
Je n'ai pas trouvé la formule.

Mille merci à l'auteur du module (dans lequel j'avoue ne pas avoir tout compris). La taille de ma base est passée de 210 Mo à 6,8 Mo sans les photos des acteurs et sans les affiches de films.
Encore merci.


Salas99

[ClaudeLELOUP]

Bonjour,

Je m'interroge toutefois sur la possibilité d'indiquer dans la source qu'une photo peut avoir une extension ".jpg" ou ".png".

Dans l'événement Sur activation (On Current) cherche quelle extension a l'image et aménage la propriété à la volée.

[salas99]

Bonjour,

Merci. Mais comment faire référence à l'extension dans le code ?

Salas99

[loufab]

Bonjour,
Il faut tester l'existence du fichier avant d'y faire référence. Exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Dim sNameFile as String
sNameFile  = CurrentProject.path & "\Acteurs\" & [PrénomActeur] & " " & [NomActeur]
 
if dir(sNameFile & ".jpg")<>"" then
   sNameFile  =sNameFile   & ".jpg"
else if  dir(sNameFile & ".png")<>"" then
   sNameFile  =sNameFile   & ".png"
else
   sNameFile  =CurrentProject.path & "\" & "imageAbsente.jpg"
endif
 
me.image.picture = sNameFile

"imageAbsente.jpg" correspond à une image à afficher si aucune image ne correspond. ça évite les erreurs.

Cordialement,

[ClaudeLELOUP]

Bonjour Salas99, Bonjour Fabrice,

Le code fourni par Fabrice est évidemment correct, mais le problème est ici un peu plus compliqué.

On exploite la méthode décrite par Arkham46 ici : http://www.developpez.net/forums/d10...a/#post5650876
Arkham46 nous propose deux versions 1 et 1.bis.
Si on désire utiliser des images .png, il faut utiliser la version 1.bis.

Je crois que Salas99 s’est inspiré de mon article : http://claudeleloup.developpez.com/t...plic-ploc/#LII

Dans cet article, j’utilise la version 1 => les images .png ne sont donc pas utilisables.

N.B. Pour utiliser la version 1.bis, il faut installer la gdiplus.dll.
Je la mets en P.J., il faut l’installer dans le répertoire de l’application Access.

En deuxième P.J., je mets un exemple d’utilisation avec des images .jpg, .bmp, .png, .gif, .ico

[loufab]

Utiliser la bibliothèque GdiPlus pour faire de l'affichage d'images me semble un peu extrême. Un peu comme utiliser un fusil de chasse pour tuer un moustique.

MS Access reconnaît la plupart des formats d'images, il suffit simplement d'y faire référence dans la propriété Picture du contrôle Image indépendant.

Maintenant détecter si un fichier image dont on ne stocke ni le nom ni le type existe, le plus simple est d'utiliser la fonction Dir().

Pourquoi se compliquer l'existence ?! Faire simple et encore la meilleure approche dans un développement.

Mais peut être que je me trompe.

[ClaudeLELOUP]

Ça t’a sans doute échappé : il s’agit d'une image dans un contrôle indépendant qui varie à chaque enregistrement d’un formulaire en continu ou d’un état.

La source du contrôle :




… et pour trouver l’image qui correspond à cet enregistrement, j’utilise effectivement la fonction DIR() :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Option Compare Database
Option Explicit
 
Public Function PhotoOK(AuteurPk As Long) As String
 
  If Dir(CurrentProject.Path & "\Images\" & AuteurPk & ".jpg") = AuteurPk & ".jpg" Then
      PhotoOK = CurrentProject.Path & "\Images\" & AuteurPk & ".jpg"
      Exit Function
    ElseIf Dir(CurrentProject.Path & "\Images\" & AuteurPk & ".gif") = AuteurPk & ".gif" Then
        PhotoOK = CurrentProject.Path & "\Images\" & AuteurPk & ".gif"
        Exit Function
    ElseIf Dir(CurrentProject.Path & "\Images\" & AuteurPk & ".bmp") = AuteurPk & ".bmp" Then
             PhotoOK = CurrentProject.Path & "\Images\" & AuteurPk & ".bmp"
             Exit Function
    ElseIf Dir(CurrentProject.Path & "\Images\" & AuteurPk & ".png") = AuteurPk & ".png" Then
             PhotoOK = CurrentProject.Path & "\Images\" & AuteurPk & ".png"
    ElseIf Dir(CurrentProject.Path & "\Images\" & AuteurPk & ".ico") = AuteurPk & ".ico" Then
             PhotoOK = CurrentProject.Path & "\Images\" & AuteurPk & ".ico"
             Exit Function
         Exit Function
 
    Else: PhotoOK = CurrentProject.Path & "\Images\Default.bmp"
  End If
 
End Function

C’est la fonction ImageToOLEPlus() écrite par Arkham46 qui nécessite la bibliothèque GdiPlus.

[loufab]

Il y a une incohérence là. Vous parlez de champ Ole alors que Salas indique bien :

qui me permet de saisir mes acteurs tout en affichant leur photo selon la procédure du tuto et surtout sans stocker les images dans la base

Tout cela est foncièrement illogique. Si le image sont externes autant utiliser un contrôle image non lié et ne pas utiliser la Gdiplus qui permet beaucoup de chose soit mais est anecdotique sur ce cas là.

[salas99]

Bonjour,
Comme l'intitulé l'indique, j'ai changé d'ordinateur portable et de version access (j'utilise la suite 2024).
J'utilise toujours la version 1 d'arkham46 pour stocker mes images à l'extérieur de la base access et son code pour les afficher dans des formulaires sou des sous-formulaires.
Je n'ai que des fichiers jpg.
Depuis le changement, la propriété "mode affichage" ne fonctionne plus pourtant je l'ai bien mise en "zoom". Les images ne remplissent plus le cadre de l'objet cadre dépendant lorsqu'elles sont plus petites.
La résolution de mon écran a changé.
Est-ce que quelqu'un a une idée ?
Merci à tous d'avance.
Salas99

[User]

Bonjour,

Avez-vous essayé cet autre module d'Arkham46 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
Option Explicit
'***************************************************************************************
'*              MODULE POUR AFFICHAGE D'IMAGES DANS UN CADRE OLE
'***************************************************************************************
 
'***************************************************************************************
' Auteur : Thierry GASPERMENT (Arkham46)
'
' Le code est libre pour toute utilisation
'***************************************************************************************
' v1.1 (21/12/10)
'***************************************************************************************
' Documentation OLE
' http://msdn.microsoft.com/en-us/library/dd942053(v=PROT.10).aspx
' http://support.microsoft.com/kb/147727/fr
'***************************************************************************************
 
' Definition des variables non typees en long pour 32 bits ou longptr pour 64 bits
' Les elements des types doivent etre types obligatoirement
#If VBA7 Then
DefLngPtr A-Z
Const PtrNull As LongPtr = 0
#Else
DefLng A-Z
Const PtrNull As Long = 0
#End If
 
' API
#If VBA7 Then
Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" _
                                           (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetStretchBltMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nStretchMode As Long) As Long
Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BitmapInfo, ByVal un As Long, lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function FillRect Lib "USER32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
#Else
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
                                           (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" _
                                      (ByVal hObject As Long, ByVal nCount As Long, lpObject As bitmap) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" _
                                    (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, _
                                     ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
                                     ByVal ySrc As Long, ByVal nSrcWidth As Long, _
                                     ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
                                          (ByVal hdc As Long, pBitmapInfo As BitmapInfo, ByVal un As Long, _
                                           lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function apiGetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
#End If
' CONSTANTES
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const HIMETRIC_INCH = 2540          ' Pour conversion Pouce<->Himetric
Private Const OT_STATIC = 3
Private Const SRCCOPY = &HCC0020
Private Const COLORONCOLOR = 3              ' Mode pour StretchBlt
Private Const HALFTONE = 4                  ' Mode pour StretchBlt avec antialiasing
Private Const DIB_RGB_COLORS As Long = &H0
Private Const BI_RGB As Long = &H0
' STRUCTURES
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Type bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
#If VBA7 Then
    bmBits As LongPtr
#Else
    bmBits As Long
#End If
End Type
Private Type BitmapInfoHeader
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
Private Type BitmapInfo
    bmiHeader As BitmapInfoHeader
    bmiColors(0 To 255) As Long
End Type
Private Type DIBSECTION
    dsBm As bitmap
    dsBmih As BitmapInfoHeader
    dsBitfields(2) As Long
#If VBA7 Then
    dshSection As LongPtr
#Else
    dshSection As Long
#End If
    dsOffset As Long
End Type
 
' Fonction publique à appeler en source d'un contrôle OLE
Public Function ImageToOLE(ByVal pFile As String, Optional pCtrlResize As Access.Control, Optional pCenter As Boolean, Optional pRepaintForm As Boolean) As Variant
Dim ldata() As Byte
Dim lsize As Long
Dim lImg As Object
Dim lOldImg
Dim lloaddc, lLoadhBmp As bitmap
Dim lhdc, lhdcref
Dim lDIBPTR, lhDib, lhOldDib
Dim lWidth As Long, lHeight As Long
Dim lCtrlWidth As Long, lCtrlHeight As Long
Dim lBI As BitmapInfo
Dim lParentForm As Object
Dim lDecalageX As Long, lDecalageY As Long
Dim lRect As RECT, lBrush
Dim lBrushColor As Long
On Error GoTo Gestion_Erreurs
' Chargement de l'image complete
Set lImg = LoadPicture(pFile)
#If Win64 Then
' Lecture des donnees bitmap de l'image source
Call GetObjectBmp(lImg.handle, LenB(lLoadhBmp), lLoadhBmp)
#Else
Call GetObjectBmp(lImg.handle, Len(lLoadhBmp), lLoadhBmp)
#End If
' DC de référence
lhdcref = GetDC(0)
' Redimensionnement suivant taille contrôle
If Not pCtrlResize Is Nothing Then
    lCtrlWidth = CLng(pCtrlResize.Width / (1440 / GetDeviceCaps(lhdcref, LOGPIXELSX)))
    lCtrlHeight = CLng(pCtrlResize.Height / (1440 / GetDeviceCaps(lhdcref, LOGPIXELSY)))
    lWidth = lCtrlWidth
    lHeight = lCtrlHeight
    If lWidth < lLoadhBmp.bmWidth Or lHeight < lLoadhBmp.bmHeight Then
        If ((lLoadhBmp.bmWidth - lWidth)) / lLoadhBmp.bmWidth * lLoadhBmp.bmHeight < (lLoadhBmp.bmHeight - lHeight) Then
            lWidth = lWidth - (lWidth - lLoadhBmp.bmWidth * (lHeight) / lLoadhBmp.bmHeight)
            lHeight = lWidth / lLoadhBmp.bmWidth * lLoadhBmp.bmHeight
        Else
            lHeight = lHeight - (lHeight - lLoadhBmp.bmHeight * (lWidth) / lLoadhBmp.bmWidth)
            lWidth = lHeight / lLoadhBmp.bmHeight * lLoadhBmp.bmWidth
        End If
    Else
        lWidth = lLoadhBmp.bmWidth
        lHeight = lLoadhBmp.bmHeight
    End If
    If pCenter Then
        lDecalageX = (lCtrlWidth - lWidth) / 2
        lDecalageY = (lCtrlHeight - lHeight) / 2
    Else
        lCtrlWidth = lWidth
        lCtrlHeight = lHeight
    End If
Else
    lWidth = lLoadhBmp.bmWidth
    lHeight = lLoadhBmp.bmHeight
    lCtrlWidth = lWidth
    lCtrlHeight = lHeight
End If
' DC pour l'image source
lloaddc = CreateCompatibleDC(lhdcref)
lOldImg = SelectObject(lloaddc, lImg)
' DIB section et DC de l'image cible (24 bits)
With lBI.bmiHeader
    .biSize = 40
    .biBitCount = 24
    .biHeight = lCtrlHeight
    .biWidth = lCtrlWidth
    .biPlanes = 1
    .biCompression = BI_RGB
End With
lhdc = CreateCompatibleDC(lhdcref)
lhDib = CreateDIBSection(lhdc, lBI, DIB_RGB_COLORS, lDIBPTR, 0, 0)
lhOldDib = SelectObject(lhdc, lhDib)
If pCenter Then
    lRect.Right = lCtrlWidth
    lRect.Bottom = lCtrlHeight
    lBrushColor = vbWhite
    If Not pCtrlResize Is Nothing Then
        If pCtrlResize.BackStyle = 0 Then
            On Error Resume Next
            lBrushColor = pCtrlResize.Parent.Section(pCtrlResize.Section).BackColor
            On Error GoTo Gestion_Erreurs
        Else
            lBrushColor = pCtrlResize.BackColor
        End If
    End If
    lBrush = CreateSolidBrush(GetColor(lBrushColor))
    FillRect lhdc, lRect, lBrush
    DeleteObject lBrush
End If
' Copie de l'image source vers cible
SetStretchBltMode lhdc, HALFTONE
StretchBlt lhdc, lDecalageX, lDecalageY, lWidth, lHeight, lloaddc, 0, 0, lLoadhBmp.bmWidth, lLoadhBmp.bmHeight, SRCCOPY
' Lecture des donnees bitmap de l'image cible
#If Win64 Then
Call GetObjectBmp(lhDib, LenB(lLoadhBmp), lLoadhBmp)
#Else
Call GetObjectBmp(lhDib, Len(lLoadhBmp), lLoadhBmp)
#End If
lsize = lLoadhBmp.bmWidthBytes * lLoadhBmp.bmHeight
' Structure OLE
ReDim ldata(1 To 95)
AddInt ldata, &H1C15&, 1 ' Signature
AddInt ldata, 27, 3 ' HeaderSize = len(OBJECTHEADER) + ClassLen + NameLen
AddLong ldata, OT_STATIC, 5 ' ObjectType
AddInt ldata, 6, 9 ' NameLen
AddInt ldata, 1, 11 ' ClassLen
AddInt ldata, 20, 13 ' NameOffset
AddInt ldata, 26, 15 ' ClassOffset
AddInt ldata, -1, 17 ' Width
AddInt ldata, -1, 19 ' Height
ldata(21) = Asc("I") ' Name
ldata(22) = Asc("m")
ldata(23) = Asc("a")
ldata(24) = Asc("g")
ldata(25) = Asc("e")
ldata(26) = 0
ldata(27) = 0 ' Class
AddLong ldata, 1281, 28 ' OLEVersion : 1281 = 1.5
AddLong ldata, 3, 32 ' FormatID
AddLong ldata, 4, 36 ' PresClassLen
ldata(40) = Asc("D") ' PresClass
ldata(41) = Asc("I")
ldata(42) = Asc("B")
ldata(43) = 0
AddLong ldata, CLng(lLoadhBmp.bmWidth * (HIMETRIC_INCH / GetDeviceCaps(lhdc, LOGPIXELSX))), 44 ' WidthHiMetric
AddLong ldata, -CLng(lLoadhBmp.bmHeight * (HIMETRIC_INCH / GetDeviceCaps(lhdc, LOGPIXELSY))), 48 ' HeightHimetric
AddLong ldata, 40 + lsize, 52 ' PresentationDataSize
AddLong ldata, 40, 56 ' biSize
AddLong ldata, lLoadhBmp.bmWidth, 60   ' biWidth
AddLong ldata, lLoadhBmp.bmHeight, 64  ' biHeight
AddInt ldata, 1, 68 ' biPlanes
AddInt ldata, lLoadhBmp.bmBitsPixel, 70    ' biBitCount
AddLong ldata, 0, 72 ' biCompression
AddLong ldata, lsize, 76 ' biSizeImage
AddLong ldata, 3780, 80 ' biXPelsPerMeter
AddLong ldata, 3780, 84 ' biYPelsPerMeter
AddLong ldata, 0, 88  ' biClrUsed
AddLong ldata, 0, 92  ' biClrImportant
' Redim pour ajout des pixels
ReDim Preserve ldata(1 To 95 + lsize + 4) ' + 4 pour le checksum (non calculé ici)
' Copie des données images (=pixels)
If lLoadhBmp.bmBits <> 0 Then
    RtlMoveMemory ldata(96), ByVal lLoadhBmp.bmBits, lsize
End If
' Retour des données
ImageToOLE = ldata
If Not pCtrlResize Is Nothing And pRepaintForm Then
    Set lParentForm = pCtrlResize.Parent
    Do While Not TypeOf lParentForm Is Access.Form
        Set lParentForm = lParentForm.Parent
    Loop
    lParentForm.Repaint
End If
' Destruction des objets
Gestion_Erreurs:
    ReleaseDC 0, lhdcref
    DeleteObject SelectObject(lhdc, lhOldDib)
    DeleteDC lhdc
    SelectObject lloaddc, lOldImg
    DeleteDC lloaddc
    Set lImg = Nothing
End Function
Private Sub AddLong(pArray() As Byte, pLong As Long, pPos As Long)
RtlMoveMemory pArray(pPos), pLong, 4
End Sub
Private Sub AddInt(pArray() As Byte, pInt As Integer, pPos As Long)
RtlMoveMemory pArray(pPos), pInt, 2
End Sub
Private Function GetColor(ByVal pColor As Long) As Long
    If pColor < 0 Then
        Call OleTranslateColor(pColor, 0, pColor)
    End If
    GetColor = pColor
End Function

Sinon, un contrôle image classique à la place devrait normalement fonctionner.

Cdlt

[User]

Bonsoir,

Avez-vous pu tester cette version du module d'Arkham46 ?

Cdlt

[salas99]

Bonjour,
Non malheureusement, je n'ai pas pu essayer la nouvelle fonction. Je n'ai plus mis mon nez dans les modules Access depuis très très longtemps, j'ai peur de faire une connerie...
Je copie-colle le module dans un module de ma base de données access. La syntaxe dans la propriété Source contrôle est-elle la même : =ImageToOLE([CurrentProject].[path]...
Quel nom dois-je donner au module, le précédent (qui datait de 2006) avait comme nom mArkham46ImageFormContinu ???

Merci pour votre aide.

[User]

Bonjour,

Vous faites une copie de votre base juste pour tester, il n'y a aucun risque si vous travaillez sur la copie.

Ensuite, dans la copie, vous remplacez le contenu du module d'Arkham ("ModImageOLE" v1.2) par celui que je vous ai donné v1.1 (un simple copié-collé).

Vous compilez le projet et vous testez en ouvrant votre état...

[salas99]

Bonjour,
Merci pour votre aide.
Je viens d'essayer, mais j'ai le même problème, sur mon nouvel ordinateur, la valeur "Zoom" de mon cadre d'objet dépendant est sans effet ???
D'où cela peut-il venir, cela fonctionne très bien sur mon ancien ordi ?
Salas

[User]

Bonjour,

Dans ce cas, il faudrait faire l'autre test : remplacer le cadre d'objet dépendant du sous-état par un contrôle image, et mettre ceci dans sa propriété Source contrôle ou Image :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

=[CurrentProject].[path] & "\Acteurs\" & [PrénomActeur] & " " & [NomActeur] & ".jpg"

Les images doivent bien sûr être placées dans le dossier Acteurs situé dans le même dossier que le fichier Access.

Cdlt