Comment convertir une image stdole.StdPicture en un type différent?

Question

Pour recevoir la prime, veuillez fournir une réponse avec le code de travail. Merci.

J'ai un objet stdole.StdPicture du type vbPicTypeIcon. J'ai besoin de le convertir en Type vbPicTypeBitmap. En raison des contraintes du projet, je dois être capable de le faire en utilisant Win32 ou VBA. J'essaie de charger l'icône d'un fichier dans un bouton de la barre de commande. Voici ce que j'ai jusqu'ici. Il produit un joli carré noir :) Je suis vraiment nouveau à la terre graphique alors pardonnez-moi si c'est une question fondamentale.

Option Explicit 

Private Const vbPicTypeBitmap As Long = 1 
Private Const vbPicTypeIcon As Long = 3 

Private Const SHGFI_ICON As Long = &H100& 
Private Const SHGFI_SMALLICON As Long = &H1& 

Private Type PICTDESC 
    cbSize As Long 
    pictType As Long 
    hIcon As Long 
    hPal As Long 
End Type 

Private Type typSHFILEINFO 
    hIcon As Long 
    iIcon As Long 
    dwAttributes As Long 
    szDisplayName As String * 260 
    szTypeName As String * 80 
End Type 

Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long 
Private Declare Function SHGetFileInfoA Lib "shell32.dll" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As typSHFILEINFO, ByVal cbSizeFileInfo As Long, ByVal uFlags As Long) As Long 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As Any, ByVal fOwn As Long, ipic As stdole.IPictureDisp) As Long 

Public Sub Test() 
    Dim btn As Office.CommandBarButton 
    Dim lngRslt As Long 
    Dim lngAppInstc As Long 
    Dim strFilePath As String 
    Dim tFI As typSHFILEINFO 
    Dim pic As stdole.IPictureDisp 
    Set btn = TestEnv.GetTestButton 
    lngAppInstc = Excel.Application.Hinstance 
    strFilePath = TestEnv.GetTestFile 
    If LenB(strFilePath) = 0& Then 
     Err.Raise 70& 
    End If 
    SHGetFileInfoA strFilePath, 0&, tFI, LenB(tFI), SHGFI_ICON Or SHGFI_SMALLICON 
    Set pic = IconToPicture(tFI.hIcon) 
    btn.Picture = pic 
Exit_Proc: 
    On Error Resume Next 
    If tFI.hIcon Then 
     lngRslt = DestroyIcon(tFI.hIcon) 
    End If 
    Exit Sub 
Err_Hnd: 
    MsgBox Err.Description, vbCritical Or vbMsgBoxHelpButton, Err.Number, Err.HelpFile, Err.HelpContext 
    Resume Exit_Proc 
    Resume 
End Sub 

Private Function IconToPicture(ByVal hIcon As Long) As stdole.IPictureDisp 
    'Modified from code by Francesco Balena on DevX 
    Dim pic As PICTDESC 
    Dim guid(0 To 3) As Long 
    Dim pRtnVal As stdole.IPictureDisp 
    pic.cbSize = LenB(pic) 
    'pic.pictType = vbPicTypeBitmap 
    pic.pictType = vbPicTypeIcon 
    pic.hIcon = hIcon 
    ' this is the IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB} 
    ' we use an array of Long to initialize it faster 
    guid(0) = &H7BF80980 
    guid(1) = &H101ABF32 
    guid(2) = &HAA00BB8B 
    guid(3) = &HAB0C3000 
    ' create the picture, 
    ' return an object reference right into the function result 
    OleCreatePictureIndirect pic, guid(0), True, pRtnVal 
    Set IconToPicture = pRtnVal 
End Function 

Answer 1

Donnez this post à vbAccelerator.com un tir.

Modifier: La chose la plus proche que j'ai trouvé pour VBA est ce poste sur officeblogs.net. Le code prend une icône au lieu d'un handle d'icône si.

Answer 2

D'accord, j'ai nettoyé le code. La méthode ExtractAssociatedIcon renvoie une icône 64x64 donc pour l'exemple, j'ai juste codé cette taille. La zone d'image n'a pas été supprimée et l'image est affectée à la propriété d'image du formulaire pour éviter toute confusion.

Exemple: copier le code à une nouvelle forme et exécuter

Option Explicit 

Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long 
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long 
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long 
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long 
Private Declare Function DrawIconEx Lib "user32" (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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PICTDESC_BMP, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long 

Private Type GUID 
    Data1 As Long 
    Data2 As Integer 
    Data3 As Integer 
    Data4(7) As Byte 
End Type 

Private Type PICTDESC_BMP 
    Size As Long 
    Type As Long 
    hBmp As Long 
    hPal As Long 
    Reserved As Long 
End Type 

Const DI_MASK = &H1 
Const DI_IMAGE = &H2 
Const DI_NORMAL = DI_MASK Or DI_IMAGE 

Private Type RECT 
     Left As Long 
     Top As Long 
     Right As Long 
     Bottom As Long 
End Type 

Private Sub Form_Load() 

    Call GetIcon("C:\Program Files\Internet Explorer\iexplore.exe") 

End Sub 

Private Sub GetIcon(ByVal sFileName As String) 
    Dim hIcon As Long 
    Dim hAssocIcon As Long 
    Dim sAssocFile As String * 260 
    Dim sCommand As String 
    Dim lDC As Long 
    Dim lBmp As Long 
    Dim R As RECT 
    Dim OldBMP As Long 

    Me.AutoRedraw = True 
    hIcon = ExtractAssociatedIcon(App.hInstance, sFileName, hAssocIcon) 
    If hIcon <> 0 Then 'no icons found - use icon generic icon resource 
     'Create a device context, compatible with the screen 
     lDC = CreateCompatibleDC(GetDC(0&)) 
     'Create a bitmap, compatible with the screen 
     lBmp = CreateCompatibleBitmap(GetDC(0&), 64, 64) 
     'Select the bitmap into the device context 
     OldBMP = SelectObject(lDC, lBmp) 
     ' Set the rectangles' values 
     R.Left = 0 
     R.Top = 0 
     R.Right = 64 
     R.Bottom = 64 
     ' Fill the rect with white 
     FillRect lDC, R, 0 
     ' Draw the icon 
     Call DrawIconEx(lDC, 0, 0, hIcon, 64, 64, 0, 0, DI_NORMAL) 
     Me.Picture = PictureFromBitmap(lBmp, 0&) 
     DestroyIcon (hIcon) 
    End If 
    Call SelectObject(lDC, OldBMP) 
    Call DeleteObject(lDC) 

End Sub 

Private Function PictureFromBitmap(ByVal hBmp As Long, ByVal hPal As Long) As StdPicture 
    Dim IPictureIID As GUID 
    Dim IPic As IPicture 
    Dim tagPic As PICTDESC_BMP 
    Dim lpGUID As Long 

    ' Fill in the IPicture GUID 
    ' {7BF80980-BF32-101A-8BBB-00AA00300CAB} 
    With IPictureIID 
     .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 

    ' Set the properties on the picture object 
    With tagPic 
     .Size = Len(tagPic) 
     .Type = vbPicTypeBitmap 
     .hBmp = hBmp 
     .hPal = hPal 
    End With 

    ' Create a picture that will delete it's bitmap when it is finished with it 
    Call OleCreatePictureIndirect(tagPic, IPictureIID, 1, IPic) 

    ' Return the picture to the caller 
    Set PictureFromBitmap = IPic 
End Function 

Answer 3

LoadPicture Elle retourne un objet qui prend en charge IPictureDisp. Il se peut que ce ne soit pas vbPicTypeBitmap. Vous ne savez pas si vous pouvez appeler GdipCreateBitmapFromFile dans VBA.

Answer 4

Recherchez dans Google Groupes un fil intitulé, Convert StdPicture from Icon to Bitmap.

MISE À JOUR

Non, je ne peux pas le faire fonctionner non plus. Mais j'ai eu un terrible sentiment de déjà vu quand je l'essayais ... puis je me suis souvenu que je l'avais fait il y a quelques années, ie ajouter des icônes avec des masques à Excel CommandBarButtons à l'exécution, ne sachant pas quelle version d'Excel il a été ouvert en. Malheureusement je ne peux pas trouver le code (pas dans le contrôle de la source, donc je ne l'ai pas fait sortir, je suis presque sûr que ça marche).

Je pense que je lourdement endettées de ces articles:

How To Create a Transparent Picture For Office CommandBar Buttons

How To Set the Mask and Picture Properties for Office XP CommandBars

Et parce que Excel n'a pas le presse-papiers, il me semble rappeler les emprunts de Stephen Bullen de PastePicture.zip.

espère que cela ne vous envoie pas partir en chasse de l'oie sauvage :)