Vba 如何将stdole.StdPicture转换为其他类型？

要获得赏金，请提供带有工作代码的答案。谢谢

我有一个VBPictTypeIcon类型的stdole.StdPicture对象。我需要将其转换为VBPictTypeBitmap类型。由于项目限制，我需要能够使用Win32或VBA完成此操作。我正在尝试将文件的图标加载到命令栏按钮。这是我到目前为止所拥有的。它产生了一个可爱的黑色正方形：）我对图形领域真的很陌生，所以如果这是一个基本问题，请原谅我

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

在vbAccelerator.com上试一试

---

编辑：我在VBA上找到的最接近的东西是这篇文章。代码采用图标而不是图标句柄。

好的，我已经清理了代码。ExtractAssociatedIcon方法返回一个64x64图标，因此对于示例，我刚刚硬编码了该大小。picturebox未被删除，图像已指定给窗体的picture属性以避免混淆

示例：将代码复制到新表单并运行

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

选项显式
私有声明函数ExtractAssociatedIcon Lib“shell32.dll”别名“ExtractAssociatedIconA”（ByVal hInst为长，ByVal lpIconPath为字符串，lpiIcon为长）为长
私有声明函数DestroyIcon Lib“user32”（ByVal hIcon，长）长
私有声明函数DeleteObject Lib“gdi32”（ByVal hObject As Long）为Long
私有声明函数GetDC Lib“user32”（ByVal hwnd作为Long）作为Long
私有声明函数CreateCompatibleDC Lib“gdi32”（ByVal hdc作为Long）作为Long
私有声明函数CreateCompatibleBitmap Lib“gdi32”（ByVal hdc为长，ByVal nWidth为长，ByVal nHeight为长）为长
私有声明函数FillRect Lib“user32”（ByVal hdc为Long，lpRect为RECT，ByVal hBrush为Long）为Long
私有声明函数DrawIconEx Lib“user32”（ByVal hdc为长，ByVal xLeft为长，ByVal yTop为长，ByVal hIcon为长，ByVal cxWidth为长，ByVal cyWidth为长，ByVal istepIfAniCur为长，ByVal hbrFlickerFreeDraw为长，ByVal diFlags为长）为长
私有声明函数selectobjectlib“gdi32”（ByVal hdc为Long，ByVal hObject为Long）为Long
私有声明函数OLEATEPICTUREINDIRECT Lib“olepro32.dll”（ByRef PicDesc作为PICTDESC_BMP，ByRef RefID作为GUID，ByVal fPictureOwnsHandle作为Long，ByRef IPic作为IPacture）作为Long
专用类型GUID
数据1尽可能长
数据2作为整数
数据3作为整数
数据4（7）作为字节
端型
私有类型PICTDESC\u BMP
大小与长度相同
尽可能长地打字
hBmp尽可能长
hPal只要
保留多久
端型
常数DI_掩码=&H1
常量DI_图像=&H2
常量DI_NORMAL=DI_掩码或DI_图像
私有类型RECT
左尽可能长
顶长
对，只要
底部一样长
端型
专用子表单_加载（）
调用GetIcon（“C:\Program Files\Internet Explorer\iexplore.exe”）
端接头
私有子GetIcon（ByVal sFileName作为字符串）
暗希肯一样长
Dim hAssocIcon尽可能长
以字符串形式显示的文件*260
将命令变暗为字符串
最不发达国家只要
暗淡的lBmp如长
dimras RECT
暗淡的颜色和长的颜色一样
Me.AutoRedraw=真
hIcon=提取关联图标（App.hInstance、sFileName、hAssocIcon）
如果hIcon 0，则“未找到图标-使用图标通用图标资源”
'创建与屏幕兼容的设备上下文
lDC=CreateCompatibleDC（GetDC（0&））
'创建与屏幕兼容的位图
lBmp=CreateCompatibleBitmap（GetDC（0&），64，64）
'在设备上下文中选择位图
OldBMP=SelectObject（lDC、lBmp）
“设置矩形”值
R.左=0
R.顶部=0
右=64
R.底部=64
'用白色填充矩形
FillRect lDC，R，0
'绘制图标
呼叫DrawIconEx（lDC、0、0、hIcon、64、64、0、0、DI_NORMAL）
Me.Picture=PictureFromBitmap（lBmp，0&）
破坏图标（hIcon）
如果结束
调用SelectObject（lDC、OldBMP）
调用DeleteObject（lDC）
端接头
专用函数PictureFromBitmap（ByVal hBmp为Long，ByVal hPal为Long）为StdPicture
将IPictureId设置为GUID
Dim IPic作为IPacture
尺寸标记为PICTDESC\u BMP
暗淡的lpGUID尽可能长
'填写IPacture GUID
“{7BF80980-BF32-101A-8BB-00AA00300CAB}
带Ipictureid
.Data1=&H7BF80980
.Data2=&HBF32
.Data3=&H101A
.数据4（0）=&H8B
.数据4（1）=&HBB
.Data4（2）=&H0
.Data4（3）=&HAA
.Data4（4）=&H0
.数据4（5）=&H30
.数据4（6）=&HC
.Data4（7）=&HAB
以
'设置图片对象的属性
带tagPic
.Size=Len（tagPic）
.Type=VBPictTypeBitmap
.hBmp=hBmp
.hPal=hPal
以
'创建一张图片，完成后将删除其位图
调用OleCreatePictureIndirect（tagPic，IPictureId，1，IPic）
'将图片返回给来电者
设置PictureFromBitmap=IPic
端函数

它返回一个支持IPIP的对象。但它可能不是VBPictypebatmap。不确定是否可以在VBA中调用GdipCreateBitmapFromFile。

在Google Groups中搜索名为的线程

更新

不，我也不能让它工作

但是当我尝试的时候，我有一种可怕的似曾相识的感觉。。。然后我想起几年前我确实做过这件事，即在运行时向Excel CommandBarButtons添加带掩码的图标，而不知道它是在哪个版本的Excel中打开的。可悲的是，我找不到代码（不在源代码管理中，所以没有发布？我几乎可以肯定我让它工作了）

我想我从这些文章中借用了很多：

因为Excel并没有剪贴板，我似乎记得借用了Stephen Bullen的

---

希望这不会让你白费力气：）

嗨，谢谢你的回复。这是我想要的方向，但我没有将图标加载到图片控件中，而是尝试将其加载到Office.CommandBarButton.Picture w中