XL 2019 Image dans UserForm

[JLR67]

Bonjour le Forum,

Je souhaiterais savoir s'il est possible d'incérer une image dans un UserForm, en sachant que cette image peut être modifiée sur le fichier (en fait, c'est une copie d'un TCD, avec lien)
Et si oui avez vous une solution pour moi.
Ci joint petit fichier en exemple sur lequel la copie de l'image se par par la propriété Picture (mais malheureusement la mise à jour n'est pas possible).
Merci à ceux qui voudront bien me venir en aide

 

[sylvanu]

Bonjour JLR,
Comme je ne sais pas intégrer l'image présent dans le classeur dans un userform, je triche.
Je rafraichit le TCD
J'exporte le TCD sous forme d'image et l'enregistre.
Je met ce fichier comme image dans l'userform.
Je supprime ce fichier image.
NB: La feuille Image devient donc inutile.

 

[JLR67]

Bonjour Sylvanu,

Merci d'avoir pris le temps de répondre à ma demande. C'est là qu'on reconnait les grands de ce monde de la programmation Excel. Le fichier retourné correspond exactement à mes besoins.
Super et encore merci

 

[patricktoulon]

re
Bonsoir tout les deux

Comme je ne sais pas intégrer l'image présent dans le classeur dans un userform, je triche.

sinon on crée un pictureDISP en memoire
sans passer par un export fichier externe
a peine un peu de recherche vous auriez trouvé je l'ai donné plusieurs fois

donc dans cet exemple mon module WMF3 qui fait exactement ça
pour le coup bien évidemment je supprime la feuille image qui n'est plus nécessaire
le Ipicture contenant les data de la capture du pivotTable(1) de la feuille base va directement dans le controls Image1 de l'userform

maintenant vous savez comment on fait

 

[sylvanu]

Bonsoir Patrick,
Si j'avais déjà vu, mais incompatible de ma config.
Je ne sais pas si c'est ma version VBA (V6.3) ou autre chose mais cela coince sur les type, du genre himage As LongPtr. Et je n'ai jamais vraiment approfondi.

 

[patricktoulon]

ok donne moi 5 minute je te le fait compatible avec 2007 et vb6

 

[patricktoulon]

re
voila
j'ai un doute sur la Olecreatepictureindirecte essaie l'autre si ça ne fonctionne pas en bloquant la première
code complet du module

'******************************************************************************************************************************************************
'    ___      _     _______  __      _    ____  _   _  _______  ___      _   _    _    ___      _     _.
'   //  \\   /\\      //    // \\   //   //    //  //    //    //  \\   //  //   //   //  \\   //|   //
'  //___//  //__\    //    //__//  //   //    //__||    //    //   //  //  //   //   //   //  // |  //
' //       //   \\  //    //  \\  //   //    //  \\    //    //   //  //  //   //   //   //  //  | //
'//       //    // //    //   // //   //___ //    \\  //     \\__//  //__//   //___ \\__//  //   |//
'******************************************************************************************************************************************************


'capturer une plage ou un object en wmf et créer une image en memoire (Ipicture)pour
's'en servir dans un control image dans un userform
'patricktoulon sur developpez.com
'date/22/03/2010
'remasteurisation du code date: 12/09/2023
' api creation object image
Option Explicit
#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
   Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
    Declare PtrSafe Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As LongPtr, ByVal Direction As String) As LongPtr
    Declare PtrSafe Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function CopyEnhMetaFileA Lib "gdi32" (ByVal HwndImage As Long, ByVal Direction As String) As Long
    
   ' Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
    Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, riid As GUID, ByVal fOwn As Long, ppvObj As IPicture) As Long


#End If

Type RECT: Left As Long: top As Long: Right As Long: BOTTOM As Long: End Type
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Type PICTDESC: cbSize As Long: picType As Long: himage As LongPtr: hPal As LongPtr: End Type

Function copyxlPicture(obj, Optional Ex_transparency As Boolean = False) As IPicture
    Dim PictStructure As PICTDESC, DispatchInfo As GUID, IPic As IPicture, T#, p, Shap
    #If VBA7 Then
        Dim hCopy As LongPtr
    #Else
        Dim hCopy As Long
    #End If
    obj.CopyPicture
    Set p = obj.Parent
    If Ex_transparency = True Then
        p.Paste: Set Shap = p.Shapes(p.Shapes.Count)
        Shap.Fill.Visible = msoTrue: Shap.Fill.ForeColor.RGB = vbWhite: Shap.CopyPicture: Shap.Delete
    End If
    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: .cbSize = Len(PictStructure): .picType = 4: .himage = hCopy: .hPal = 0: End With
    OleCreatePictureIndirect PictStructure, DispatchInfo, True, IPic
    Set copyxlPicture = IPic
End Function

 

[sylvanu]

Merci Patrick,
J'avais déjà modifié les PtrSafe, sans résultat.
Ca coince sur les LongPtr qui ne sont pas reconnus par VBA6. ( le Longptr reste ainsi sans être mis en majuscules donc n'est pas reconnu )
Bon pas grave.
Le futur lecteur aura une version VBA6 et une version VBA7.

 

[patricktoulon]

Bonjour
ca ne fonctionne pas avec le code du post #7?
ça devrait pourtant j'ai testé sur 2007 chez moi

 

[sylvanu]

Re,
Il ne connait pas le typage LongPtr :

 

[patricktoulon]

re
celui là devrait fonctionner il fonctionne avec mon pc portable W7 2007 en vb6

 

[sylvanu]

Merci Patrick. Hé hop, dans ma besace. ( Je n'ai plus qu'à le décortiquer ! )

 

[job75]

Bonjour JLR67, sylvanu, Patrick,

L'utilisation d'un graphique auxiliaire est quand même la solution la plus simple :

Private Sub UserForm_Initialize()
Dim fichier$
fichier = ThisWorkbook.Path & "\MonImage.jpg"
ThisWorkbook.RefreshAll
With ActiveSheet.PivotTables(1).TableRange2
    .CopyPicture xlScreen, xlBitmap 'copie dans le presse-papiets
    With ActiveSheet.ChartObjects.Add(2000, 0, .Width, .Height).Chart
        .Parent.Activate
        Do: .Paste: DoEvents: Loop While .Shapes.Count = 0 'en attente du collage
        .Export fichier
        .Parent.Delete
    End With
End With
Image1.Picture = LoadPicture(fichier)
Kill fichier
End Sub

A+

 

[patricktoulon]

re
@job75
oui mais plus lourd à l’exécution
mes modules sont autonome
c'est des fonctions utilisables comme tel de 2007 à 2021
tu colle dans un module tu utilise

de plus la qualité de la capture avec un graph dépend de la qualité de ta carte graphique à l'inverse le wmf est basé sur les data de la capture
la meilleur qualité d'export avec un graph est le png mais il n'arrive pas à la qualité du wmf

 

[patricktoulon]

re
iens pour @job75 voici une capture qui montre deux instances de paint
qui contiennent
l'une la capture JPG (à droite) par graph et l'autre en WMF( à gauche)
j'ai zoomé pour que l'on voit bien la différence

dans le zip les deux capture aux deux formats je te laisse juger avec ton application image