vba 如何将 stdole.StdPicture 转换为不同的类型?
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/1507385/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
How do I convert a stdole.StdPicture to a different Type?
提问by Oorang
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.
我有一个类型为 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
回答by C-Pound Guru
Give this postat vbAccelerator.com a shot.
给这个帖子在vbAccelerator.com了一枪。
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.
编辑:我为 VBA 找到的最接近的东西是officeblogs.net上的这篇文章。不过,该代码采用图标而不是图标句柄。
回答by jac
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.
好的,我已经清理了代码。ExtractAssociatedIcon 方法返回一个 64x64 的图标,所以在这个例子中,我刚刚硬编码了那个大小。图片框已被移除,并将图像分配给表单的图片属性以避免混淆。
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
回答by u109919
LoadPictureIt returns an object that supports IPictureDisp. It may not be vbPicTypeBitmap though. Not sure if you can call GdipCreateBitmapFromFile in VBA.
LoadPicture返回一个支持 IPictureDisp 的对象。不过它可能不是 vbPicTypeBitmap。不确定是否可以在 VBA 中调用 GdipCreateBitmapFromFile。
回答by onedaywhen
Search Google Groups for a thread entitled, Convert StdPicture from Icon to Bitmap.
在 Google 网上论坛中搜索名为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).
但是当我尝试它时,我有一种可怕的似曾相识的感觉......然后记得我几年前确实这样做过,即在运行时将带有蒙版的图标添加到 Excel CommandBarButtons,不知道它正在打开哪个版本的 Excel in. 遗憾的是我找不到代码(不在源代码管理中,所以没有发布?我几乎可以肯定我让它工作了)。
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.
因为 Excel 没有剪贴板,我似乎记得借用了 Stephen Bullen 的PastePicture.zip。
Hope this doesn't send you off on a wild goose chase :)
希望这不会让您陷入疯狂的追逐:)