Icon in Bitmap konvertieren Mit dieser Funktion lässt sich ein Icon in ein Bitmap umwandeln und als StdPicture-Objekt innerhalb der Anwendung verwenden.
Autor:   Dieter Otter	Bewertung:     [ Jetzt bewerten ]	Views:  14.912
www.tools4vb.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 17 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 4.8 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Hin und wieder kommt es vor, dass man ein Icon (.ICO-Datei) in ein Bitmap umwandeln muss. Ein Beispiel hierfür ist das Kopieren einer Symboldatei in die Windows-Zwischenablage, um dieses in anderen Anwendungen weiterverarbeiten zu können. Wenn Sie eine Symboldatei (Icon) laden und versuchen in die Zwischenablage zu kopieren, quittiert Ihnen VB das mit einer Fehlermeldung, dass es sich um ein falsches Clipboard-Format handelt. Bitmaps hingegen lassen sich ohne Probleme via Clipboard.SetData in die Zwischenablage kopieren.

Mit der Funktion IconToBitmap ist es möglich ein Icon in ein Bitmap umzuwandeln und dieses als StdPicture-Objekt weiterzuverwenden, wobei optional sogar noch die gewünschte Hintergrundfarbe angegeben werden kann.

Fügen Sie den nachfolgenden Code in ein Modul:

Option Explicit
 
' benötigte API-Deklarationen
Private Declare Function GetDesktopWindow Lib "user32.dll" () 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" ( _
  lpPictDesc As PictDesc, _
  riid As Any, _
  ByVal fOwn As Long, _
  lplpvObj As IPicture) As Long
 
Private Declare Function GetSysColor Lib "user32.dll" ( _
  ByVal nIndex As Long) As Long
 
Private Const DI_NORMAL = &H3
 
Private Type PictDesc
  cbSizeofStruct As Long
  picType As Long
  hImage As Long
  xExt As Long
  yExt As Long
End Type

' Wandelt ein Icon in ein Bitmap um und gibt dieses
' als StdPicture-Objekt zurück
Public Function IconToBitmap(oIcon As StdPicture, _
  Optional ByVal BackColor As Long = vbButtonFace, _
  Optional ByVal nWidth As Long = 32, _
  Optional ByVal nHeight As Long = 32)
 
  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

Beispiel für den Aufruf:

' Icon aus Datei laden und als Bitmap in die Zwischenablage kopieren
Dim oIcon As StdPicture
Set oIcon = LoadPicture(App.Path & "\MyIcon.ico")
 
' Icon in Bitmap umwandeln
Dim oBitmap As StdPicture
oBitmap = IconToBitmap(oIcon, vbWhite, 32, 32)

Weiteres Beispiel:

' Icons aus Datei laden und als Bitmap speichern
Dim oIcon As StdPicture
Set oIcon = LoadPicture(App.Path & "\MyIcon.ico")
 
' in Bitmap umwandeln und speichern
SavePicture IconToBitmap(oIcon, , 32, 32), App.Path & "\MyBitmap.bmp"