Afficher une image dans UserForm en fonction de la TextBox

Version imprimable

21/02/2019, 09h28
kalista

1 pièce(s) jointe(s)

Afficher une image dans UserForm en fonction de la TextBox

Bonjour à tous,

Je cherche à faire un UserForm où la personne entre un numéro composé de lettre, et en fonction de cette référence, une image s'affiche. J'ai toutes mes images dans un onglet, chacune associées à un numéro.

Je joints un exemple pour que cela soit plus clair.

Merci :)
21/02/2019, 10h05
Menhir

Citation:

Envoyé par kalista

Je joints un exemple pour que cela soit plus clair.

Je joints un lien pour que cela soit plus clair : https://www.developpez.net/forums/d8...s-discussions/

Citation:

Je cherche à faire un UserForm où la personne entre un numéro composé de lettre, et en fonction de cette référence, une image s'affiche. J'ai toutes mes images dans un onglet, chacune associées à un numéro.

Comment connaitre la relation entre le code entré et le nom de l'objet image ?

re c'est plus compliqué que cela
tes imags dans le sheets sont des pictures im faut faire une copie en bipmat ou !! metafile
tu a deux solutions soit utiliser un chart et faire une copie ,paste et export dans un fichier et loader le fichier dans le .picture du control image (activX)
soit u

tiliser les api et la il y a encore deux sous solutions

je t'en donne une qui est relativement simple

vire tout code de ton userform !!!
et met ceci

Code:

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
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
 
Private Sub CommandButton1_Click()
    Set cel = Sheets("Base de donnée").Range("A:A").Find(UCase(TextBox1.Text), , lookat:=xlWhole)
    If Not cel Is Nothing Then
        For Each SHAP In Sheets("Base de donnée").Shapes
            If SHAP.TopLeftCell.Row = cel.Row Then CopiePhoto SHAP
        Next
    End If
End Sub
Sub test()
End Sub
Sub CopiePhoto(Source)
    Dim FicTmp As String
    FicTmp = Environ("userprofile") & "\DeskTop\image.wmf"
    Source.CopyPicture    'xlScreen, xlBitmap
    OpenClipboard 0
    DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), FicTmp)
    CloseClipboard
    'On Error Resume Next
    Image1.Picture = LoadPicture(FicTmp)
'  Kill FicTmp
End Sub

Merci beaucoup pour cette aide.
Cela ne fonctionne pas pour l'instant, je cherche encore pourquoi.

A quoi renvoi le chemin "\DeskTop\image.wmf" svp ?

Citation:

Envoyé par patricktoulon

Code:

1
2
3
4
5
6
7
8
9
10
11
Sub CopiePhoto(Source)
    Dim FicTmp As String
    FicTmp = Environ("userprofile") & "\DeskTop\image.wmf"
    Source.CopyPicture    'xlScreen, xlBitmap
    OpenClipboard 0
    DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), FicTmp)
    CloseClipboard
    'On Error Resume Next
    Image1.Picture = LoadPicture(FicTmp)
'  Kill FicTmp
End Sub

21/02/2019, 15h46
patricktoulon

re

re
2016 il va te falloir adapter les api en 64 bits si tu es en excel 64 bit

le chemin avec environ et desktop c'est le bureau
21/02/2019, 15h59
unparia
Bonjour
desktop ? -->> pas nécessairement !

EDIT : chez moi mon bureau a ce chemin :
C:\Documents and Settings\......nom .....\Bureau

Environ étant trop limité, je l'extrais ainsi :
Code:

1 2 3 Dim oWSHShell As Object Set oWSHShell = CreateObject("WScript.Shell") chemin_bureau = oWSHShell.SpecialFolders("Desktop")

1 pièce(s) jointe(s)

re
bonjour

Code:

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
#If win64 Then    'si windows 64
    #If VBA7 Then    'si excel 64 dans windows 64
        Private Declare ptrsafe Function CloseClipboard Lib "user32" () As Long
        Private Declare ptrsafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare ptrsafe Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
        Private Declare ptrsafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
        Private Declare ptrsafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
    #Else    'si excel 32 dans windows 64
        Private Declare Function CloseClipboard Lib "user32" () As Long
        Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
        Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
        Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
        Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
    #End If
#Else    'si windows 32 et excel 32
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
    Private Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
    Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As Long) As Long
#End If
 
Private Sub CommandButton1_Click()
    Set cel = Sheets("Base de donnée").Range("A:A").Find(UCase(TextBox1.Text), lookat:=xlWhole)
    If Not cel Is Nothing Then
        For Each SHAP In Sheets("Base de donnée").Shapes
            If SHAP.TopLeftCell.Row = cel.Row Then CopiePhoto SHAP
        Next
    End If
End Sub
Sub test()
End Sub
Sub CopiePhoto(Source)
    Dim FicTmp As String
    'FicTmp = Environ("userprofile") & "\DeskTop\image.wmf"
    'ou
    With CreateObject("WScript.Shell"): FicTmp = .SpecialFolders("Desktop") & "\image.wmf": End With
    '
    Source.CopyPicture
    OpenClipboard 0: DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), FicTmp): CloseClipboard
    If Dir(FicTmp) <> "" Then Image1.Picture = LoadPicture(FicTmp)
    Kill FicTmp
End Sub

fichier a tester comme tel