AW: Programmsymbol extrahieren ?
03.06.2010 18:50:03
Nepumuk
Hallo Stefan,
das war jetzt doch nicht ganz so einfach wie ich dachte.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" ( _
ByVal pszPath As String, _
ByVal dwFileAttributes As Long, _
ByRef psfi As ShellFileInfoType, _
ByVal cbFileInfo As Long, _
ByVal uFlags As Long) As Long
Private Declare Function OleCreatePictureIndirectA Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" ( _
ByRef pDicDesc As IconType, _
ByRef riid As CLSIdType, _
ByVal fOwn As Long, _
ByRef lpUnk As Object) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function DrawIconEx Lib "user32.dll" ( _
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 CreateSolidBrush Lib "gdi32.dll" ( _
ByVal crColor As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
ByRef lpPictDesc As PictDesc, _
ByRef riid As Any, _
ByVal fOwn As Long, _
ByRef lplpvObj As IPicture) As Long
Private Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal imageType As Long, _
ByVal newWidth As Long, _
ByVal newHeight As Long, _
ByVal lFlags As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" ( _
ByVal nIndex As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Const DI_NORMAL = &H3
Private Const MAX_PATH = 260&
Private Const vbPicTypeBitmap = 1&
Private Const vbPicTypeIcon = 3&
Private Const SMALL_ICON = &H101&
Private Const LARGE_ICON = &H100
Private Const IMAGE_BITMAP = 0&
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2&
Private Type IconType
cbSize As Long
picType As Long
hIcon As Long
End Type
Private Type CLSIdType
id(16) As Byte
End Type
Private Type ShellFileInfoType
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Public Sub Beispiel()
Dim strPath As String
Dim objIcon As StdPicture, objBitmap As StdPicture
Dim lngTempPicture As Long
Dim objShape As Shape
strPath = "M:\PBF\Tools\EVM.biz 2003\Design_EVM.biz.exe" 'Datei aus der extrahiert wird
Set objIcon = LoadIcon(SMALL_ICON, strPath)
If Not objIcon Is Nothing Then
Set objBitmap = IconToBitmap(objIcon, vbWhite, 16, 16)
If Not objBitmap Is Nothing Then
lngTempPicture = CopyImage(objBitmap.handle, _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
If lngTempPicture <> 0 Then
Call OpenClipboard(Application.hwnd)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, lngTempPicture)
Call CloseClipboard
If IsClipboardFormatAvailable(CF_BITMAP) Then
Tabelle1.Paste
Set objShape = Tabelle1.Shapes(Tabelle1.Shapes.Count)
With objShape 'Position in der Tabelle
.Top = Tabelle1.Cells(1, 1).Top
.Left = Tabelle1.Cells(1, 1).Left
End With
Tabelle1.Cells(1, 1).Select
Call OpenClipboard(Application.hwnd)
Call EmptyClipboard
Call CloseClipboard
Else
Err.Raise Number:=vbObjectError, Description:="Kopieren fehlgeschlagen"
End If
Else
Err.Raise Number:=vbObjectError, _
Description:="Handle des Bildes konnte nicht ermittelt werden."
End If
Else
Err.Raise Number:=vbObjectError, Description:="Konvertieren fehlgeschlagen"
End If
Else
Err.Raise Number:=vbObjectError, Description:="Extrahieren fehlgeschlagen"
End If
Set objIcon = Nothing
Set objBitmap = Nothing
Set objShape = Nothing
End Sub
Private Function LoadIcon(Size As Long, strFile As String) As IPictureDisp
Dim objUnknown As IUnknown
Dim udtIcon As IconType
Dim udtCLSID As CLSIdType
Dim udtShellInfo As ShellFileInfoType
Call SHGetFileInfo(strFile, 0, udtShellInfo, Len(udtShellInfo), Size)
udtIcon.cbSize = Len(udtIcon)
udtIcon.picType = vbPicTypeIcon
udtIcon.hIcon = udtShellInfo.hIcon
udtCLSID.id(8) = &HC0
udtCLSID.id(15) = &H46
Call OleCreatePictureIndirectA(udtIcon, udtCLSID, 1, objUnknown)
Set LoadIcon = objUnknown
End Function
Private Function IconToBitmap( _
oIcon As StdPicture, _
Optional ByVal BackColor As Long = vbButtonFace, _
Optional ByVal nWidth As Long = 32, _
Optional ByVal nHeight As Long = 32)
'© by Dieter Otter - www.vbarchiv.net
Dim DeskDC As Long
Dim hDC As Long
Dim hBmp As Long
Dim hBmpOld As Long
Dim hBrush As Long
Dim IID_IPicture(3) As Long
Dim PD As PictDesc
Dim NewPic As StdPicture
' Device-Context erstellen
DeskDC = GetDC(GetDesktopWindow)
hDC = CreateCompatibleDC(DeskDC)
If hDC <> 0 Then
' Compatibles Bitmap in erforderlicher Größe erzeugen
hBmp = CreateCompatibleBitmap(DeskDC, nWidth, nHeight)
hBmpOld = SelectObject(hDC, hBmp)
' gewünschte Hintergrundfarbe
If (BackColor And &HFF000000) = &H80000000 Then _
BackColor = GetSysColor(BackColor And &HFFFFFF)
hBrush = CreateSolidBrush(BackColor)
' Icon in den Device-Context zeichnen
DrawIconEx hDC, 0, 0, oIcon.handle, nWidth, nHeight, 0, hBrush, DI_NORMAL
' Handles wieder auflösen
SelectObject hDC, hBmpOld
DeleteDC hDC
' jetzt aus dem Bitmap-Handle ein
' StdPicture-Objekt erzeugen
IID_IPicture(0) = &H7BF80980
IID_IPicture(1) = &H101ABF32
IID_IPicture(2) = &HAA00BB8B
IID_IPicture(3) = &HAB0C3000
With PD
.cbSizeofStruct = Len(PD)
.hImage = hBmp
.picType = vbPicTypeBitmap
End With
OleCreatePictureIndirect PD, IID_IPicture(0), 1, NewPic
' StdPicture (Bitmap) zurückgeben
Set IconToBitmap = NewPic
Else
Set IconToBitmap = Nothing
End If
' Device-Context wieder freigeben
ReleaseDC GetDesktopWindow, DeskDC
End Function
Gruß
Nepumuk