【发布时间】：2010-12-03 04:54:31
【问题描述】：
要获得赏金，请提供带有工作代码的答案。谢谢。
我有一个类型为 vbPicTypeIcon 的 stdole.StdPicture 对象。我需要将其转换为类型 vbPicTypeBitmap。由于项目限制，我需要能够使用 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
【问题讨论】：
-
我下面的代码虽然需要清理，但只使用 API 并且完全符合您的要求。示例中有一个表单和一个图片框，仅用于演示它的工作原理。
-
嗨 Beaner，有很多编辑，所以你可能错过了。但是解决方案必须在 VBA 中工作。 VBA 没有优化校准。不幸的是，这就是我问这个问题的原因:) 很抱歉有任何困惑。
-
您可能错过了它，但图片框不再是转换的一部分。我把它留在那里以在示例中显示转换后的图像。就像我说的我没有时间清理代码。现在它已经被清理了一些，我完全删除了图片框以消除混乱。转换为 ALL WinAPI
-
嗨 Beaner，我调整了您最近发布的代码，将图片从 PictureFromBitmap 加载到 CommandBarButton 的 Picture 属性，但我仍然遇到同样的问题。它看起来像一个类型的图片（位图），但它仍然加载为黑色矩形。这很令人沮丧。
-
我知道您不想使用剪贴板，但似乎微软推荐将透明图像粘贴到按钮上的方法。 support.microsoft.com/kb/288771