2009-10-02 2 views
2

Чтобы получить награду, предоставьте ответ на рабочий код. Благодарю.Как преобразовать 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 
+0

Моего кода ниже, в то время как Нуждаясь очисткой, использует только API и делают именно то, что вы хотите. В образце есть форма и изображение, чтобы продемонстрировать, что это работает. – jac

+0

Привет, Beaner. Было много исправлений, поэтому вы, возможно, пропустили его. Но решение ДОЛЖНО работать в VBA. У VBA нет управления снимками. Который, к сожалению, почему я задаю этот вопрос вообще :) Извините за любую путаницу. – Oorang

+0

Возможно, вы пропустили его, но картинка больше не была частью конверсии. Я оставил его там, чтобы отобразить преобразованное изображение в примере. Как я уже сказал, у меня не было времени на очистку кода. Теперь он был очищен, и я полностью удалил картинку, чтобы устранить путаницу.Конверсия - это ВСЕ WinAPI – jac

ответ

1

Дайте this post на vbAccelerator.com выстрел.

Редактировать: Самое ближайшее, что я нашел для VBA, это сообщение на officeblogs.net. Однако код использует значок вместо значка.

+0

Привет C-Pound. Возможно, я должен был упомянуть, что мне нужно это решение для работы в VBA. Вот что создало проблему. К несчастью, VBA не может получить доступ к объекту Picture. Вот почему я специально пытался использовать stdole.IPictureDisp. Можно ли сделать код, который вы указали, для создания правильного объекта? – Oorang

+0

Извините за ссылку только на VB. Я добавил редактирование с чем-то, что может работать для VBA. –

+0

Hi CPG, Опять же, мы все вокруг проблемы, но не совсем там. Это код VB.Net. Я мог бы закодировать его и скомпилировать, но затем я раздаю дополнительный файл (который, как уже упоминалось, я стараюсь избегать). Также он возвращает StdPicture типа Icon. После глубокого погружения я понял, почему назначение свойства изображения не работает, потому что объект StdPicture должен быть типа Bitmap. Поэтому, насколько я могу судить, проблема сводится к попытке выяснить, как конвертировать Значок. Я закончил с помощью SHGetFileInfoA, чтобы перейти вправо 16X16 Icon Handle, затем Oorang

1

Хорошо, я очистил код. Метод ExtractAssociatedIcon возвращает значок 64x64, поэтому для примера я просто закодировал этот размер. Картинка не удалена, и изображение присваивается свойству изображения формы, чтобы избежать путаницы.

Пример: скопировать код в новую форму и запустить

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 
+0

Привет, спасибо за ответ. Это происходит по дороге, которую я хочу, но вместо загрузки значка в элемент управления Picture, я пытаюсь загрузить его в Office.CommandBarButton.Picture, который является объектом IPictureDisp. – Oorang

+0

Я просто предлагаю вам использовать этот метод для скрытого Picturebox для загрузки вами значка, затем используйте «Clipboard.Clear», Clipboard.SetData (Picture1.Picture, vbCFBitmap) и CommandBarControl.PasteFace, чтобы поместить значок на вас. – jac

+0

Hi Beaner, один из недостатков проблемы заключается в том, что он также должен работать в VBA. К сожалению, VBA не может получить доступ к объекту Picture. Вот почему я пытаюсь обрисовать рукописную рукописную заметку в стиле stdole.IPictureDisp. – Oorang

0

LoadPicture Он возвращает объект, который поддерживает IPictureDisp. Однако это может быть не vbPicTypeBitmap. Не уверен, что вы можете вызвать GdipCreateBitmapFromFile в VBA.

+0

Здравствуйте, LoadPicture работает только с этими типами файлов: bmp, ico, cur, rle, wmf, emf, gif и jpg. Когда я вытаскиваю свои значки из Exes, мне нужно иметь способ сохранить файл из дескриптора значка. Если вы знаете, как это сделать, я бы подумал, что это решение. – Oorang

+0

попробуйте GdipCreateBitmapFromHICON/GdipSaveImageToFile –

0

Поиск групп Google для темы, озаглавленной, Convert StdPicture from Icon to Bitmap.

UPDATE

Нет, я не могу заставить его работать.

Но я получал страшное чувство дежавю, когда я его пытался ... потом вспомнил, что я определенно сделал это пару лет назад, т.е. добавляя значки с масками в Excel CommandBarButtons во время выполнения, не зная, какая версия Excel он был открыт. К сожалению, я не могу найти код (не в исходном контроле, поэтому он не выпустил его? Я почти уверен, что у меня это работает).

Я думаю, что я почерпнул из этих статей:

How To Create a Transparent Picture For Office CommandBar Buttons

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

И потому, что Excel не имеет буфера, я, кажется, припоминаю заимствование у Стивена Буллена PastePicture.zip.

Надеется, что это не посылает тебя на дик химерами :)

+0

Это выглядит многообещающим, но я не смог его перевести в рабочий пример. Хотя я действительно придумал способ заставить Excel вырваться на настольный компьютер довольно последовательно :) Не могли бы вы привести рабочий пример? – Oorang

+0

Я определенно хочу держаться подальше от буфера обмена. Это ужасная практика, чтобы захватить его. Другой подход, который я рассматривал, - это просто сохранить значок в временную папку, а затем использовать изображение нагрузки. Но его все равно нужно было бы сохранить как растровое изображение для правильной загрузки. Однако, поскольку это было бы еще одной проблемой исследования, я думал, что я сохраню это для плана B. – Oorang

 Смежные вопросы

  • Нет связанных вопросов^_^