Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0729: Bild als Icon speichern

 von 

Beschreibung 

Dieser Tipp zeigt wie ein Bild, das sich in einer PictureBox befindet, als Icon gespeichert werden kann. Dabei werden alle Standardgrößen und Farbtiefen für Icons unterstützt.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CreateDIBSection (CreateDIBSection256), CreateIconFromResourceEx, DeleteObject, GetDC, GetDIBits (GetDIBits256), IIDFromString, OleCreatePictureIndirect, OleTranslateColor, ReleaseDC, SetDIBits (SetDIBits256)

Download:

Download des Beispielprojektes [44,91 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Pic2Ico.vbp  -------------
'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Rahmensteuerelement "frmBpp"
' Steuerelement: Optionsfeld-Steuerelement "opBpp" (Index von 0 bis 5) auf frmBpp
' Steuerelement: Schaltfläche "cmdDraw"
' Steuerelement: Bildfeld-Steuerelement "picView"
' Steuerelement: Bildfeld-Steuerelement "picIco"
' Steuerelement: Schaltfläche "cmdSave"
Option Explicit

Private eIconFormat As IconFormat

Private Sub cmdDraw_Click()

    ' nun zeichnen wir irgendwas in die
    ' PictureBox in der Größe für ein 32x32 Icon
    picIco.Line (0, 0)-(31, 31), vbBlue, B
    picIco.Line (5, 5)-(26, 26), vbBlack, B
    picIco.Line (10, 10)-(22, 22), vbRed, BF
    picIco.Line (0, 0)-(32, 32), vbYellow
    picIco.Line (0, 31)-(32, -1), vbMagenta
    picIco.Line (0, 16)-(32, 16), vbGreen
    picIco.Line (16, 0)-(16, 32), vbCyan
    picIco.Line (14, 14)-(18, 18), picIco.BackColor, BF

    ' Button zum speichern aktivieren
    cmdSave.Enabled = True
    
End Sub

Private Sub cmdSave_Click()

    Dim strPath As String
    Dim eIconSize As IconSize
    
    ' Anwendungspfad ermitteln
    strPath = App.Path
    
    ' Backslash anhängen wenn nicht vorhanden
    If Right$(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    
    ' Dateiname an den Pfad hängen
    strPath = strPath & "testing.ico"
    
    ' Es kann auch ein Bild in die PictureBox geladen bzw. gezeichnet werden.
    ' Allerdings findet hier keine Skalierung des Bildes auf die gewünschte
    ' Icongröße statt sondern es wird ein entsprechend großer Ausschnitt aus
    ' dem Bild in ein Icon konvertiert. Entweder man läd schon ein entsprechend
    ' großes Bild in die PictureBox oder man skaliert das Bild voher zb. mit
    ' PaintPicture oder StretchBlt und SetStretchBltMode auf die gewünschte
    ' Größe und zeichnet dieses in die PictureBox.
    
    ' Icongröße (Bildausschnitt aus picIco)
    eIconSize = [32x32]
            
    ' ***************************************************************
    ' Unter Windows 95/98/Me muss die PictureBox vorher auf die Größe
    ' des zu erstellenden Icons eingestellt werden.
    ' Ab Windows NT sind diese Zeilen überflüssig.
    picIco.Move picIco.Left, picIco.Top, eIconSize, eIconSize
    picIco.Cls
    Call cmdDraw_Click
    ' ***************************************************************
    
    ' nun speichern wir einen 32x32 Pixel großen Ausschnitt aus dem Image
    ' als 32x32 großes Icon im 256 Color-Format wobei die Hintergrundfarbe
    ' der PictureBox als transparente Farbe für das Icon verwendet werden soll.
    If SaveImageAsIcon(picIco.Image, strPath, eIconSize, eIconFormat, _
        picIco.BackColor, True) Then
        
        ' nach Iconformat selektieren
        Select Case eIconFormat
        
        Case IconFormat.[2 Color], IconFormat.[16 Color], _
            IconFormat.[256 Color], IconFormat.[24 Bit Truecolor]
        
            ' erstelltes Icon zum Test in eine PictureBox laden
            picView.Picture = LoadPicture(strPath)
            
        Case Else
        
            ' VBC kann keine 16bit und 32bit Icons per LoadPicture laden.
            ' Daher verwenden wir hier eine andere Methode um das Icon
            ' in die PictureBox zu laden.
            picView.Picture = LoadIcon(strPath, picView.BackColor)
            
        End Select
        
    Else
    
        ' hier ist dann irgendwas schief gelaufen
        Set picView.Picture = Nothing
        picView.Move cmdDraw.Left + cmdDraw.Width + 4, cmdDraw.Top, 255, 255
        MsgBox "Speichern war nicht erfolgreich."
        
    End If
    
End Sub

Private Sub Form_Load()

    Me.ScaleMode = vbPixels
    Me.Width = 10300
    Me.Height = 4300
    
    eIconFormat = [256 Color]
    
    With picIco
        .BorderStyle = 0
        .ScaleMode = vbPixels
        
        ' PictureBox auf die maximale Standard-Icongröße aufziehen
        .Move 2, 2, 256, 256
        
        ' ein muss, sonst geht gar nichts
        .AutoRedraw = True
        
        ' nur damit sich die PictureBox vom Hintergrund der Form abhebt
        .BackColor = QBColor(8)
        
        ' damit wir etwas sehen bleibt die PictureBox sichtbar
        ' .Visible = False
    End With
    
    With cmdDraw
        .Caption = "Draw"
        .Move picIco.Left + picIco.Width + 4, picIco.Top, 155, 30
    End With
    
    With cmdSave
        .Caption = "Save Image as Icon"
        
        .Move picIco.Left + picIco.Width + 4, cmdDraw.Top + cmdDraw.Height + _
            4, 155, 30
        
        .Enabled = False
    End With
    
    With frmBpp
        .Move cmdSave.Left, cmdSave.Top + cmdSave.Height + 4, 155
    End With
    
    With picView
        .AutoSize = True
        .BorderStyle = 0
        .Move cmdDraw.Left + cmdDraw.Width + 4, cmdDraw.Top, 255, 255
        
        ' nur damit wir die transparenten Bereiche des Icons sehen
        .BackColor = QBColor(15)
    End With
    
End Sub

Private Sub opBpp_Click(Index As Integer)

    ' Farbtiefe für das zu speichernde Icon festlegen
    Select Case Index
    
    Case 0
        eIconFormat = [2 Color]
        
    Case 1
        eIconFormat = [16 Color]
        
    Case 2
        eIconFormat = [256 Color]
        
    Case 3
        eIconFormat = [16 Bit Truecolor]
        
    Case 4
        eIconFormat = [24 Bit Truecolor]
        
    Case 5
        eIconFormat = [32 Bit Truecolor]
        
    End Select
    
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------ Anfang Modul "modPic2Ico" alias modPic2Ico.bas ------
Option Explicit

' ----==== Const ====----
Private Const S_OK As Long = 0&
Private Const BI_RGB As Long = 0&
Private Const DIB_RGB_COLORS As Long = 0&
Private Const IconVersion As Long = &H30000
Private Const LR_DEFAULTCOLOR As Long = &H0
Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"

' ----==== Enum ====----
' Standard-Iconpixelformate
Public Enum IconFormat
    [2 Color] = 1
    [16 Color] = 4
    [256 Color] = 8
    [16 Bit Truecolor] = 16
    [24 Bit Truecolor] = 24
    [32 Bit Truecolor] = 32
End Enum

' Standard-Icongrößen
Public Enum IconSize
    [16x16] = 16
    [24x24] = 24
    [32x32] = 32
    [48x48] = 48
    [64x64] = 64
    [72x72] = 72
    [96x96] = 96
    [128x128] = 128
    [256x256] = 256
End Enum

' ----==== Type ====----
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(255) As Long
End Type

Private Type IconHeader
    ihReserved As Integer
    ihType As Integer
    ihCount As Integer
End Type

Private Type IconEntry
    ieWidth As Byte
    ieHeight As Byte
    ieColorCount As Byte
    ieReserved As Byte
    iePlanes As Integer
    ieBitCount As Integer
    ieBytesInRes As Long
    ieImageOffset As Long
End Type

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7)  As Byte
End Type

Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hGdiObj As Long
    hPalOrXYExt As Long
End Type

' ----==== GDI32 API Deklarationen ====----
Private Declare Function CreateDIBSection256 Lib "gdi32.dll" _
                         Alias "CreateDIBSection" ( _
                         ByVal hdc As Long, _
                         ByRef pBitmapInfo As BITMAPINFO256, _
                         ByVal un As Long, _
                         ByVal lplpVoid As Long, _
                         ByVal handle As Long, _
                         ByVal dw As Long) As Long
                         
Private Declare Function DeleteObject Lib "gdi32" ( _
                         ByVal hObject As Long) As Long
                         
Private Declare Function GetDIBits256 Lib "gdi32.dll" _
                         Alias "GetDIBits" ( _
                         ByVal aHDC As Long, _
                         ByVal hBitmap As Long, _
                         ByVal nStartScan As Long, _
                         ByVal nNumScans As Long, _
                         ByRef lpBits As Any, _
                         ByRef lpBI As BITMAPINFO256, _
                         ByVal wUsage As Long) As Long
                         
Private Declare Function SetDIBits256 Lib "gdi32.dll" _
                         Alias "SetDIBits" ( _
                         ByVal hdc As Long, _
                         ByVal hBitmap As Long, _
                         ByVal nStartScan As Long, _
                         ByVal nNumScans As Long, _
                         ByRef lpBits As Any, _
                         ByRef lpBI As BITMAPINFO256, _
                         ByVal wUsage As Long) As Long
                         
' ----==== USER32 API Deklarationen ====----
Private Declare Function CreateIconFromResourceEx Lib "user32.dll" ( _
                         ByRef presbits As Any, _
                         ByVal dwResSize As Long, _
                         ByVal fIcon As Long, _
                         ByVal dwVer As Long, _
                         ByVal cxDesired As Long, _
                         ByVal cyDesired As Long, _
                         ByVal Flags As Long) As Long
                         
' ----==== OLE32 API Declarationen ====----
Private Declare Function IIDFromString Lib "ole32.dll" ( _
                         ByVal lpsz As Long, _
                         ByRef lpIID As IID) As Long
                         
' ----==== OLEAUT32 API Deklarationen ====----
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
                         ByRef lpPictDesc As PICTDESC, _
                         ByRef riid As IID, _
                         ByVal fOwn As Boolean, _
                         ByRef lplpvObj As Object) As Long
                         
Private Declare Function OleTranslateColor Lib "oleaut32.dll" ( _
                         ByVal lOleColor As Long, _
                         ByVal lHPalette As Long, _
                         ByRef lColorRef As Any) As Long
                         
' ----==== USER32 API Deklarationen ====----
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
                         
' ------------------------------------------------------
' Funktion     : FileExists
' Beschreibung : Existiert eine Datei
' Übergabewert : FileName = Pfad\Datei.ext
' Rückgabewert : True = Datei ist vorhanden
'                False = Datei ist nicht vorhanden
' ------------------------------------------------------
Private Function FileExists(ByVal FileName As String) As Boolean

    On Error Resume Next
    
    Dim ret As Long
    
    ret = Len(Dir$(FileName))
    
    If Err Or ret = 0 Then FileExists = False Else FileExists = True
    
End Function

' ------------------------------------------------------
' Funktion     : LoadIcon
' Beschreibung : Lädt ein Icon aus einer Icondatei
' Übergabewert : IcoFileName = Pfad\Datei.ext
'                TransColor32Bit = Hintergrundfarbe für das 32Bit-Icon
' Rückgabewert : StdPicture (Icon)
' ------------------------------------------------------
Public Function LoadIcon(ByVal IcoFileName As String, Optional ByVal TransColor32Bit As _
    Long = vbButtonFace) As StdPicture
    
    ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ' Diese Funktion ist eine speziell für diesen Tipp angepasste Version
    ' eines anderen Tipps zum laden von Icons. Mit dieser Funktion kann
    ' nur eine Icondatei ausgelesen werden, in der sich auch nur ein Icon
    ' befindet.
    ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    
    Dim hIcon As Long
    Dim lngFNr As Long
    Dim lngAlpha As Long
    Dim lngRed As Long
    Dim lngGreen As Long
    Dim lngBlue As Long
    Dim lngX As Long
    Dim lngY As Long
    Dim lngPictOffset As Long
    Dim lngMaskOffset As Long
    Dim lngPictPos As Long
    Dim lngMaskPos As Long
    Dim lngPictStride As Long
    Dim lngMaskStride As Long
    Dim bytIconData() As Byte
    Dim bytARGB(0 To 3) As Byte
    Dim tIID As IID
    Dim tPictDesc As PICTDESC
    Dim tIconEntry As IconEntry
    Dim tIconHeader As IconHeader
    Dim tBITMAPINFO As BITMAPINFOHEADER
    Dim oPicture As IPicture
    
    ' wenn die Datei vorhanden ist
    If FileExists(IcoFileName) Then
    
        ' wenn die Dateierweiterung = "ico" ist
        If LCase$(Right$(IcoFileName, 3)) = "ico" Then
        
            ' freie Dateinummer holen
            lngFNr = FreeFile
            
            ' Icondatei binär zum lesen öffnen
            Open IcoFileName For Binary Access Read As #lngFNr
            
            ' IconHeader einlesen
            Get #lngFNr, , tIconHeader
            
            ' ist es eine Icondatei
            If tIconHeader.ihType = 1 Then
            
                ' ist ein Icon in der Datei vorhanden
                If tIconHeader.ihCount = 1 Then
                
                    ' IconEntry einlesen
                    Get #lngFNr, , tIconEntry
                    
                    ' ByteArray bytIconData zur Aufname der Bilddaten
                    ' dimensionieren
                    ReDim bytIconData(tIconEntry.ieBytesInRes - 1)
                    
                    ' Bilddaten einlesen
                    Get #lngFNr, , bytIconData()
                    
                End If
            End If
            
            ' Zugriff auf die Datei schließen
            Close #lngFNr
            
            ' wenn es kein 32Bit-Icon ist
            If tIconEntry.ieBitCount < 32 Then
            
                ' dann kann das Icon direkt aus den Daten erstellt werden
                hIcon = CreateIconFromResourceEx(bytIconData(0), _
                    tIconEntry.ieBytesInRes, 1, IconVersion, tIconEntry.ieWidth, _
                    tIconEntry.ieHeight, LR_DEFAULTCOLOR)
                    
            Else
            
                ' Für 32Bit-Icons müssen wir ein wenig schummeln damit das Icon korrekt
                ' dargestellt wird. Wir mischen die Farbe des Icons mit der Hintergrundfarbe
                ' auf dem das Icon dann dargestellt werden soll um so den Effekt von
                ' transparenz zu erzeugen.

                ' Systemfarben konvertieren und Farbwert von Long nach RGB splitten
                If OleTranslateColor(TransColor32Bit, 0&, bytARGB(0)) = 0 Then
                
                    ' Breite einer Bildzeile inkl. PadBytes berechnen
                    lngPictStride = tIconEntry.ieWidth * 4 ' 32bpp
                    lngMaskStride = ((tIconEntry.ieWidth + 31) And Not 31) \ 8 ' 1bpp
                    
                    ' Offset berechen wo im ByteArray bytIcoData die Bilddaten liegen
                    lngPictOffset = Len(tBITMAPINFO)
                    lngMaskOffset = lngPictOffset + (tIconEntry.ieHeight * lngPictStride)
                    
                    ' alle Pixel des Icons durchlaufen
                    For lngY = 0 To tIconEntry.ieHeight - 1
                        For lngX = 0 To tIconEntry.ieWidth - 1
                        
                            ' Pixelpositionen im ByteArray bytIcoData berechnen
                            lngPictPos = lngPictOffset + (lngY * lngPictStride) + (lngX * 4)
                            lngMaskPos = lngMaskOffset + (lngY * lngMaskStride) + (lngX \ 8)
                                
                            ' ist es ein Weißer Pixel in der Maske
                            If (bytIconData(lngMaskPos) And CByte(&H80 / (2 ^ (lngX And _
                                &H7)))) = CByte(&H80 / (2 ^ (lngX And &H7))) Then
                                
                                ' dann wird der Pixel vom Iconimage auf transparent
                                ' gesetzt
                                lngAlpha = 0
                                
                                ' diesen Pixel in der Maskenbitmap auf Schwarz setzen
                                bytIconData(lngMaskPos) = bytIconData(lngMaskPos) And Not _
                                    CByte(&H80 / (2 ^ (lngX And &H7)))
                                    
                            Else
                            
                                ' Schwarzer Pixel in der Maske
                                
                                ' dann wird der Pixel vom Iconimage opaque bzw.
                                ' entsprechend der transparenz gesetzt
                                lngAlpha = CLng(bytIconData(lngPictPos + 3)) ' A
                                
                            End If
                            
                            ' Alphawert von 255 abziehen
                            lngAlpha = 255 - lngAlpha
                            
                            ' RGB-daten des Pixels auslesen
                            lngRed = CLng(bytIconData(lngPictPos + 2))     ' R
                            lngGreen = CLng(bytIconData(lngPictPos + 1))   ' G
                            lngBlue = CLng(bytIconData(lngPictPos + 0))    ' B
                            
                            ' RGB-Daten des Pixels mit den RGB-Daten von
                            ' TransColor32Bit prozentual mischen
                            bytIconData(lngPictPos + 2) = CByte(lngRed - (((lngRed - _
                                bytARGB(0)) * lngAlpha) / 255))
                                
                            bytIconData(lngPictPos + 1) = CByte(lngGreen - (((lngGreen - _
                                bytARGB(1)) * lngAlpha) / 255))
                                
                            bytIconData(lngPictPos + 0) = CByte(lngBlue - (((lngBlue - _
                                bytARGB(2)) * lngAlpha) / 255))
                                
                        Next lngX
                    Next lngY
                    
                    ' Icon aus den Daten erstellen
                    hIcon = CreateIconFromResourceEx(bytIconData(0), _
                        tIconEntry.ieBytesInRes, 1, IconVersion, tIconEntry.ieWidth, _
                        tIconEntry.ieHeight, LR_DEFAULTCOLOR)
                        
                End If
            End If
            
            ' ist ein Handle auf ein Icon vorhanden
            If hIcon <> 0 Then
            
                ' IID_IPicture -> tIID
                If IIDFromString(StrPtr(IID_IPicture), tIID) = S_OK Then
                
                    With tPictDesc
                    
                        .cbSizeOfStruct = Len(tPictDesc)
                        .picType = vbPicTypeIcon
                        .hGdiObj = hIcon
                        
                    End With
                    
                    ' StdPicture (Icon) aus dem Handle erstellen
                    If OleCreatePictureIndirect(tPictDesc, tIID, True, oPicture) = S_OK _
                        Then
                        
                        ' StdPicture zurückgeben
                        Set LoadIcon = oPicture
                        
                    End If
                End If
            End If
        End If
    End If
    
End Function

' ------------------------------------------------------
' Funktion     : SaveImageAsIcon
' Beschreibung : Speichert ein Image als Icon
' Übergabewert : Image = StdPicture
'                IcoFileName = Pfad\Datei.ext
'                Size = Enum IconSize
'                PixelFormat = Enum IconFormat
'                TransColor = Farbe die transparent werden soll
'                UseTransparency = TransColor verwenden
' Rückgabewert : True = speichern war erfolgreich
'                False = speichern war nicht erfolgreich
' ------------------------------------------------------
Public Function SaveImageAsIcon(ByVal Image As StdPicture, ByVal IcoFileName As String, _
    Optional ByVal Size As IconSize = [32x32], Optional ByVal PixelFormat As IconFormat _
    = [16 Color], Optional ByVal TransColor As Long = vbButtonFace, Optional ByVal _
    UseTransparency As Boolean = True) As Boolean
    
    Dim lngX As Long
    Dim lngY As Long
    Dim lngDC As Long
    Dim hBmp32 As Long
    Dim lngFNr As Long
    Dim lngPictPos As Long
    Dim lngMaskPos As Long
    Dim lngPalItem As Long
    Dim lngPalCount As Long
    Dim lngPalette() As Long
    Dim lngMaskStride As Long
    Dim lngPictStride As Long
    Dim bytPictArray() As Byte
    Dim bytMaskArray() As Byte
    Dim tIconEntry As IconEntry
    Dim tIconHeader As IconHeader
    Dim tBITMAPINFO As BITMAPINFO256
    Dim tBITMAPINFOHEADER As BITMAPINFOHEADER
    
    ' Wir konvertieren zunächst das Bild in das 32bpp Format und schneiden
    ' die entsprechende Größe (Size) aus der übergebenden Bitmap aus. Das
    ' 32bpp Format verwenden wir hier weil es einfacher ist eine Farbe
    ' als tranparente Farbe zu setzen. Insbesondere ist die Verarbeitung
    ' dann für die 16bpp, 8bpp, 4bpp und 1bpp Formate einfacher was die
    ' transparente Farbe angeht.
    ' Breite einer Bildzeile inkl. PadBytes berechnen
    lngPictStride = Size * 4 ' 32bpp
    lngMaskStride = ((Size + 31) And Not 31) \ 8 ' 1bpp
    
    ' ByteArrays zur Aufnahme der Bilddaten dimensionieren
    ' bytPictArray enthält später die Bilddaten für die Iconbitmap
    ' bytMaskArray enthält später die Bilddaten für die Maskenbitmap
    ReDim bytPictArray((Size * lngPictStride) - 1)
    ReDim bytMaskArray((Size * lngMaskStride) - 1)
    
    ' Bitmapinfos zum konvertieren in das 32bpp
    ' Pixelformat festlegen -> tBITMAPINFO.bmiHeader
    tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader)
    tBITMAPINFO.bmiHeader.biWidth = Size
    tBITMAPINFO.bmiHeader.biHeight = Size
    tBITMAPINFO.bmiHeader.biPlanes = 1
    tBITMAPINFO.bmiHeader.biBitCount = [32 Bit Truecolor]
    tBITMAPINFO.bmiHeader.biCompression = BI_RGB
    tBITMAPINFO.bmiHeader.biSizeImage = UBound(bytPictArray) + 1
    
    ' DC ermitteln
    lngDC = GetDC(0&)
    
    ' ist ein DC vorhanden
    If lngDC <> 0 Then
    
        ' Bild in das angegebene Pixelformat konvertieren. Die Bitmapdaten
        ' befinden sich nun im ByteArray bytPictArray.
        If GetDIBits256(lngDC, Image.handle, 0&, Size, bytPictArray(0), tBITMAPINFO, _
            DIB_RGB_COLORS) <> 0 Then
            
            ' wenn eine Farbe transparent gemacht werden soll
            If UseTransparency Then
            
                ' Systemfarben konvertieren
                If OleTranslateColor(TransColor, 0&, TransColor) = 0 Then
                
                    ' Alle Pixel im ByteArray bytPictArray durchlaufen
                    For lngY = 0 To Size - 1
                        For lngX = 0 To Size - 1
                        
                            ' Pixelpositionen in den ByteArrays berechnen
                            lngPictPos = (lngY * lngPictStride) + (lngX * 4)
                            lngMaskPos = (lngY * lngMaskStride) + (lngX \ 8)
                            
                            ' zunächst setzen wir den Alphakanal auf Opaque
                            bytPictArray(lngPictPos + 3) = 255
                            
                            ' entspricht die Farbe des Pixels im Bild mit der Farbe
                            ' überein die transparent gemacht werden soll
                            If RGB(bytPictArray(lngPictPos + 2), bytPictArray(lngPictPos _
                                + 1), bytPictArray(lngPictPos + 0)) = TransColor Then
                                
                                ' dann setzen wir diesen Pixel auf schwarz
                                ' transparent
                                bytPictArray(lngPictPos + 3) = 0 ' A
                                bytPictArray(lngPictPos + 2) = 0 ' R
                                bytPictArray(lngPictPos + 1) = 0 ' G
                                bytPictArray(lngPictPos + 0) = 0 ' B
                                
                                ' diesen Pixel setzen wir dann für die Maskenbitmap
                                ' auf Weiß
                                bytMaskArray(lngMaskPos) = bytMaskArray(lngMaskPos) Or _
                                    CByte(&H80 / (2 ^ (lngX And &H7)))
                                    
                            End If
                            
                        Next lngX
                    Next lngY
                    
                End If
            End If
            
            ' wenn das Icon in eine andere Farbtiefe als 32bpp gespeichert
            ' werden soll, dann konvertieren wir das Bild nochmal in das
            ' entsprechende Pixelformat.
            If PixelFormat <> [32 Bit Truecolor] Then
            
                ' div. Standardeinstellungen für
                ' die entsprechenden Pixelformate
                Select Case PixelFormat
                
                    ' 2 Farben, 1bpp
                Case IconFormat.[2 Color]
                
                    ' Anzahl der Farben in der Palette
                    lngPalCount = 2
                    
                    ' Breite einer Bildzeile inkl. PadBytes berechnen
                    lngPictStride = ((Size + 31) And Not 31) \ 8
                    
                    ' 16 Farben, 4bpp
                Case IconFormat.[16 Color]
                    lngPalCount = 16
                    lngPictStride = ((Size + 7) And Not 7) \ 2
                    
                    ' 256 Farben, 8bpp
                Case IconFormat.[256 Color]
                    lngPalCount = 256
                    lngPictStride = (Size + 3) And Not 3
                    
                    ' 16Bit
                Case IconFormat.[16 Bit Truecolor]
                    lngPictStride = ((Size * 2) + 2) And Not 2
                    
                    ' 24Bit
                Case IconFormat.[24 Bit Truecolor]
                    lngPictStride = ((Size * 3) + 3) And Not 3
                    
                End Select
                
                ' DIB-Bitmap erstellen -> hBmp32
                hBmp32 = CreateDIBSection256(lngDC, tBITMAPINFO, DIB_RGB_COLORS, 0&, 0&, _
                    0&)
                    
                ' ist ein DIB-Bitmap vorhanden
                If hBmp32 <> 0 Then
                
                    ' Bitmapdaten (32bpp) aus dem ByteArray bytPictArray in das
                    ' DIB-Bitmap schreiben
                    If SetDIBits256(lngDC, hBmp32, 0&, Size, bytPictArray(0), _
                        tBITMAPINFO, DIB_RGB_COLORS) <> 0 Then
                        
                        ' alte Daten im ByteArray bytPictArray löschen
                        Erase bytPictArray
                        
                        ' ByteArray bytPictArray zur Aufnahme der Bilddaten
                        ' erneut dimensionieren
                        ReDim bytPictArray((Size * lngPictStride) - 1)
                        
                        ' Bitmapinfos zum konvertieren in das entsprechende
                        ' Pixelformat festlegen -> tBITMAPINFO.bmiHeader
                        tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader)
                        tBITMAPINFO.bmiHeader.biWidth = Size
                        tBITMAPINFO.bmiHeader.biHeight = Size
                        tBITMAPINFO.bmiHeader.biPlanes = 1
                        tBITMAPINFO.bmiHeader.biBitCount = PixelFormat
                        tBITMAPINFO.bmiHeader.biCompression = BI_RGB
                        tBITMAPINFO.bmiHeader.biSizeImage = UBound(bytPictArray) + 1
                        
                        ' Bild in das angegebene Pixelformat konvertieren.
                        ' Die konvertierten Bitmapdaten befinden sich nun
                        ' wieder im ByteArray bytPictArray.
                        If GetDIBits256(lngDC, hBmp32, 0&, Size, bytPictArray(0), _
                            tBITMAPINFO, DIB_RGB_COLORS) <> 0 Then
                            
                        End If
                    End If
                    
                    ' DIB-Bitmap löschen
                    Call DeleteObject(hBmp32)
                    
                End If
            End If
            
            ' Daten für den Type IconHeader festlegen
            tIconHeader.ihReserved = 0 ' muss 0 sein
            tIconHeader.ihType = 1 ' 1 = Typ Icon
            tIconHeader.ihCount = 1 ' Anzahl der Icons in der Datei
            
            ' Daten für den Type IconEntry festlegen
            ' nur wenn die Icongröße < 256x256 Pixel ist
            If Size < [256x256] Then
            
                ' Größe des Icons speichern
                tIconEntry.ieWidth = tBITMAPINFO.bmiHeader.biWidth
                tIconEntry.ieHeight = tBITMAPINFO.bmiHeader.biHeight
                
            End If
            
            ' Anzahl der Ebenen und Bittiefe speichern
            tIconEntry.iePlanes = tBITMAPINFO.bmiHeader.biPlanes
            tIconEntry.ieBitCount = tBITMAPINFO.bmiHeader.biBitCount
            
            ' größe der Bitmapdaten in Bytes berechnen
            tIconEntry.ieBytesInRes = Len(tBITMAPINFOHEADER) + UBound(bytPictArray) + _
                UBound(bytMaskArray) + 2
                
            ' Beginn der Bitmap in der Icondatei berechnen
            tIconEntry.ieImageOffset = Len(tIconHeader) + Len(tIconEntry)
            
            ' Daten für den Type BITMAPINFOHEADER festlegen
            ' größe der Struktur speichern
            tBITMAPINFOHEADER.biSize = Len(tBITMAPINFOHEADER)
            
            ' Breite der Bitmap
            tBITMAPINFOHEADER.biWidth = tBITMAPINFO.bmiHeader.biWidth
            
            ' Höhe der Bitmap * 2 (Höhe Iconbitmap + Höhe Maskenbitmap)
            tBITMAPINFOHEADER.biHeight = tBITMAPINFO.bmiHeader.biHeight * 2
            
            ' Anzahl der Ebenen, Bittiefe und Komprimierung speichern
            tBITMAPINFOHEADER.biPlanes = tBITMAPINFO.bmiHeader.biPlanes
            tBITMAPINFOHEADER.biBitCount = tBITMAPINFO.bmiHeader.biBitCount
            tBITMAPINFOHEADER.biCompression = tBITMAPINFO.bmiHeader.biCompression
            
            ' Bildgröße in Bytes
            tBITMAPINFOHEADER.biSizeImage = tBITMAPINFO.bmiHeader.biSizeImage
            
            ' ist lngPalCount > 0 dann ist es eine Palettenbitmap
            ' (1bpp, 4bpp und 8bpp)
            If lngPalCount > 0 Then
            
                ' dann müssen wir zur Größe der Bitmapdaten noch die Größe
                ' der Palette hinzu rechnen
                tIconEntry.ieBytesInRes = tIconEntry.ieBytesInRes + (lngPalCount * 4)
                
                ' nur wenn lngPalCount < 256 ist
                If lngPalCount < 256 Then
                
                    ' dann die Anzahl der verwendeten Farben in der Palette
                    ' speichern
                    tIconEntry.ieColorCount = lngPalCount
                    
                End If
                
                ' Anzahl der verwendeten Farben in der Palette
                tBITMAPINFOHEADER.biClrUsed = lngPalCount
                
                ' Anzahl der verwendeten Farben in der Palette
                tBITMAPINFOHEADER.biClrImportant = lngPalCount
                
                ' Array zur Aufnahme der Palettendaten
                ' dimensionieren.
                ReDim lngPalette(lngPalCount - 1)
                
                ' Palettendaten umkopieren, damit wir die
                ' Palette einfach mit Put ausgeben können.
                For lngPalItem = 0 To lngPalCount - 1
                
                    lngPalette(lngPalItem) = tBITMAPINFO.bmiColors(lngPalItem)
                    
                Next lngPalItem
                
            End If
            
            ' ist die zuschreibenden Datei vorhanden
            If FileExists(IcoFileName) Then
            
                ' dann löschen wir die Datei
                Kill IcoFileName
                
            End If
            
            ' freie Dateinummer holen
            lngFNr = FreeFile
            
            ' neue Datei erstellen
            Open IcoFileName For Binary Access Write As #lngFNr
            
            ' IconHeader schreiben
            Put #lngFNr, , tIconHeader
            
            ' IconEntry schreiben
            Put #lngFNr, , tIconEntry
            
            ' BITMAPINFOHEADER schreiben
            Put #lngFNr, , tBITMAPINFOHEADER
            
            ' bei einer Palettenbitmap müsen wir hier die Palette mitschreiben
            If lngPalCount > 0 Then
            
                ' Palette schreiben
                Put #lngFNr, , lngPalette()
                
            End If
            
            ' Bilddaten der Iconbitmap schreiben
            Put #lngFNr, , bytPictArray
            
            ' Bilddaten der Maskenbitmap schreiben
            Put #lngFNr, , bytMaskArray
            
            ' zugriff auf die Datei schließen
            Close #lngFNr
            
            ' Rückgabewert der Funktion setzen
            SaveImageAsIcon = True
            
        End If
        
        ' DC freigeben
        Call ReleaseDC(0&, lngDC)
        
    End If
    
End Function
'------- Ende Modul "modPic2Ico" alias modPic2Ico.bas -------
'-------------- Ende Projektdatei Pic2Ico.vbp  --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.