Startseite / Tipps / VB 5/6-Tipp 0730: 32-Bit-Icons laden und anzeigen

VB 5/6-Tipp 0730: 32-Bit-Icons laden und anzeigen

 von Frank Schüler

'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 Ico2Pic.vbp  -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'------- Anfang Formular "frmMain" alias frmMain.frm  -------
' Steuerelement: Listen-Steuerelement "lbIcon"
' Steuerelement: Standarddialog-Steuerelement "cdOpen"
' Steuerelement: Schaltfläche "cmdOpen"
' Steuerelement: Bildfeld-Steuerelement "picIcon"
Option Explicit

Private Sub cmdOpen_Click()

    Dim lngItem As Long
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' div. Parameter für den Dialog
    With cdOpen
    
        .DialogTitle = "Load Iconfile"
        .Filter = "Icofile *.ico | *.ico"
        .InitDir = App.Path
        .CancelError = True
        .ShowOpen
        
    End With
    
    ' wenn das laden der Icondatei erfolgreich war
    If LoadIcon(cdOpen.FileName) Then
    
        ' Liste löschen
        lbIcon.Clear
        
        ' alle Icons im Icon durchlaufen
        For lngItem = 0 To tIconHeader.ihCount - 1
        
            ' Breite x Höhe x Farbtiefe ausgeben
            lbIcon.AddItem "Icon " & CStr(lngItem + 1) & ": " & CStr(tIconEntry( _
                lngItem).ieWidth) & "x" & CStr(tIconEntry(lngItem).ieHeight) & _
                "x" & CStr(IconColorDepth(lngItem)) & "Bit"
                
        Next lngItem
        
        ' Listbox den Focus geben
        lbIcon.SetFocus
        
        ' letztes Icon aus der Liste auswählen
        lbIcon.ListIndex = lbIcon.ListCount - 1
        
    End If
    
    Exit Sub
    
errorhandler:

End Sub

Private Sub lbIcon_Click()

    ' sind Einträge in der ListBox vorhanden
    If lbIcon.ListCount > 0 Then
    
        ' Icon anhand dessen Index laden und anzeigen
        picIcon.Picture = GetIconByIndex(lbIcon.ListIndex, picIcon.BackColor)
        
    End If
    
End Sub
'-------- Ende Formular "frmMain" alias frmMain.frm  --------
'------ Anfang Modul "modIco2Pic" alias modIco2Pic.bas ------
Option Explicit

' ----==== sonstige Const ====----
Private Const S_OK 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}"

' ----==== Types ====----
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 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

' ----==== KERNEL32 API Deklarationen ====----
Private Declare Sub CopyMemory Lib "kernel32.dll" _
                    Alias "RtlMoveMemory" ( _
                    ByRef pDst As Any, _
                    ByRef pSrc As Any, _
                    ByVal ByteLen 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
                         
' ----==== Variablen ====----
Public tIconHeader As IconHeader
Public tIconEntry() As IconEntry
Private bytIcoData() As Byte

' ------------------------------------------------------
' Funktion     : GetIconByIndex
' Beschreibung : Gibt das Icon mit einem bestimmten Index aus der
'                eingelesenen Icondatei (bytIcoData) zurück
' Übergabewert : Index = Index des Icons
'                TransColor32Bit = Hintergrundfarbe für 32Bit Icons
' Rückgabewert : StdPicture (Icon)
' ------------------------------------------------------
Public Function GetIconByIndex(ByVal Index As Long, Optional ByVal TransColor32Bit _
    As Long = vbButtonFace) As StdPicture
    
    Dim hIcon 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 byt32Bit() As Byte
    Dim bytARGB(0 To 3) As Byte
    Dim tIID As IID
    Dim tPictDesc As PICTDESC
    Dim tBITMAPINFO As BITMAPINFOHEADER
    Dim oPicture As IPicture
    
    ' wenn es kein 32Bit-icon ist
    If IconColorDepth(Index) < 32 Then
    
        ' Icondaten aus dem ByteArray bytIcoData verwenden um daraus ein
        ' Icon zu erstellen. So können auch 16Bit-Icons in VB
        ' angezeigt werden.
        
        ' Handle auf ein Icon
        hIcon = CreateIconFromResourceEx(bytIcoData(tIconEntry( _
            Index).ieImageOffset), tIconEntry(Index).ieBytesInRes, 1, IconVersion, _
            tIconEntry(Index).ieWidth, tIconEntry(Index).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)) = S_OK Then
            
            ' ByteArray byt32Bit zur Aufname der Bilddaten dimensionieren
            ' damit die Originalbilddaten nicht verändert werden
            ReDim byt32Bit(tIconEntry(Index).ieBytesInRes - 1)
            
            ' Bilddaten aus dem ByteArray bytIcoData herraus kopieren
            Call CopyMemory(byt32Bit(0), bytIcoData(tIconEntry( _
                Index).ieImageOffset), tIconEntry(Index).ieBytesInRes)
                
            ' Breite einer Bildzeile inkl. PadBytes berechnen
            lngPictStride = tIconEntry(Index).ieWidth * 4 ' 32bpp
            lngMaskStride = ((tIconEntry(Index).ieWidth + 31) And Not 31) \ 8 ' 1bpp
            
            ' Offset berechen wo im ByteArray byt32Bit die Bilddaten liegen
            lngPictOffset = Len(tBITMAPINFO)
            lngMaskOffset = lngPictOffset + (tIconEntry(Index).ieHeight * _
                lngPictStride)
                
            ' alle Pixel des Icons durchlaufen
            For lngY = 0 To tIconEntry(Index).ieHeight - 1
                For lngX = 0 To tIconEntry(Index).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 (byt32Bit(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
                        byt32Bit(lngMaskPos) = byt32Bit(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(byt32Bit(lngPictPos + 3)) ' A
                        
                    End If
                    
                    ' Alphawert von 255 abziehen
                    lngAlpha = 255 - lngAlpha
                    
                    ' RGB-daten des Pixels auslesen
                    lngRed = CLng(byt32Bit(lngPictPos + 2))     ' R
                    lngGreen = CLng(byt32Bit(lngPictPos + 1))   ' G
                    lngBlue = CLng(byt32Bit(lngPictPos + 0))    ' B
                    
                    ' RGB-Daten des Pixels mit den RGB-Daten von TransColor32Bit
                    ' prozentual mit dem Alphawert mischen
                    byt32Bit(lngPictPos + 2) = CByte(lngRed - (((lngRed - bytARGB( _
                        0)) * lngAlpha) / 255))
                        
                    byt32Bit(lngPictPos + 1) = CByte(lngGreen - (((lngGreen - _
                        bytARGB(1)) * lngAlpha) / 255))
                        
                    byt32Bit(lngPictPos + 0) = CByte(lngBlue - (((lngBlue - _
                        bytARGB(2)) * lngAlpha) / 255))
                        
                Next lngX
            Next lngY
            
        End If
        
        ' Handle auf ein Icon
        hIcon = CreateIconFromResourceEx(byt32Bit(0), tIconEntry( _
            Index).ieBytesInRes, 1, IconVersion, tIconEntry(Index).ieWidth, _
            tIconEntry(Index).ieHeight, LR_DEFAULTCOLOR)
            
    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 GetIconByIndex = oPicture
                
            End If
        End If
    End If

End Function

' ------------------------------------------------------
' Funktion     : FileExists
' Beschreibung : Ermittelt ob eine Datei vorhanden ist
' Übergabewert : FileName = Pfad\Dateiname.ext
' Rückgabewert : True = Datei vorhanden
'                False = Datei 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     : IconColorDepth
' Beschreibung : Farbtiefe des Icons ermitteln
' Übergabewert : Index = Index des Icons
' Rückgabewert : Farbtiefe
' ------------------------------------------------------
Public Function IconColorDepth(ByVal Index As Long) As Long

    If tIconEntry(Index).iePlanes = 1 Then
    
        ' 16bit, 24bit, 32bit
        IconColorDepth = tIconEntry(Index).ieBitCount
        
    Else
    
        ' 1bit, 4bit, 8bit
        Select Case tIconEntry(Index).ieColorCount
        
        Case 2
            IconColorDepth = 1
            
        Case 16
            IconColorDepth = 4
            
        Case Else
            IconColorDepth = 8
            
        End Select
        
    End If
    
End Function

' ------------------------------------------------------
' Funktion     : LoadIcon
' Beschreibung : Icondatei komplett einlesen
' Übergabewert : IcoFileName = Pfad\Dateiname.ext
' Rückgabewert : True = Einlesen war erfolgreich
'                False = Einlesen war nicht erfolgreich
' ------------------------------------------------------
Public Function LoadIcon(ByVal IcoFileName As String) As Boolean

    Dim lngFNr As Long
    
    ' wenn die Datei vorhanden ist
    If FileExists(IcoFileName) Then
    
        ' wenn die Dateierweiterung = "ico" ist
        If LCase$(Right$(IcoFileName, 3)) = "ico" Then
        
            ' alte Daten in den ByteArrays löschen
            Erase bytIcoData
            Erase tIconEntry
            
            ' freie Dateinummer holen
            lngFNr = FreeFile
            
            ' Icondatei binär zum lesen öffnen
            Open IcoFileName For Binary Access Read As #lngFNr
            
            ' bytIcoData dimensionieren
            ReDim bytIcoData(LOF(lngFNr) - 1)
            
            ' Icon komplett einlesen
            Get #lngFNr, , bytIcoData()
            Close #lngFNr
            
            ' IconHeader aus dem ByteArray bytIcoData kopieren
            Call CopyMemory(tIconHeader, bytIcoData(0), Len(tIconHeader))
            
            ' Ist es eine Icondatei, dann muss tIconHeader.ihType = 1 sein
            If tIconHeader.ihType = 1 Then
            
                ' ist mindestens ein Icon in der Datei vorhanden
                If tIconHeader.ihCount >= 1 Then
                
                    ' In tIconHeader.ihCount steht die Anzahl der Icons in der
                    ' Datei. Entsprechend dimensionieren wir tIconEntry
                    ReDim tIconEntry(tIconHeader.ihCount - 1)
                    
                    ' IconEntrys aus dem ByteArray kopieren
                    Call CopyMemory(tIconEntry(0), bytIcoData(Len(tIconHeader)), _
                        Len(tIconEntry(0)) * tIconHeader.ihCount)
                        
                    ' Rückgabewert setzen
                    LoadIcon = True
                    
                End If
            End If
        End If
    End If
    
End Function

'------- Ende Modul "modIco2Pic" alias modIco2Pic.bas -------
'-------------- Ende Projektdatei Ico2Pic.vbp  --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s