FaceID / Icône dans un cadre Image

**Cinesra** · 04/11/2010, 15h22

Bonjour à tous!!

Je suis tout nouveau sur ce forum et un rookie qui bidouille des bouts de code VBA trouvé de-ci de-là pour arriver à mes fins dans Access.

Mon problème est le suivant: peut on utiliser les icônes des fichiers (apparemment appelés FaceId) dans un cadre Image lié à un champ texte (qui me sert à avoir des fichiers liés, et non pas intégrés à ma BdD). Si oui, quel serait le code le plus sachant que "le mien" commence ainsi:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Dim oFSO As Scripting.FileSystemObject
Set oFSO = New Scripting.FileSystemObject
If oFSO.GetExtensionName(Fichiers_joints) = "pdf" Then
 
'Me.Image14 = faceid pdf
 
ElseIf oFSO.GetExtensionName(Fichiers_joints) = "xls" Then
 
'Me.Image14 = faceid xls
 
End If

Image14 est mon cadre Image, Fichiers_joints mon champ Texte.

Merci par avance pour vos réponses
Cordialement

Invité · 04/11/2010, 18h42

Bonjour

Tu peux t'inspirer de quelques astuces dans ce tuto :

http://starec.developpez.com/tuto/barrecommande/#LVI-B
http://starec.developpez.com/tuto/barrecommande/#LVI-D

Philippe

**Cinesra** · 04/11/2010, 19h37

Merci c'est gentil mais j'avais déjà pensé à faire appel à une image externe, ici je préférerais ne pas avoir à m'encombrer avec des images externes mais faire appel à la capacité d'Access d'afficher des icônes comme dans un champs OLE lié.
En fait au final, ça me permettrait de faire en sorte que mon Cadre Image affiche l'image si le fichier importer est une image ou d'afficher l'icone d'un programme (genre Word) si c'est un fichier (fichier .doc).

Mais merci quand même!

**Cinesra** · 04/11/2010, 20h10

Apparement il faut procéder comme suit:

http://vb.developpez.com/faq/index.p...ticonfromfille

MAIS:
- je ne trouve pas la référence "Standard OLE Types"
- est ce que le code entre "Public Function" et "End Function" renvoi une image?
- si oui, comment l'appeler/quelle est son nom?

Mercii!!

**ClaudeLELOUP** · 04/11/2010, 20h58

Bonsoir,

un début de réponse :

je ne trouve pas la référence "Standard OLE Types"

1° Tu crées un nouveau module
2° Tu y colles tout le code
3° Outils/Références, tu fais défiler (ordre alphabétique) et tu coches Standard OLE Types

la fonction s'appelle GetIconFromFile

Mais j'ignore comment l'exploiter.
Dans la fenêtre d'exécution j'ai essayé :

Code :

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

? GetIconFromFile("C:\Program Files\Internet Explorer\iexplore.exe",0,true)

qui renvoie : 82511373

Pour la suite j'espère que tu trouveras de l'aide, le sujet m'intéresse aussi.
Bonne soirée

**Cinesra** · 04/11/2010, 23h28

Merci pour les tips, en fait la référence "Standard OLE Types" s'appelle "OLE Automation" dans Access 2007...enfin apparement

J'ai essayer de me servir de la fonction GetIconFromFile de plein de manières différentes mais rien à faire, access me retourne l'erreur:

"Erreur de compilation:
Membre de méthode ou de données introuvable"

J'avoue que je n'ai aucune idée de ce que ça veut dire, sauf peut être que la fonction GetIconFromFile est mal définie.

**pier.antoine** · 05/11/2010, 04h16

Bonjour

A priori les déclaration et instanciation ne sont pas faite dans les règles de l'art.

Comment les avez-vous faites?

Pierre

**Cinesra** · 05/11/2010, 09h11

Bonjour pier.antoine,

J'ai simplement fait un copier-coller du code de déclaration dans un nouveau module, sans rien toucher. Ça marche chez vous?

**ClaudeLELOUP** · 05/11/2010, 09h15

Bonjour,

3° Outils/Références, tu fais défiler (ordre alphabétique) et tu coches Standard OLE Types

As-tu ajouté la référence ?

**Cinesra** · 05/11/2010, 09h42

La référence "Standard OLE Types" s'appelle "OLE Automation" dans Access 2007...enfin apparement
Donc oui, "OLE Automation" est ajoutée

**ClaudeLELOUP** · 05/11/2010, 09h51

Désolé, hors mon champ (limité) de compétence.
Bonne continuation.

**Cinesra** · 05/11/2010, 11h33

Bon, il y a un brin de progrès de mon côté:

lorsque je charge un fichier pdf dans mon formulaire voilà ce qu'il ce passe:

Code :

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

1
2
3
If oFSO.GetExtensionName(Fichiers_joints) = "PDF" Then
Me.Image14 = GetIconFromFile(Fichiers_joints, 0, False)
End if

Image14 est mon cadre Image, Fichiers_joints est mon champs Texte qui contient le chemin d'accès au fichier (ici un pdf).

LE PROBLEME (hé oui, encore un!), c'est que cette fois access veut apparemment bien de la fonction GetIconFromFile mais me dit:

"438
Propriété ou méthode non gérée par cet objet"

Alors à mon avis c'est que l'objet renvoyé par la fonction GetIconFromFile ne peut pas être insérer dans un cadre Image mais je n'en suis pas sur.

Une suggestion?

**ClaudeLELOUP** · 05/11/2010, 11h44

A l'instinct donc sans garantie.
La syntaxe est probablement Me.image14.UnePropriété
Mais laquelle ?

**Cinesra** · 05/11/2010, 11h48

En essayant:

Code :

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

1
2
3
If oFSO.GetExtensionName(Fichiers_joints) = "PDF" 
Set icon = GetIconFromFile("C:\texte.PDF", 0, False)
Me.Image14.Picture = icon

OU

Code :

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

1
2
3
If oFSO.GetExtensionName(Fichiers_joints) = "PDF" 
icon = GetIconFromFile("C:\texte.PDF", 0, False)
Me.Image14 = icon

OU

Code :

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

1
2
3
If oFSO.GetExtensionName(Fichiers_joints) = "PDF" 
Set icon = GetIconFromFile("C:\texte.PDF", 0, False)
Me.Image14 = icon

j'ai:

"13
Incompatibilité de type"

**Arkham46** · 05/11/2010, 12h35

bjr,

un "petit" module :

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
 
Option Compare Database
Option Explicit
 
Private Declare Function GetObjectBmp Lib "gdi32" Alias "GetObjectA" _
                                      (ByVal hObject As Long, ByVal nCount As Long, lpObject As bitmap) As Long
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pPath As String, _
    ByVal dwFileAttributes As Long, ByRef psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function GetIconInfo Lib "USER32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal length As Long)
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal hdc 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
                                           (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
 
Private Type bitmap
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
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 DIBSECTION
    dsBm As bitmap
    dsBmih As BitmapInfoHeader
    dsBitfields(2) As Long
    dshSection As Long
    dsOffset As Long
End Type
Private Type BitmapInfo
    bmiHeader As BitmapInfoHeader
    bmiColors(0 To 255) As Long
End Type
Private Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    hbmMask As Long
    hbmColor As Long
End Type
Private Type SHFILEINFO
   hIcon As Long
   iIcon As Long
   dwAttributes As Long
   szDisplayName As String * 260
   szTypeName As String * 80
End Type
 
Private Const SHGFI_ICON = &H100
Private Const BI_RGB As Long = &H0
Private Const DIB_RGB_COLORS As Long = &H0
 
Public Function GetIconPictureData(pPath As String, Optional pLargeIcon As Boolean, Optional ByVal pIconBackColor As Long = vbWhite) As Variant
    Dim lLoadhBmp As bitmap
    Dim lpicinfo As ICONINFO
    Dim lIcon As Long, lBrush As Long, lHdc As Long, lHdcRef As Long
    Dim lhDIB As Long, lDIBPTR As Long, lhOldDIB As Long
    Dim lsfi As SHFILEINFO
    Dim lExtensionOnly As Boolean
    Dim lIconType As Long
    Dim lBI As BitmapInfo
    Dim lPicData() As Byte
    Dim lds As DIBSECTION
    On Error GoTo Gestion_Erreurs
    ' Pour compatibilite anciennes versions
    If Not pLargeIcon Then
        lIconType = &H1
    Else
        lIconType = &H0
    End If
    ' Si uniquement extension
    If Len(pPath) <= 6 And Left(pPath, 1) = "." Then lExtensionOnly = True
    ' Recupere l'icone
    Call SHGetFileInfo(ByVal pPath, IIf(lExtensionOnly, &H80, 0), lsfi, Len(lsfi), IIf(lExtensionOnly, &H10, 0) Or SHGFI_ICON Or lIconType)
    If lsfi.hIcon = 0 Then GetIconPictureData = Null: Exit Function
    lIcon = lsfi.hIcon
    ' Informations de l'icone
    GetIconInfo lIcon, lpicinfo
    ' Lecture des infos du bitmap de l'icone
    Call GetObjectBmp(lpicinfo.hbmColor, Len(lLoadhBmp), lLoadhBmp)
    ' Taille de l'en-tete
    lBI.bmiHeader.biSize = Len(lBI.bmiHeader)
    ' Taille de l'image = taille de l'objet
    lBI.bmiHeader.biWidth = lLoadhBmp.bmWidth
    lBI.bmiHeader.biHeight = lLoadhBmp.bmHeight
    ' Compression RGB (pas de compression en fait)
    lBI.bmiHeader.biCompression = BI_RGB
    ' 24bits
    lBI.bmiHeader.biBitCount = 24
    ' Nombre de plans : toujours = 1 (d'apres MSDN)
    lBI.bmiHeader.biPlanes = 1
    ' Taille de l'image à zéro, sera calculée par gdi32
    lBI.bmiHeader.biSizeImage = 0
    ' DC de reference
    lHdcRef = GetDC(0)
    ' Device context
    lHdc = CreateCompatibleDC(lHdcRef)
    ' Libere le DC
    ReleaseDC 0, lHdcRef
    ' Creation d'une nouvelle section DIB qui va contenir le bitmap
    lhDIB = CreateDIBSection(lHdc, lBI, DIB_RGB_COLORS, lDIBPTR, 0, 0)
    ' On selectionne ce DIB dans le contexte d'affichage en prenant soin de conserver l'ancien DIB
    lhOldDIB = SelectObject(lHdc, lhDIB)
    ' Brosse pour fond
    If pIconBackColor < 0 Then OleTranslateColor pIconBackColor, 0, pIconBackColor
    lBrush = CreateSolidBrush(pIconBackColor)
    ' Dessine l'icone sur le DIB
    DrawIconEx lHdc, 0, 0, lIcon, lLoadhBmp.bmWidth, lLoadhBmp.bmHeight, 0, ByVal lBrush, &H3
    ' Lecture de la taille de l'image
    Call apiGetObject(lhDIB, Len(lds), lds)
    ' Redimensionnement du tableau
    ReDim lPicData(lds.dsBmih.biSizeImage + 40)
    ' Copie des donnees de l'image
    RtlMoveMemory lPicData(40), ByVal lDIBPTR, lds.dsBmih.biSizeImage
    ' Copie des donnees en-tete
    RtlMoveMemory lPicData(0), lds.dsBmih, 40
    ' Renvoie le resultat
    GetIconPictureData = lPicData
Gestion_Erreurs:
    If Err.Number <> 0 Then GetIconPictureData = Null
    ' Supprime les objets temporaire
    DeleteObject lBrush
    DeleteObject lpicinfo.hbmColor
    DeleteObject lpicinfo.hbmMask
    DestroyIcon lIcon
    DeleteObject (SelectObject(lHdc, lhOldDIB))
    DeleteDC lHdc
End Function

pour l'utiliser :

Code :

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

1
2
3
4
5
6
7
8
 
Dim lData As Variant
lData = GetIconPictureData(Fichiers_joints.Value, True, Me.Section(0).BackColor)
If Not IsNull(lData) Then
    Me.Image14.PictureData = lData
Else
    Me.Image14.Picture = ""
End If

le premier paramètre est soit :
- le chemin complet d'un fichier ("c:\monfichier.pdf")
- ou d'un disque ("c:\", "d:\", ...)
- une extension (".pdf",".exe", ...)

le deuxième paramètre est soit :
- False pour une petite icone
- True pour une grande icone

le troisième paramètre est un code de la couleur de fond de l'icone
- Me.Section(acDetail).BackColor
- vbWhite (c'est la valeur par défaut)
- ...

Si le chemin est incorrect, ça renvoit Null.
Sinon c'est un tableau de byte utilisable pour la propriété PictureData d'une image.

**Cinesra** · 05/11/2010, 12h53

Oh boy, ça marche nickel-chrome. Je vais essayer de comprendre ce que tu as fais maintenant

En tout cas, Merci ooOOOH GRAND MERCI!
(je supprime le post concernant les Path des FaceID, c'était une autre piste que j'avais pour résoudre mon problème)

Je pourrais te MP si je ne comprends pas tout?
EDIT: tout compris merci

Merci encore

GE-NIAL!!

**ClaudeLELOUP** · 05/11/2010, 17h44

Merci Arkham46 !

FaceID / Icône dans un cadre Image [AC-2007]

VBA Access

Discussions similaires

Partager

Partager