Charger une image avec une transparence alpha sur un userform à partir d'un chemin

Question

Je souhaite placer une image dans un contrôle d'image VBA UserForm et conserver sa transparence (transparence on-off 1 bit comme dans un fichier ico, ou mieux; transparence de canal alpha complet comme un png peut avoir). En d'autres termes, les parties de l'image qui sont transparentes dans le fichier d'origine sont également transparentes sur mon formulaire utilisateur, ce qui me permet de superposer des images par exemple.

---

Tout d'abord, je ne pouvais pas trouver une réponse sur le SO, donc je devais regarder autres forums. J'ai trouvé une méthode qui prend en charge la transparence on/off 1 bit, je la posterai comme une réponse, maintenant on peut la trouver plus facilement ici.

Mais la méthode que j'ai trouvé charges images du presse-papiers, ce qui signifie charger à partir d'un filepath je dois

ActiveSheet.Pictures.Insert("[filepath]").Cut 
myUserform.someImageControl.Picture = PastePicture 

qui semble lent et alambiqué, et efface également le presse-papiers, alors je me demande s'il y a un bon moyen de charger des images transparentes à un userform à partir d'un chemin de fichier (sans utiliser de presse-papier)?

---

Le deuxième point est que le code actuel je regarde terrible (les résultats qui est, bien que le code lui-même est un peu en désordre). Pour obtenir de meilleurs résultats, je suis surpris qu'il n'y ait pas de cadre que je puisse référencer qui renvoie un IPictureDisp avec transparence.

Le image Windows v2.0 Aquisition Bibliothèque (wiaaut.dll) peut être utilisé pour charger PNGs à un contrôle - par exemple

Function loadImg(fileLocation As String) As IPictureDisp 
Dim imgctrl As New WIA.ImageFile   'can handle more extensions than built in LoadPicture function 
With imgctrl 
    .LoadFile fileLocation 
    Set loadImg = .fileData.Picture 
End With 
Set imgctrl = Nothing 
End Function 

Cependant, il supprime la transparence qui n'est pas bonne. Donc, je pose cette question pour mettre en commun les ressources sur les méthodes alternatives que les gens connaissent (le cas échéant), et qui fournissent les meilleurs résultats?

Answer 1

Pour référence, dans le cas où il n'y a pas de copie sur SO quelque part ailleurs: voici une fonction qui peut être utilisée à la place de LoadPicture pour appliquer une image à un Image Control sur un userform. Il ne supporte que 1 transparence bits (pixel est visible ou à savoir ce n'est pas)

Option Explicit 
Option Compare Text 

''' User-Defined Types for API Calls 

'Declare a UDT to store a GUID for the IPicture OLE Interface 
Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(0 To 7) As Byte 
End Type 

'Declare a UDT to store the bitmap information 
Private Type uPicDesc 
    Size As Long 
    Type As Long 
    hPic As Long 
    hPal As Long 
End Type 

'''Windows API Function Declarations 

'Does the clipboard contain a bitmap/metafile? 
Private Declare Function IsClipboardFormatAvailable Lib "user32" (_ 
         ByVal wFormat As Integer) As Long 

'Open the clipboard to read 
Private Declare Function OpenClipboard Lib "user32" (_ 
         ByVal hwnd As Long) As Long 

'Get a pointer to the bitmap/metafile 
Private Declare Function GetClipboardData Lib "user32" (_ 
         ByVal wFormat As Integer) As Long 

'Close the clipboard 
Private Declare Function CloseClipboard Lib "user32"() As Long 

'Convert the handle into an OLE IPicture interface. 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (_ 
         PicDesc As uPicDesc, RefIID As GUID, _ 
         ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long 

'Create our own copy of the metafile, so it doesn't get _ 
'wiped out by subsequent clipboard updates. 
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (_ 
     ByVal hemfSrc As Long, ByVal lpszFile As String) As Long 

'Create our own copy of the bitmap, so it doesn't get wiped out by 
'subsequent 
'clipboard updates. 
Declare Function CopyImage Lib "user32" (ByVal handle As Long, _ 
             ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _ 
             ByVal un2 As Long) As Long 

'The API format types we're interested in 
Const CF_BITMAP = 2 
Const CF_PALETTE = 9 
Const CF_ENHMETAFILE = 14 
Const IMAGE_BITMAP = 0 
Const LR_COPYRETURNORG = &H4 

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture 
    'Some pointers 
    Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long 
    Dim lPicType As Long, hCopy As Long 

    'Convert xl piture-type constant to the API constant equivalent 
    lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE) 

    'Check if the clipboard contains the required format 
    hPicAvail = IsClipboardFormatAvailable(lPicType) 

    If hPicAvail <> 0 Then 
     'Get access to the clipboard 
     h = OpenClipboard(0&) 

     If h > 0 Then 
      'Get a handle to the image data 
      hPtr = GetClipboardData(lPicType) 

      'Create our own copy of the image on the clipboard, in the appropriate format. 
      If lPicType = CF_BITMAP Then 
       hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) 
      Else 
       hCopy = CopyEnhMetaFile(hPtr, vbNullString) 
      End If 

      'Release the clipboard to other programs 
      h = CloseClipboard 

      'If we got a handle to the image, convert it into a Picture object and return it 
      If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType) 
     End If 
    End If 

End Function 

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, _ 
           ByVal lPicType) As IPicture 

    ' IPicture requires a reference to "OLE Automation" 
    Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture 

    'OLE Picture types 
    Const PICTYPE_BITMAP = 1 
    Const PICTYPE_ENHMETAFILE = 4 

    ' Create the Interface GUID (for the IPicture interface) 
    With IID_IDispatch 
     .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 

    ' Fill uPicInfo with necessary parts. 
    With uPicInfo 
     .Size = Len(uPicInfo) 
     .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) 
     .hPic = hPic 
     .hPal = IIf(lPicType = CF_BITMAP, hPal, 0) 
    End With 

    ' Create the Picture object. 
    r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic) 

    ' If an error occured, show the description 
    If r <> 0 Then 
     'Debug.Print "Create Picture: " & fnOLEError(r) 
Debug.Print "Error, call fnOLEError(r) here" 
     ' fnOLEError from modPastePicture not posted 
    End If 

    ' Return the new Picture object. 
    Set CreatePicture = IPic 

End Function 

Source with minor edits

Original source est pastePicture.zip

utilisation de Stephen Bullen comme:

Set myImageControl.Picture = PastePicture