How do I convert a stdole.StdPicture to a different Type?

有些话、适合烂在心里 提交于 2021-02-19 05:02:48

问题


To receive the bounty, please provide an answer with working code. Thanks.

I have a stdole.StdPicture Object of the Type vbPicTypeIcon. I need to convert it to Type vbPicTypeBitmap. Due to project contraints, I need to be able to do this using Win32 or VBA. I am trying to load a file's icon to a command bar button. Here is what I have so far. It produces a lovely black square:) I am really new to graphics land so pardon me if it's a basic question.

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

回答1:


Give this post at vbAccelerator.com a shot.

Edit: The closest thing I found for VBA is this post on officeblogs.net. The code takes an icon instead of an icon handle though.




回答2:


Okay, I have cleaned up the code. The ExtractAssociatedIcon method is returning a 64x64 icon so for the example I have just hard coded that size. The picturebox has neen removed and the image is assigned to the form's picture property to avoid confusion.

Example: copy the code to a new form and run

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



回答3:


Search Google Groups for a thread entitled, Convert StdPicture from Icon to Bitmap.

UPDATE

No, I can't get it to work either.

But I was getting a terrible sense of deja vu as I was trying it... then remembered I definitely did this a couple of years ago i.e. adding icons with masks to Excel CommandBarButtons at runtime, not knowing which version of Excel it was being opened in. Sadly I can't find the code (not in source control so didn't make it to release? I'm almost sure I got it working).

I think I borrowed heavily from these articles:

How To Create a Transparent Picture For Office CommandBar Buttons

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

And because Excel has no clipboard, I seem to recall borrowing from Stephen Bullen's PastePicture.zip.

Hope this doesn't send you off on a wild goose chase :)




回答4:


LoadPicture It returns an object that supports IPictureDisp. It may not be vbPicTypeBitmap though. Not sure if you can call GdipCreateBitmapFromFile in VBA.



来源:https://stackoverflow.com/questions/1507385/how-do-i-convert-a-stdole-stdpicture-to-a-different-type

标签
易学教程内所有资源均来自网络或用户发布的内容,如有违反法律规定的内容欢迎反馈
该文章没有解决你所遇到的问题?点击提问,说说你的问题,让更多的人一起探讨吧!