XL 2013 Insérer dans un USF une image qui est dans une feuille

[erics83]

Bonjour,

Je cherche à insérer dans un userform une image. J'ai vu certains tutos ou exemples, mais impossible de le reproduire....ou alors, j'ai fait une fausse manip que je ne comprends pas...ou j'ai mal "reproduit" un code....et je n'ai pas compris comment JB manipulait les contrôle image dans son fichier "controle image.xls), donc...suis un peu "perdu", car j'ai beaucoup d'exemple avec des images enregistrées dans le disk dur, mais pas d'exemple (ou pas trouvé) sur des images dans le même fichier...
Pour faire simple (=une fois que j'aurais compris le code, je pourrais le reproduire), lorsque l'USF s'ouvre, il doit afficher l'image qui est en Feuil2....

Merci pour votre aide,

 

[patricktoulon]

pour les PCs éventuellement curieux qui entasse les macro4 dans un buffer
ben Exactement la même chose en déclarant les api

' __        _____  ___   .  ___         _____  ___             ___
'|__|  /\     |   |   |  | |     | /      |   |   | |   | |   |   | |\  |
'|    /__\    |   |---   | |     |/\      |   |   | |   | |   |   | | \ |
'|   /    \   |   |   \  | |___  |  \     |   |___| |___| |__ |___| |  \|
'
'***********************************************************************************
'                           COLLECTION IMAGE ET SHAPES
'exporter un object en gif(rnange,shapes et tout autre object present sur la feuille)
'version avec LES API USER32 ET GDI DECLAREES
' version 03/05/2013
'mise  à jour:12/09/2023
'transformation en fonction
'ajout de la supression auto du fichier quand c'est pour une copie dans le userform

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As LongPtr
Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Dim cheminT
Sub supperessionWMF1()
    If Dir(cheminT) <> "" Then Kill cheminT
End Sub
Function CopyOBJECTInImageWMF1(ObjecOrRange As Object, _
                               Optional cheminx As String = "", _
                               Optional NotTransparenceRange As Boolean = False, _
                               Optional DoNotKeepFile As Boolean = False) As String
    If cheminx = "" Then cheminx = ThisWorkbook.Path & "\image.wmf"
    cheminT = cheminx
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
    ObjecOrRange.CopyPicture
    If NotTransparenceRange = True Then
        With ObjecOrRange.Parent
            .Pictures.Paste
            DoEvents
            Set ShaP = .Shapes(.Shapes.Count)
            ShaP.Fill.Visible = msoTrue
            ShaP.Fill.ForeColor.RGB = vbWhite
            'Exit Function
            ShaP.CopyPicture
            ShaP.Delete
        End With
    End If
    T = Timer
    Do: DoEvents: hpicvail = ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC""," & 14 & ")")
        If Timer - T > 2 Then Exit Do
    Loop While hpicvail = 0
    If hpicvail = 0 Then MsgBox "il y a eu un problème l'ors de la copie de l'image": CopyOBJECTInImageWMF1 = "": Exit Function

    OpenClipboard 0
    DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), cheminx)
    CloseClipboard

    CopyOBJECTInImageWMF1 = cheminx
    If DoNotKeepFile Then Application.OnTime Now, "supperessionWMF1"

End Function

ben moi je dis que l'usine a gaz ne prends pas beaucoup de place hein

 

[Dranreb]

Bonjour.
D'accord, je suis convaincu, pour l'instant, surtout par les ExecuteExcel4Macro "CALL( … bien que je ne les maitrise pas du tout. …
Je me suis écrit ça, dans un UserForm de test que je réutiliserai probablement :

Option Explicit
Private Sub UserForm_Activate()
   ShapeImg(Me.Image1) = Feuil1.Shapes(1)
   End Sub
Private Property Let ShapeImg(ByVal Img As MSForms.Image, ByVal RHS As Excel.Shape)
Rem. Inspiré d'un code de patricktoulon
   Dim FicTemp As String, HImg As LongPtr, HEMF As LongPtr
   ExecuteExcel4Macro "CALL(""user32"",""OpenClipboard"",""JJ"",0)"
   ExecuteExcel4Macro "CALL(""user32"",""EmptyClipboard"",""J"")"
   ExecuteExcel4Macro "CALL(""user32"",""CloseClipboard"",""J"")"
   RHS.CopyPicture
   DoEvents
   Do While ExecuteExcel4Macro("CALL(""user32"",""IsClipboardFormatAvailable"",""JJC"",14)") = 0
      If MsgBox("Instruction: Shapes(""" & RHS.Name & """).CopyPicture" & vbLf & _
         "Le presse papier ne semble pas recevoir l'image.", _
         vbRetryCancel, "Property Set ShapeImg") = vbCancel Then Exit Property
      Loop
   ExecuteExcel4Macro "CALL(""user32"",""OpenClipboard"",""JJ"",0)"
   HImg = ExecuteExcel4Macro("CALL(""user32"",""GetClipboardData"",""JJ"",14)")
   FicTemp = Environ$("UserProfile") & "\DeskTop\Temp.wmf"
   HEMF = ExecuteExcel4Macro("CALL(""gdi32"",""CopyEnhMetaFileA"",""JJC""," & HImg & ",""" & FicTemp & """)")
   ExecuteExcel4Macro "CALL(""gdi32"",""DeleteEnhMetaFile"",""JJ""," & HEMF & ")"
   ExecuteExcel4Macro "CALL(""user32"",""CloseClipboard"",""J"")"
   Img.Picture = LoadPicture(FicTemp): Kill FicTemp
   End Property

Mais c'est quand même une énorme lacune que rien n'existe dans aucune bibliothèque couramment utilisée qui sache le faire sans passer par un fichier !

 

[patricktoulon]

re
Bonjour @Dranreb
rectification avec les api si on continu avec l'api oléécreatepictureindirect on peut créer un ipicture ou ipicturedisp si tu préfère
sauf que la on perd la transparence
j'en ai fait une fonction réutilisable mais si tu veux oui tu peux faire comme ça

en post#31 je le donne avec l’écriture classique avec les déclaration vba vba7
j'explique
exemple
en macro4

ExecuteExcel4Macro "CALL(""user32"",""OpenClipboard"",""JJ"",0)"

en normal maintenant

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
sub test()
openclibboard 0
end sub

le 1er "J "c'est le type du return de la fonction (toujours!!!)
le second "j" c'est le type de l'argument 1(en rouge )
le zero en vert c'est la valeur de l'argument

ceci ci dessous
""user32"",""OpenClipboard""
est = à cela ci dessous
Private Declare PtrSafe Function OpenClipboard Lib "user32"

je ne pense pas devoir t'expliquer ce que veut dire "Call"

extrait de mon module tutoriel

'Types de données pour type_string: argument(chaîne_type)

'B - nombre à virgule flottante de 8 octets (IEEE), transféré par valeur, type C double.

'C - Chaîne terminée par zéro (null) (longueur max. = 255 caractères), transférée par référence, type C char *

'F - Chaîne terminée par zéro (null) (longueur max. = 255 caractères), transférée par référence (modifier sur place) , Type C char *

'J - entier signé de 4 octets de large, transféré par valeur, type C long int

'P - structure de données OPER d'Excel, transféré par référence, type C OPER *

'R - structure de données XLOPER d'Excel, transféré par référence, type C XLOPER *

 

[Dranreb]

Ça signifie quoi "J" ? Long je suppose … Et en 64bits pour LongLong ou LongPtr, ce serait quoi ?

 

[patricktoulon]

C'EST PAREIL EN 64
c'est ca qui est bien
de la même maniere que certaine api qui demande du longlong quand on les declare avec "&" ben elles fonctionnent
il est gentils hein vba

 

[Dranreb]

Il resterait quand même à récupérer le résultat d'un ExecuteExcel4Macro("CALL… renvoyant un handle dans une variable qui n'entrainerait pas un dépassement de capacité. Mais Double pourrait peut être aussi bien faire l'affaire que LongPtr ou LongLong.

 

[patricktoulon]

ben c'est pareil
exemple
dim Hwnd as long 'ou longptr 'on s'en fou en fait
hwnd = ExecuteExcel4Macro("CALL(""user32"",""FindWindowA"",""JCC""," & """" & ClassName & """" & ", " & """" & Caption & """)")

remarque le "JCC"
le "J" c'est le return
le "C" c'est la conversion addresse mémoire de classname 255 char max
l'autre "C" c'est la conversion addresse memoire de texte de la caption de la fenêtre 255 char max

comme tu peux le voir on peut récupérer le resultat de la fonction
je t'invite à regarder si ça t'intéresse

episode 1

démonstration de l'utilisation des api en Excelmacro4 épisode 1 la barre de titre des userforms

UTILISATION DES API AVEC EXECUTEEXCEL4MACRO ÉPISODE 1 très souvent on peine a déclarer nos api en fonction de la version d'excel 32/64 bits ce fichier vous montre un certain nombre de possibilités quand à l'utilisation des api avec...

excel-downloads.com

episode 2

démonstration de l'utilisation des api en Excelmacro4 episode 2 les frames transparentes

la transparence des frames Bonjour à tous je continu dans la démonstration d'utilisation des api avec executeexcel4macro dans cet épisode on va rendre les frames transparentes comme dans l'épisode 1 on a pas de déclaration d'api a faire...

excel-downloads.com

episode 3

démonstration de l'utilisation des api en Excelmacro4 episode 3 la transparence dans userform

De la transparence dans les Userforms en utilisant les apis en macro 4 Bonjour à tous je continu dans la démonstration d'utilisation des api avec executeexcel4macro dans cet épisode vous trouverez comment jouer avec la transparence pour les...

excel-downloads.com

episode 4

démonstration de l'utilisation des api en Excelmacro4 episode 4 diverses fonctions

diverses fonctions ou Sub utilisant les apis en macro 4 Bonjour à tous je continu dans la démonstration d'utilisation des api avec executeexcel4macro dans cet épisode vous trouverez diverses fonctions notamment la "pointtopixel "avec la...

excel-downloads.com

 

[patricktoulon]

re
pour en finir avec cette shape collée dans le control image (sujet de départ de ce topic)
j'ajouterais qu'en général un ".wmf" fait la moitié du".jpg" en terme de poids

 

[Dranreb]

Ben non, si la valeur d'une expression est supérieure à &H7FFFFFFF elle ne peut plus être affectée à un Long.
Ça ne marchera que pour des Handle courts d'objets Windows principalement. Pour des Handle de plages de mémoires alouées dynamiquement par exemple ça finira forcément par planter en dépassement de capacité.

 

[patricktoulon]

a ben c'est certain qu'il y a des limites
perso je m'en sert pour des fonctions bien persos après je ferais pas tout une app avec
après tu a les combinaisons
JJ
JC
JCJ
JCC
JJJJJJ' LE MAX
JJCJJC' marche sur certaines api pour "As Any"
par exemple pour setcursorposici on combine *2

ExecuteExcel4Macro ("CALL(""user32"",""SetCursorPos"",""JJJJJ""," & 100 & ", " & 400 & ")")

pour les structures j'y suis jamais arrivé
et je ne les connais pas toutes il y en a d'autres
on trouve ça le plus souvent sur des sites chinois écrit en chinois et le translate n'est pas tout le temps
efficace ,je patauge très souvent et très longtemps avant de bien en maitriser une

 

[patricktoulon]

re
tiens c'est kado
puré j'ai ressorti ma vielle clé usb l'explorer a mi 100 ans a m'afficher le dossier
alors toi qui parlais de se passer de fichier dynamique voila en format bitmap avec un clisd
on est loin de l'usine a gaz de stephen bullen qui marche tres bien d'ailleurs mais je prend un raccourci avec le clisd
purée c'est vieux ça puré j'ai mal au dos d'un coup

alors prend un fichier vierge
met lui un userform et control image picturesizeclip
un module et colle lui ça

'capturer une plage en bitmap et créer une image en memoire (Ipicture)pour
's'en servir dans un control image dans un userform
'patricktoulon sur developpez.com
'utilisation d'un  clisd pour la structure IPictureIID
'date/22/03/2010
' api creation object image
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As Integer) As Long
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'rectangle
Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
'guid all propertie pour le jpg
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(8) As Byte: End Type
' info image
Private Type PICTDESC: cbSize As Long: picType As Long: hImage As Long: End Type

Sub test()    'teste pour voir un range dans l'userform
    EmptyClipboard
    Range("A1:c8").Copy
    LaisseLeClipboardDigérer
    With UserForm1
        .Show 0
        .Image1.Picture = TakePictureOnClipboard
    End With
End Sub 'nouveau on utilise le clisd pour la creation du conteneur BIPMAP
'reduction considerable du code
'Attention !!fonctionne que pour du BITMAP PAS POUR DU (WMF(XLPICTURE))
Function TakePictureOnClipboard()
    Dim iPic As IPicture, hCopy&, tIID As GUID, tPICTDEST As PICTDESC
    OpenClipboard 0&
    hCopy = CopyImage(GetClipboardData(&H2), 0, 0, 0, &H8)
    CloseClipboard
    If hCopy = 0 Then Exit Function
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Exit Function
    With tPICTDEST: .cbSize = Len(tPICTDEST): .picType = 1: .hImage = hCopy: End With
    Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
    If Ret Then Exit Function
    Set TakePictureOnClipboard = iPic
End Function

Function LaisseLeClipboardDigérer()
    Dim hPicAvail
    x = Timer
    Do While hPicAvail = 0
        hPicAvail = IsClipboardFormatAvailable(2) '2 pour le format bitmap
        If Timer - x > 1 Then Exit Do
    Loop
    LaisseLeClipboardDigérer = hPicAvail = 1
End Function

bon on a pas la transparence mais tu a ta copie dans le userform
purée ça marche encore dis donc !!!!

edit :
bien sur comme Ipic est une image a part entiere (Ipicture)
si tu veux sauver l'image tu peux sauver l'image avec savepicture

SavePicture iPic, Environ("userprofile") & "\DeskTop\monimage.bipmap"

 

[Dudu2]

Bonjour,
Il est vrai que les images de Range ont une qualité légèrement altérée, ce qui n'est pas le cas des "vraies" images. Ce n'est pas dû à l'Export du Chart mais au format GIF. En PNG c'est meilleur mais hélas pas utilisable en Control Image. Alors les Range qui n'ont pas forcément besoin de transparence peuvent être exportés en JPG.

Edit: Finalement pour exporter le fichier image, le mieux est effectivement le format EMF.

 

[Dudu2]

D'ailleurs, on peut se passer de fichier intermédiaire puisque CopyEnhMetaFile peut travailler en mémoire.
Un exemple en utilisant la fonction PastePicture de STEPHEN BULLEN.

 

[patricktoulon]

re
ben bien sur que l'on peut se passer de fichier intermédiaire avec olecreatepictureindirect
je l'ai dis plus haut
sauf qu'en macro4 les arguments de type structure ne passe passent pas il faut les convertir en address mémoire

 

[patricktoulon]

re
à l’époque pour le wmf avant de decider d'utiliser les macro4
je l'avais reduit à ça

Private Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PicDesc, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal Hclip As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Private Type PicDesc: Size As Long: Type As Long: hPic As LongPtr: hPal As LongPtr: End Type

Function copyxlPicture(obj) As IPicture
    Dim hCopy As LongPtr, Pictstructure As PicDesc, DispatchInfo As GUID, IPic As IPicture, T#
    obj.CopyPicture
    OpenClipboard 0
    T = Timer
    Do While hCopy = 0
        hCopy = CopyEnhMetaFileA(GetClipboardData(14), vbNullString)
        If Timer - T > 1 Then Exit Do
    Loop
    CloseClipboard
    If hCopy = 0 Then Set copyxlPicture = IPic: Exit Function ' si pas de handleimage WMF dans clip on arrete tout
    
    With DispatchInfo
        .Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A: .Data4(0) = &H8B: .Data4(1) = &HBB
        .Data4(2) = &H0: .Data4(3) = &HAA: .Data4(4) = &H0: .Data4(5) = &H30: .Data4(6) = &HC: .Data4(7) = &HAB
    End With

    With Pictstructure: .Size = Len(Pictstructure): .Type = 4: .hPic = hCopy: .hPal = 0: End With

    OleCreatePictureIndirect Pictstructure, DispatchInfo, True, IPic
    
    Set copyxlPicture = IPic
End Function

dans le userform (ou ailleurs)

userform1.Image1.picture=copyxlPicture(activesheet.shapes("blablabla"))

je ne sais pas si les déclarations vont $etre bonne pour le 64 en tout cas chez moi en 32 c'est OK