VB 5/6-Tipp 0454: Informationen über GIF-Dateien auslesen

Kommentar von Götz Kircher am 14.01.2004 um 15:31

Betr.: der unvollständige Tipp 454

Hallo, Ihr Leute von activeVB

Der Aufbau einer GIF ist etwas komplexer als der Tipp 454 vermuten läßt. Die dort aufgeworfene Frage nach der Größe der Farbtabelle habe ich im folgenden beantwortet. Vielleicht wollt Ihr den Tipp durch diesen Code hier ersetzen.

Zumindest stelle ich ihn zur Verfügung.

Public Function GetTransparenteAustauschFarbe(ByVal LwpD As String, _
               ByRef TransparenteAustauschfarbe As Long _
               ) As Boolean
'
'Die Funktion holt aus der mit LwpD (LaufwerkPfadDateiname) angegebenen
'GIF- Datei die transparente Farbe und weitere Infomationen heraus.
'
'Ist die GIF transparent, gibt die Funktion TRUE zurück, die
'TransATF-Werte sind zugewiesen.
'
'Ist die Datei keine GIF-Datei oder die GIF ist nicht transparent,
'oder sonst ein Fehler ist aufgetreten, gibt die Funktion FALSE zurück.
'
'Sind mehrere Bilder in der GIF enthalten, werden die Daten für das
'erste Bild zurückgegeben.
'
'
'Diese Function basiert auf den Angaben von Compuserve.
'Nachzulesen unter: http://256.com/gray/docs/gifspecs/general.html
'
'Programmiert Jan. 2004 von Götz Kircher, goetzkircher@web.de
'Die Source darf frei verwendet werden.
'Für Richtigkeit und Funktionsfähigkeit keine Gewähr und Haftung.
'(siehe auch die Anmerkung zu: If FoundHintergrundfarbe Then
'weiter unten im Code)
'
'---------------------------------------------------------------
'die folgende Typdeklaration muß im Modulkopf stehen:
'
'Type GIFHeaderType
'    Signatur                As String * 6
'    LogicalScreenWidth      As Integer 'Pixel
'    LogicalScreenHeight     As Integer
'    'Das ist die Größe des Bereichs, in dem die Bilder
'    'ausgegeben werden. Er kann größer sein als das
'    'Bild oder die Bilder.
'    '(Die Bilder können unterschiedlich groß sein und
'    'an unterschiedlicher Position ausgegeben werden.)
'    DiverseBitDaten  As Byte   'Bit 7 = true: globale Farbtabelle folgt
                                'Bit 3 = true: Farbtabelle ist sortiert
                                'Die häufigst vorkommende Farbe zuerst.
                                'Bit 0 bis 3: Größe der Farbtabelle
                                '= 2 ^ (Wert+1)
'    HintergrundFarbeIndex   As Byte
'    'das ist nicht der Index auf die transparente Farbe,
'    'sondern der Index auf die Hintergrundfarbe.
'    'Der durch LogicalScreenWidth und LogicalScreenHeight definierte Bereich
'    'kann mit einer eigenen Hintergrundfarbe ausgefüllt sein.

'    Pixelabstandverhältnis  As Byte
'End Type
'
'Type GIFFarbwertType
'    Rot                     As Byte
'    Grün                    As Byte
'    Blau                    As Byte
'End Type
'
'Type GIFImageDescriptorType 'je Bild ist genau einer vorhanden.
'   ImgLeft                  As Integer 'Left und Top innerhalb der Logical
'   ImgTop                   As Integer 'ScreenWidth und ...Top
'   ImgWidth                 As Integer 'Das sind jetzt die Bildabmessungen
'   ImgHeight                As Integer 'des jeweiligen Bildes in Pixel
'   DiverseBitDaten          As Byte    'Bit 7 = true: lokale Farbtabelle folgt
                                        'Bit 6 = true: interleaced GIF
                                        'Bit 5 = true: Farbtabelle ist sortiert
                                        'Bit 0 bis 2: Größe der Farbtabelle
'End Type
'
'Type GIFGraphCtrlExtType
'    BlockSize               As Byte
'    DiverseBitDaten         As Byte    'Bit 0 = True: GIF ist transparent
'                                       'Bit 1 = True: animierte GIF
'                                       'Weiterschaltung nach Tastendruck
'                                       'oder Mausklick.
'    DelayTime               As Integer 'wenn > 0: animierte GIF. Wartezeit
'                                       'zum Weiterschalten in 1/100 Sek.
'    transpFarbeIdx          As Byte
'    BlockTerminator         As Byte
'End Type
'


Dim GIFheader                As GIFHeaderType
Dim GIFFarbwert()            As GIFFarbwertType
Dim GIFImageDescriptor       As GIFImageDescriptorType
Dim GIFGraphCtrlExt          As GIFGraphCtrlExtType
Dim weglesen1Byte            As Byte
Dim weglesen12Byte           As String * 12
Dim weglesen13Byte           As String * 13
Dim Weglesen()               As Byte
Dim AnzByteWeglesen          As Byte

Dim FileLänge                As Long
Dim GIFHdl                   As Integer
Dim GrößeFarbtabelle         As Integer
Dim Separator                As Byte
Dim ExitFlag                 As Boolean

Dim FoundHintergrundfarbe    As Boolean
Dim Hintergrundfarbe         As Long

On Error Goto errhdl
'
If Dir(LwpD) = "" Then
    'die Datei ist nicht vorhanden
    GetTransparenteAustauschFarbe = False
    Exit Function
End If
        
If Right(LCase(LwpD), 4) <> ".gif" Then
    'keine GIF
    GetTransparenteAustauschFarbe = False
    Exit Function
End If
'
FileLänge = FileLen(LwpD)
If FileLänge < Len(GIFheader) Then
    'Datei zu kurz ==> keine GIF
    GetTransparenteAustauschFarbe = False
    Exit Function
End If
'
'den Header einlesen
GIFHdl = FreeFile
Open LwpD For Binary As GIFHdl
Get #GIFHdl, , GIFheader
'
If GIFheader.Signatur <> "GIF89a" And GIFheader.Signatur <> "GIF87a" Then
    'keine GIF.
    GetTransparenteAustauschFarbe = False
    Close GIFHdl
    Exit Function
    'wird nur die Infomation der transparenten Farbe benötigt, kann die
    'Abfrage auch lauten: If GIFheader.Signatur <> "GIF89a" then
    'denn GIF87a unterstützt keine Transparenz.
End If
If GIFheader.DiverseBitDaten And 128 Then
    'wenn das höchstwertige Bit gesetzt ist, gibt es eine globale
    'Farbtabelle. Die Größe der Farbtabelle ist in den drei
    'niederwertigsten Bits verpackt.
    GrößeFarbtabelle = 2 ^ ((GIFheader.DiverseBitDaten And 7) + 1)
    '
    'Die Tabelle mit den Farbwerten dimensionieren...
    '(der Index ist nullbasiert)
    ReDim GIFFarbwert(0 To GrößeFarbtabelle - 1) As GIFFarbwertType
    '
    'und einlesen
    Get #GIFHdl, , GIFFarbwert
    '
    'Beim Austesten bin ich auf GIFs gestoßen, da zeigte der (nicht benötigte)
    'Index auf 0xFF außerhalb des Indexbereiches der globalen Farbtabelle.
    'deshalb die folgende Abfrage.
    If GIFheader.HintergrundFarbeIndex < GrößeFarbtabelle Then
        Hintergrundfarbe = RGB(GIFFarbwert(GIFheader.HintergrundFarbeIndex).Rot, _
                                GIFFarbwert(GIFheader.HintergrundFarbeIndex).Grün, _
                                GIFFarbwert(GIFheader.HintergrundFarbeIndex).Blau)
        FoundHintergrundfarbe = True
        'Eine Hintergrundfarbe kann nur zusammen mit einer globalen Farbtabelle
        'auftreten.
    End If
End If

'
ExitFlag = False 'Default
Do  'ab jetzt ist die Reihenfolge nicht mehr zwingend vorgeschrieben.
    '==> Schleifen bis zum ersten GIFImageDescriptor.
    '
    'das nächste Byte ist ein Seperator. Diesen einlesen...
    Get #GIFHdl, , Separator
    '...und auswerten
    If Separator = &H2C Then 'Es folgt ein GIFImage- Descriptor
        'diesen einlesen...
        Get #GIFHdl, , GIFImageDescriptor
        '... und auswerten
        If GIFImageDescriptor.DiverseBitDaten And 128 Then
            'wenn das höchstwertige Bit gesetzt ist, folgt eine lokale
            'Farbtabelle (sie gilt für das nächste Bild in einer Gif mit
            'mehreren Bildern) Die eventuell oben eingelesene globale
            'Farbtabelle wird jetzt durch die lokale Farbtabelle
            'überschrieben. (falls sie gebraucht wird, muß sie
            'hier zuerst gesichert werden.)
            GrößeFarbtabelle = 2 ^ ((GIFImageDescriptor.DiverseBitDaten And 7) + 1)
            ReDim GIFFarbwert(0 To GrößeFarbtabelle - 1) As GIFFarbwertType
            Get #GIFHdl, , GIFFarbwert
        End If
        ExitFlag = True 'im Anschluß folgen die ersten Bilddaten. D.h. es
                        'sind alle von dieser Funktion benötigten Daten
                        'zusammen ==> Ende einlesen.
                        
    ElseIf Separator = &H21 Then 'das ist der Extensions-Introducer
        Get #GIFHdl, , Separator 'Das nächste Byte besagt,
                                 'was für eine Extension
                               
        If Separator = &H1 Then  'Plain Text Extension (Text anstatt Bild)
            'interessiert hier nicht ==> weglesen
            Get #GIFHdl, , weglesen13Byte
            Do
                Get #GIFHdl, , weglesen1Byte
            Loop Until weglesen1Byte = 0
        ElseIf Separator = &HFF Then ' Applikations Extension (Copyright)
            'interessiert hier nicht ==> weglesen
            Get #GIFHdl, , weglesen12Byte
            Get #GIFHdl, , AnzByteWeglesen
            If AnzByteWeglesen > 0 Then
                ReDim Weglesen(1 To AnzByteWeglesen) As Byte
                Get #GIFHdl, , Weglesen
            End If
            Get #GIFHdl, , weglesen1Byte
        ElseIf Separator = &HFE Then 'Kommentar Extension
            'interessiert auch nicht ==> weglesen
            Do
                Get #GIFHdl, , weglesen1Byte
            Loop Until weglesen1Byte = 0
        ElseIf Separator = &HF9 Then ' Graphic Control Extension
            'das wird gebraucht. Hier steht ob und wie transparent.
            Get #GIFHdl, , GIFGraphCtrlExt
        End If
    End If
Loop While Not ExitFlag
'
'
If GrößeFarbtabelle = 0 Then 'keine Farbtabelle gefunden
    'Das ist laut Definition erlaubt. Es gilt dann die zuletzt geladene
    'Farbtabelle. Ist diese nicht vorhanden, eine Standartfarbtabelle.
    'Dieser Sonderfall aus der Zeit als Speicherplatz und Übertragungs-
    'zeiten noch sehr teuer waren, wird hier nicht behandelt.
    '
    'Gibt es noch solche GIFs?
    GetTransparenteAustauschFarbe = False
    Close #GIFHdl
    Exit Function
End If

'Die Farbtabelle steht jetzt zur Verfügung in
'GIFFarbwert(0 to Größefarbtabelle -1).Rot | .Grün | .Blau
'Der Wert "Größefarbtabelle" gibt keinen Aufschluß über die Anzahl der
'verwendeten Farben, da die Tabelle nicht kontinuierlich zunimmt, sondern
'in Stufen 2 ^(N+1), wobei N den Wert 0 bis 7 annehmen kann.
'Um die Anzahl verwendeter Farben festzustellen, muß die Farbtabelle
'selber ausgewertet werden, was hier nicht geschieht.
'
'Prüfen, ob eine transparente Austauschfarbe vorhanden ist.
If GIFGraphCtrlExt.DiverseBitDaten And 1 Then 'ja, vorhanden
    TransparenteAustauschfarbe = RGB( _
        GIFFarbwert(GIFGraphCtrlExt.transpFarbeIdx).Rot, _
        GIFFarbwert(GIFGraphCtrlExt.transpFarbeIdx).Grün, _
        GIFFarbwert(GIFGraphCtrlExt.transpFarbeIdx).Blau)
   '
    GetTransparenteAustauschFarbe = True
    '
    'jetzt muß noch ein Sonderfall abgefangen werden.
    If FoundHintergrundfarbe Then
        If TransparenteAustauschfarbe <> Hintergrundfarbe Then
            'sind mehrere Bilder vorhanden?
            If GIFGraphCtrlExt.DelayTime > 0 Or _
               GIFGraphCtrlExt.DiverseBitDaten And 2 Then 'ja
                'dann bezieht sich die Transparenz auf die in
                'der GIF vorgegebene Hintergrundfarbe, auf die
                'Bilder gesetzt werden.
                GetTransparenteAustauschFarbe = False
            End If
        End If
    End If
    'Achtung: Die letzte Regel ist nicht immer richtig.
    'Es gibt GIFs in denen sie angewendet werden muß und
    'welche, wo sie nicht angewendet werden darf.
    'von der Logik her müßte es heißen:
    'If FoundHintergrundfarbe Then
        'If TransparenteAustauschfarbe <> Hintergrundfarbe Then
            'GetTransparenteAustauschFarbe = False
        'Endif
    'endif
    'Nach dieser Regel kopiert werden die GIFs in der Picturebox
    'auch nicht immer richtig angezeigt.
    'Es liegt der Verdacht nahe, daß die Picturebox sich beim
    'Laden der GIF nicht ganz korrekt verhält und hieraus
    'der Fehler resultiert.
    'Wer die richtige Regel findet, teilt sie mir bitte mit.
    '
Else
    'nicht transparent oder kein GIFGraphCtrlExt- Block gefunden
    '(in nicht transparenten GIFs muß er nicht vorhanden sein,
    'in der GIF87a- Version gibt es den Block nicht.)
    GetTransparenteAustauschFarbe = False
End If
'
Close #GIFHdl
Exit Function
'
errhdl: 'Fehlerbehandlung
'Es können zwei Fehler auftreten:
'1.) Der Dateiaufbau ist nicht korrekt, weshalb ein Lesezugriff
'    über das Dateiende hinaus erfolgen könnte.
'2.) Der Index auf die transparente Austauschfarbe ist falsch
'    angegeben und zeigt auf einen Eintrag außerhalb der Farbtabelle.
'In beiden Fällen gibt die Funktion FALSE zurück
Close #GIFHdl
GetTransparenteAustauschFarbe = False
End Function