Чтобы получить награду, предоставьте ответ на рабочий код. Благодарю.Как преобразовать stdole.StdPicture в другой тип?
У меня есть stdole.StdPicture Объект Тип vbPicTypeIcon. Мне нужно преобразовать его в тип 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 и делают именно то, что вы хотите. В образце есть форма и изображение, чтобы продемонстрировать, что это работает. – jac
Привет, Beaner. Было много исправлений, поэтому вы, возможно, пропустили его. Но решение ДОЛЖНО работать в VBA. У VBA нет управления снимками. Который, к сожалению, почему я задаю этот вопрос вообще :) Извините за любую путаницу. – Oorang
Возможно, вы пропустили его, но картинка больше не была частью конверсии. Я оставил его там, чтобы отобразить преобразованное изображение в примере. Как я уже сказал, у меня не было времени на очистку кода. Теперь он был очищен, и я полностью удалил картинку, чтобы устранить путаницу.Конверсия - это ВСЕ WinAPI – jac