Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0675: Animierte GIF-Dateien mit GDI+ abspielen

VB 5/6-Tipp 0675: Animierte GIF-Dateien mit GDI+ abspielen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, RtlMoveMemory (CopyMemory), GdipCreateFromHDC, GdipDeleteGraphics, GdipDisposeImage, GdipDrawImageRect, GdipGetImageBounds, GdipGetPropertyCount, GdipGetPropertyIdList, GdipGetPropertyItem, GdipGetPropertyItemSize, GdipGraphicsClear, GdipImageGetFrameCount, GdipImageSelectActiveFrame, GdipLoadImageFromFile, GdiplusShutdown, GdiplusStartup, KillTimer, OleTranslateColor, SetTimer

Download: Download des Beispielprojektes [62,5 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 GDIPlusPlayGif.vbp ----------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt.

'--- Anfang Formular "frmGDIPlusPlayGif" alias frmGDIPlusPlayGif.frm  ---
' Steuerelement: Bildfeld-Steuerelement "picViewPort"
' Steuerelement: Schaltfläche "cmdPlayGif"
' Steuerelement: Schaltfläche "cmdStopGif"
' Steuerelement: Schaltfläche "cmdPauseGif"
' Steuerelement: Kontrollkästchen-Steuerelement "ckAutoPlay"
' Steuerelement: Standarddialog-Steuerelement "cdLoadPicture"
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Beschriftungsfeld "lblShowFrame"
' Steuerelement: Beschriftungsfeld "lblFrameDelay"
' Steuerelement: Beschriftungsfeld "lblFrameCount"

Option Explicit

' ----==== GDI+ Konstanten ====----
Private Const GdiPlusVersion As Long = 1&

Private Const FrameDimensionTime As String = _
"{6AEDBD6D-3FB5-418A-83A6-7F45229DC872}"

Private Const PropertyTagFrameDelay As Long = &H5100&
Private Const PropertyTagLoopCount As Long = &H5101&

' ----==== GDI+ Typen ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GdiplusStartupOutput
    NotificationHook As Long
    NotificationUnhook As Long
End Type

Private Type PropertyItem
    id As Long
    length As Long
    Type As PropertyTagType
    value As Long
End Type

Private Type RECTF
    Top As Single
    Left As Single
    Right As Single
    Bottom As Single
End Type

' ----==== sonstige Typen ====----
Private Type GifPlayInfo
    GifFrames As Long
    GifFrame As Long
    GifDelay As Long
    GifLoops As Long
    GifLoop As Long
End Type

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

' ----==== GDI+ Enumerationen ====----
Private Enum PropertyTagType
    PropertyTagTypeByte = 1
    PropertyTagTypeASCII = 2
    PropertyTagTypeShort = 3
    PropertyTagTypeLong = 4
    PropertyTagTypeRational = 5
    PropertyTagTypeUndefined = 7
    PropertyTagTypeSLong = 9
    PropertyTagTypeSRational = 10
End Enum

'GDI+ Status
Private Enum Status
    OK = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

Private Enum Unit
    UnitWorld = 0
    UnitDisplay = 1
    UnitPixel = 2
    UnitPoint = 3
    UnitInch = 4
    UnitDocument = 5
    UnitMillimeter = 6
End Enum

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hdc As Long, ByRef graphics As Long) As Status

Private Declare Function GdipDeleteGraphics Lib "gdiplus" _
    (ByVal graphics As Long) As Status

Private Declare Function GdipDisposeImage Lib "gdiplus" _
    (ByVal Image As Long) As Status

Private Declare Function GdipDrawImageRect Lib "gdiplus" _
    (ByVal graphics As Long, ByVal Image As Long, _
    ByVal X As Single, ByVal Y As Single, ByVal Width As Single, _
    ByVal Height As Single) As Status

Private Declare Function GdipGetImageBounds Lib "gdiplus" _
    (ByVal Image As Long, ByRef srcRect As RECTF, _
    ByRef srcUnit As Unit) As Status

Private Declare Function GdipGetPropertyCount Lib "gdiplus" _
    (ByVal Image As Long, ByRef numOfProperty As Long) As Status

Private Declare Function GdipGetPropertyIdList Lib "gdiplus" _
    (ByVal Image As Long, ByVal numOfProperty As Long, _
    ByRef list As Long) As Status

Private Declare Function GdipGetPropertyItem Lib "gdiplus" _
    (ByVal Image As Long, ByVal propId As Long, _
    ByVal propSize As Long, ByRef buffer As Any) As Status

Private Declare Function GdipGetPropertyItemSize Lib "gdiplus" _
    (ByVal Image As Long, ByVal propId As Long, _
    ByRef Size As Long) As Status

Private Declare Function GdipGraphicsClear Lib "gdiplus" _
    (ByVal graphics As Long, ByVal Color As Long) As Status

Private Declare Function GdipImageGetFrameCount Lib "gdiplus" _
    (ByVal Image As Long, ByRef dimensionID As GUID, _
    ByRef Count As Long) As Status

Private Declare Function GdipImageSelectActiveFrame Lib "gdiplus" _
    (ByVal Image As Long, ByRef dimensionID As GUID, _
    ByVal frameIndex As Long) As Status

Private Declare Function GdipLoadImageFromFile Lib "gdiplus" _
    (ByVal FileName As Long, ByRef Image As Long) As Status

Private Declare Function GdiplusShutdown Lib "gdiplus" _
    (ByVal token As Long) As Status

Private Declare Function GdiplusStartup Lib "gdiplus" _
    (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
    ByRef lpOutput As GdiplusStartupOutput) As Status

' ----==== OLE32 API Deklarationen ====----
Private Declare Function CLSIDFromString Lib "ole32" _
    (ByVal str As Long, id As GUID) As Long

' ----==== OLEOUT32 API Deklarationen ====----
Private Declare Function OleTranslateColor Lib "oleaut32.dll" _
    (ByVal lOleColor As Long, ByVal lHPalette As Long, _
    lColorRef As Long) As Long

' ----==== KERNEL32 API Deklarationen ====----
Private Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (pDst As Any, pSrc As Any, _
    ByVal ByteLen As Long)

' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private lGifBitmap As Long
Private tGuidFDT As GUID
Private lShowFrame As Long
Private lFrameCount As Long
Private lLoopCount As Long
Private lFrameLoopCount As Long
Private lFrameDelay() As Long
Private oPicGif As PictureBox
Private tCurGifPlayInfo As GifPlayInfo

'------------------------------------------------------
' Funktion     : CheckLoopCount
' Beschreibung : Überprüft, ob der EXIF-Tag LoopCount
'                vorhanden sind
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
' Rückgabewert : True = LoopCount vorhanden
'                False = LoopCount nicht vorhanden
'------------------------------------------------------
Private Function CheckLoopCount( _
    ByVal lInBitmap As Long, _
    ByVal PropertyID As Long) As Boolean
    
    Dim lPropCount As Long
    Dim lPropItem As Long
    Dim lPropList() As Long
    Dim bRet As Boolean
    
    bRet = False
    
    ' Anzahl der EXIF-Metatags ermitteln
    If Execute(GdipGetPropertyCount(lInBitmap, _
    lPropCount)) = OK Then
        
        ' sind EXIF-Metatags vorhanden
        If (lPropCount > 0) Then
            
            ' Array zur Aufnahme der
            ' EXIF-Metatags dimensionieren
            ReDim lPropList(0 To lPropCount - 1)
            
            ' Liste der EXIF-Metatags auslesen -> lPropList()
            If Execute(GdipGetPropertyIdList(lInBitmap, _
            lPropCount, ByVal VarPtr(lPropList(0)))) = OK Then
                
                ' Liste der EXIF-Metatags durchlaufen
                For lPropItem = 0 To lPropCount - 1
                    
                    ' ist in der Liste der EXIF-Metatag
                    ' PropertyID vorhanden
                    If lPropList(lPropItem) = _
                    PropertyID Then
                        
                        ' wenn ja, dann Rückgabewert setzen und
                        ' Schleife verlassen
                        bRet = True
                        Exit For
                    End If
                    
                Next lPropItem
                
            End If
        End If
    End If
    
    ' Rückgabewert ausgeben
    CheckLoopCount = bRet
End Function

'------------------------------------------------------
' Funktion     : DrawGifFrame
' Beschreibung : zeichnet ein eizelnes Bild aus der GIF-Datei
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
'                tInGUID = GUID von FrameDimensionTime
'                lInFrameNum = Bildnummer
'                oPictureBox = PictureBox
'                tInPoint = Position auf Ausgabeobjekt
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function DrawGifFrame(ByVal lInBitmap As Long, _
    ByRef tInGUID As GUID, ByVal lInFrameNum As Long, _
    ByVal oPictureBox As PictureBox) As Status
    
    Dim bBlue As Byte
    Dim bGreen As Byte
    Dim bRed As Byte
    Dim lGifGraphics As Long
    Dim tGifFrameRect As RECTF
    
    ' einzelnes Bild aus GIF-Datei auswählen
    If Execute(GdipImageSelectActiveFrame(lInBitmap, _
    tInGUID, lInFrameNum)) = OK Then
        
        ' größe des Bildes ermitteln
        If Execute(GdipGetImageBounds(lInBitmap, _
        tGifFrameRect, UnitPixel)) = OK Then
            
            ' Ausgabeobjektparameter setzen
            With oPictureBox
                .ScaleMode = vbPixels
                .AutoRedraw = True
                .Width = tGifFrameRect.Right - tGifFrameRect.Left
                .Height = tGifFrameRect.Bottom - tGifFrameRect.Top
            End With
            
            ' Graphicsobjekt vom Ausgabeobjekt erstellen
            If Execute(GdipCreateFromHDC(oPictureBox.hdc, _
            lGifGraphics)) = OK Then
                
                ' Hintergrundfarbe des Ausgabeobjektes
                ' nach RGB aufsplitten
                Call RGBsplit( _
                TranslateColor(oPictureBox.BackColor), _
                bRed, bGreen, bBlue)
                
                ' Ausgabebereich mit Hintergrundfarbe überzeichnen
                ' ARGB = RGB(b,g,r) or &HFF000000
                If Execute(GdipGraphicsClear(lGifGraphics, _
                RGB(bBlue, bGreen, bRed) Or &HFF000000)) = OK Then
                    
                    ' einzelnes Bild auf Graphicsobjekt zeichnen
                    If Execute(GdipDrawImageRect(lGifGraphics, _
                    lInBitmap, tGifFrameRect.Left, _
                    tGifFrameRect.Top, tGifFrameRect.Right _
                    - tGifFrameRect.Left, tGifFrameRect.Bottom _
                    - tGifFrameRect.Top)) = OK Then
                        
                    With tCurGifPlayInfo
                        .GifDelay = lFrameDelay(lInFrameNum)
                        .GifFrame = lInFrameNum + 1
                        .GifLoop = lLoopCount - 1
                        .GifLoops = lFrameLoopCount
                    End With
    
                    ' Ausgabe von Infos
                    Call ShowGifPlayInfos(tCurGifPlayInfo)
                        
                    End If
                End If
                
                ' Graphicsobjekt löschen
                Call Execute(GdipDeleteGraphics(lGifGraphics))
                
                ' Ausgabeobjekt refreshen
                oPictureBox.Refresh
            End If
        End If
    End If
End Function

'------------------------------------------------------
' Funktion     : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
'                GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function Execute(ByVal eReturn As Status) As Status
    Dim eCurErr As Status
    If eReturn = OK Then
        eCurErr = OK
    Else
        eCurErr = eReturn
        MsgBox GdiErrorString(eReturn) & " GDI+ Error:" & _
        eReturn, vbOKOnly, "GDI Error"
    End If
    Execute = eCurErr
End Function

'------------------------------------------------------
' Funktion     : GdiErrorString
' Beschreibung : Umwandlung der GDI+ Statuscodes in Stringcodes
' Übergabewert : GDI+ Status
' Rückgabewert : Fehlercode als String
'------------------------------------------------------
Private Function GdiErrorString(ByVal eError As Status) As String
    Dim s As String
    
    Select Case eError
    Case GenericError:              s = "Generic Error."
    Case InvalidParameter:          s = "Invalid Parameter."
    Case OutOfMemory:               s = "Out Of Memory."
    Case ObjectBusy:                s = "Object Busy."
    Case InsufficientBuffer:        s = "Insufficient Buffer."
    Case NotImplemented:            s = "Not Implemented."
    Case Win32Error:                s = "Win32 Error."
    Case WrongState:                s = "Wrong State."
    Case Aborted:                   s = "Aborted."
    Case FileNotFound:              s = "File Not Found."
    Case ValueOverflow:             s = "Value Overflow."
    Case AccessDenied:              s = "Access Denied."
    Case UnknownImageFormat:        s = "Unknown Image Format."
    Case FontFamilyNotFound:        s = "FontFamily Not Found."
    Case FontStyleNotFound:         s = "FontStyle Not Found."
    Case NotTrueTypeFont:           s = "Not TrueType Font."
    Case UnsupportedGdiplusVersion: s = "Unsupported Gdiplus Version."
    Case GdiplusNotInitialized:     s = "Gdiplus Not Initialized."
    Case PropertyNotFound:          s = "Property Not Found."
    Case PropertyNotSupported:      s = "Property Not Supported."
    Case Else:                      s = "Unknown GDI+ Error."
    End Select
    
    GdiErrorString = s
End Function

'------------------------------------------------------
' Funktion     : GetGifFrameCount
' Beschreibung : Anzahl der einzelnen Bilder der GIF-Datei ermitteln
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
'                tInGUID = GUID von FrameDimensionTime
'                lOutFrameCount = Anzahl der Bilder
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function GetGifFrameCount(ByVal lInBitmap As Long, _
    ByRef tInGUID As GUID, _
    ByRef lOutFrameCount As Long) As Status
    
    GetGifFrameCount = _
    Execute(GdipImageGetFrameCount(lInBitmap, _
    tInGUID, lOutFrameCount))
    
End Function

'------------------------------------------------------
' Funktion     : GetGifFrameDelays
' Beschreibung : Auslesen der Pausenzeiten zwischen
'                den einzelnen Bildern
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
'                lInFrameCount = Anzahl der Bilder
'                lOutFrameDelay = Array mit den Pausenzeiten
'------------------------------------------------------
Private Sub GetGifFrameDelays(ByVal lInBitmap As Long, _
    ByVal lInFrameCount As Long, _
    ByRef lOutFrameDelay() As Long)
    
    Dim lProp() As Byte
    Dim lPropCount As Long
    Dim lSize As Long
    Dim lPropSize As Long
    Dim tPropItem As PropertyItem
    
    ' Datengröße vom EXIF-Tag
    ' "PropertyTagFrameDelay" ermitteln
    If Execute(GdipGetPropertyItemSize(lInBitmap, _
    PropertyTagFrameDelay, lPropSize)) = OK Then
        
        ' Daten auslesen
        If GetPropertyItem(lInBitmap, PropertyTagFrameDelay, _
        lPropSize, tPropItem) = OK Then
            
            ' Bytearray dimensionieren
            ReDim lProp(0 To (tPropItem.length - 1))
            
            ' PropertyValue in das Bytearray kopieren
            Call CopyMemory(lProp(0), ByVal tPropItem.value, _
            tPropItem.length)
            
            ' PropertyTyp ermitteln
            Select Case tPropItem.Type
            Case PropertyTagTypeByte
                lSize = 1
                
            Case PropertyTagTypeShort
                lSize = 2
                
            Case PropertyTagTypeLong
                lSize = 4
            End Select
            
            ' Array zur Aufnahme der
            ' Pausenzeiten dimensionieren
            ReDim lOutFrameDelay(lInFrameCount - 1)
            
            ' Pausenzeiten der einzelnen
            ' Bilder aus Bytearray kopieren
            For lPropCount = 0 To (lInFrameCount - 1)
                
                Call CopyMemory(lOutFrameDelay(lPropCount), _
                lProp(lPropCount * lSize), lSize)
                
                lOutFrameDelay(lPropCount) = _
                lOutFrameDelay(lPropCount) * 10
                
            Next lPropCount
        End If
    End If
End Sub

'------------------------------------------------------
' Funktion     : GetGifLoopCount
' Beschreibung : Auslesen der Wiederholungen
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
'                lOutLoopCount = Anzahl der Wiederholungen
'------------------------------------------------------
Private Sub GetGifLoopCount(ByVal lInBitmap As Long, _
    ByRef lOutLoopCount As Long)
    
    Dim lPropSize As Long
    Dim tPropItem As PropertyItem
    Dim lProp() As Byte
    Dim lSize As Long
    
    ' ist der EXIF-Tag
    ' "PropertyTagLoopCount" vorhanden
    If CheckLoopCount(lInBitmap, _
    PropertyTagLoopCount) = True Then
        
    ' Datengröße vom EXIF-Tag
    ' "PropertyTagLoopCount" ermitteln
        If GdipGetPropertyItemSize(lInBitmap, _
        PropertyTagLoopCount, lPropSize) = OK Then
            
            ' Daten auslesen
            If GetPropertyItem(lInBitmap, PropertyTagLoopCount, _
            lPropSize, tPropItem) = OK Then
                
                ' Bytearray dimensionieren
                ReDim lProp(0 To (tPropItem.length - 1))
                
                ' PropertyValue in das Bytearray kopieren
                Call CopyMemory(lProp(0), ByVal tPropItem.value, _
                tPropItem.length)
                
                ' PropertyTyp ermitteln
                Select Case tPropItem.Type
                Case PropertyTagTypeByte
                    lSize = 1
                    
                Case PropertyTagTypeShort
                    lSize = 2
                    
                Case PropertyTagTypeLong
                    lSize = 4
                End Select
                
                ' LoopCount aus Bytearray kopieren
                Call CopyMemory(lOutLoopCount, lProp(0), lSize)
            End If
        End If
    Else
        ' wenn der EXIF-Tag
        ' "PropertyTagLoopCount" fehlt
        lOutLoopCount = 0
    End If
End Sub

'------------------------------------------------------
' Funktion     : GetPropertyItem
' Beschreibung : EXIF-Daten eines EXIF-Tags auslesen
' Übergabewert : lInBitmap = GDI+ Bitmapobjekt
'                lPropertyID = PropertyTag
'                lPropertyItemSize = Größe der Daten
'                tPropertyItemData = Type PropertyItem
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function GetPropertyItem(ByVal lInBitmap As Long, _
    ByVal lPropertyID As Long, ByVal lPropertyItemSize As Long, _
    ByRef tPropertyItemData As PropertyItem) As Status
    
    Dim bPropItemData() As Byte
    
    ' Array dimesionieren
    ReDim bPropItemData(0 To (lPropertyItemSize - 1))
    
    ' Daten auslesen
    GetPropertyItem = Execute(GdipGetPropertyItem(lInBitmap, _
    lPropertyID, lPropertyItemSize, bPropItemData(0)))
    
    ' Daten aus ByteArray kopieren
    Call CopyMemory(tPropertyItemData, _
    bPropItemData(0), LenB(tPropertyItemData))
    
End Function

'------------------------------------------------------
' Funktion     : LoadGif
' Beschreibung : Laden der GIF-Datei
' Übergabewert : sFileName = Pfad\Dateiname.gif
'                lOutBitmap = GDI+ Bitmapobjekt
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function LoadGif(ByVal sFileName As String, _
    ByRef lOutBitmap As Long) As Status
    
    ' GDI+ Bitmapobjekt von Datei erstellen
    ' -> lOutBitmap
    LoadGif = _
    Execute(GdipLoadImageFromFile(StrPtr(sFileName), _
    lOutBitmap))
    
End Function

'------------------------------------------------------
' Funktion     : PlayGif
' Beschreibung : Zeichnen der einzelnen Bilder
'------------------------------------------------------
Public Sub PlayGif()
    
    ' einzelnes Bild zeichnen
    Call DrawGifFrame(lGifBitmap, tGuidFDT, _
    lShowFrame, oPicGif)
    
    ' Timer stoppen
    Call StopTimer
    
    If lLoopCount > 0 Then
        ' Timer mit Pausenzeit starten
        StartTimer lFrameDelay(lShowFrame)
    Else
        Call cmdStopGif_Click
    End If
    
    ' Bildnummer um 1 erhöhen
    lShowFrame = lShowFrame + 1
    
    If lShowFrame > (lFrameCount - 1) Then
        lShowFrame = 0
        If lFrameLoopCount > 0 Then lLoopCount = lLoopCount - 1
    End If
End Sub

'------------------------------------------------------
' Funktion     : RGBsplit
' Beschreibung : Longfarbwert in RGB aufsplitten
' Übergabewert : lInColor = Farbe in Long
'                bOutRed = Rotwert in Byte
'                bOutGreen = Grünwert in Byte
'                bOutBlue = Blauwert in Byte
'------------------------------------------------------
Private Sub RGBsplit(ByVal lInColor As Long, _
    ByRef bOutRed As Byte, ByRef bOutGreen As Byte, _
    ByRef bOutBlue As Byte)
    
    bOutBlue = (lInColor And 16711680) / 65536
    bOutGreen = (lInColor And 65280) / 256
    bOutRed = lInColor And 255
End Sub

'------------------------------------------------------
' Funktion     : ShowGifPlayInfos
' Beschreibung : Ausgabe von Infos
' Übergabewert : tGifPlayInfo = Type GifPlayInfo
'------------------------------------------------------
Private Sub ShowGifPlayInfos(ByRef tGifPlayInfo As GifPlayInfo)
    
    lblShowFrame.Caption = "Bildnummer: " & _
    CStr(tGifPlayInfo.GifFrame) & " von " & _
    tGifPlayInfo.GifFrames
    
    lblFrameDelay.Caption = "Pausenzeit: " & _
    CStr(tGifPlayInfo.GifDelay) & " ms"
    
    lblFrameCount.Caption = "Wiederholung: " & _
    CStr(tGifPlayInfo.GifLoops _
    - tGifPlayInfo.GifLoop) & _
    " von " & CStr(tGifPlayInfo.GifLoops)
End Sub

'------------------------------------------------------
' Funktion     : ShutdownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function ShutdownGDIPlus() As Status
    ' Beendet GDI+ Instanz
    ShutdownGDIPlus = GdiplusShutdown(GdipToken)
End Function

'------------------------------------------------------
' Funktion     : StartTimer
' Beschreibung : Startet den Timer
'------------------------------------------------------
Private Sub StartTimer(ByVal lInterval As Long)
    SetTimer Me.hwnd, 0, lInterval, AddressOf TimerProc
End Sub

'------------------------------------------------------
' Funktion     : StartUpGDIPlus
' Beschreibung : Initialisiert GDI+ Instanz
' Übergabewert : GDI+ Version
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Status
    ' Initialisieren der GDI+ Instanz
    Dim GdipStartupInput As GDIPlusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    
    GdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, _
    GdipStartupInput, GdipStartupOutput)
End Function

'------------------------------------------------------
' Funktion     : StopTimer
' Beschreibung : Stopt den Timer
'------------------------------------------------------
Private Sub StopTimer()
    KillTimer Me.hwnd, 0
End Sub

'------------------------------------------------------
' Funktion     : TranslateColor
' Beschreibung : Systemfarben zu VB-Farben konvertieren
' Übergabewert : lInColor = Farbe in Long
' Rückgabewert : Farbe in Long
'------------------------------------------------------
Private Function TranslateColor(ByVal lInColor As Long) As Long
    OleTranslateColor lInColor, 0&, TranslateColor
End Function

Private Sub cmdLoadPicture_Click()
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Dialogparameter setzen
        With cdLoadPicture
            .Filter = "Gif Files (*.gif)|*.gif"
            .CancelError = True
            .ShowOpen
        End With
        
        ' Timer stoppen
        Call StopTimer
        
        ' Framenummer auf 0 setzen
        lShowFrame = 0
        
        ' ist ein Bitmapobjekt vorhanden
        If lGifBitmap Then
            ' Bitmapobjekt löschen
            If Execute(GdipDisposeImage(lGifBitmap)) = OK Then
                lGifBitmap = 0
            End If
        End If
        
        ' GIF-Datei laden -> lGifBitmap
        If LoadGif(cdLoadPicture.FileName, _
        lGifBitmap) = OK Then
            
            ' Anzahl der einzelnen GIF-Bilder ermiteln
            ' -> lFrameCount
            If GetGifFrameCount(lGifBitmap, tGuidFDT, _
            lFrameCount) = OK Then
                
                ' nur ein Bild in der GIF-Datei
                If (lFrameCount - 1) = 0 Then
                    
                    ReDim lFrameDelay(0)
                    lFrameDelay(0) = 0
                    lFrameLoopCount = 0
                    lLoopCount = lFrameLoopCount + 1
                    
                    cmdPlayGif.Enabled = False
                    cmdPauseGif.Enabled = False
                    cmdStopGif.Enabled = False
                    
                    With tCurGifPlayInfo
                        .GifDelay = lFrameDelay(0)
                        .GifFrame = 1
                        .GifFrames = lFrameCount
                        .GifLoop = lLoopCount - 1
                        .GifLoops = lFrameLoopCount
                    End With
                    
                    ' Bild anzeigen
                    Call DrawGifFrame(lGifBitmap, tGuidFDT, _
                    lShowFrame, oPicGif)
                Else
                    ' mehr als ein Bild in der GIF-Datei
                    
                    ' Pausen zwischen den einzelnen
                    ' Bilden ermitteln
                    ' -> lFrameDelay()
                    Call GetGifFrameDelays(lGifBitmap, _
                    lFrameCount, lFrameDelay)
                    
                    ' Anzahl der Wiederholungen ermitteln
                    ' -> lFrameLoopCount
                    Call GetGifLoopCount(lGifBitmap, _
                    lFrameLoopCount)
                    
                    lLoopCount = lFrameLoopCount + 1
                    
                    cmdPlayGif.Enabled = True
                    cmdPauseGif.Enabled = False
                    cmdStopGif.Enabled = False
                    
                    With tCurGifPlayInfo
                        .GifDelay = lFrameDelay(0)
                        .GifFrame = 1
                        .GifFrames = lFrameCount
                        .GifLoop = lLoopCount - 1
                        .GifLoops = lFrameLoopCount
                    End With
                    
                    ' Bild anzeigen
                    Call DrawGifFrame(lGifBitmap, tGuidFDT, _
                    lShowFrame, oPicGif)
                    
                    ' Wiedergabe starten
                    If ckAutoPlay.value = 1 Then _
                    Call cmdPlayGif_Click
                End If
                
            End If
        End If
    End If
    Exit Sub
errorhandler:
End Sub

Private Sub Form_Load()
    GdipInitialized = False
    
    With Me
        .Caption = "GDI+ Play AnimGif"
        .ScaleMode = vbPixels
        .Width = 6360
        .Height = 5520
    End With
    
    With cmdLoadPicture
        .Move 2, 2, 80, 25
        .Caption = "Load Gif"
    End With
    
    With cmdPlayGif
        .Move cmdLoadPicture.Left + _
        cmdLoadPicture.Width + 2, 2, 80, 25
        .Caption = "Play"
        .Enabled = False
    End With
    
    With cmdPauseGif
        .Move cmdPlayGif.Left + _
        cmdPlayGif.Width + 2, 2, 80, 25
        .Caption = "Pause"
        .Enabled = False
    End With
    
    With cmdStopGif
        .Move cmdPauseGif.Left + _
        cmdPauseGif.Width + 2, 2, 80, 25
        .Caption = "Stop"
        .Enabled = False
    End With
    
    With ckAutoPlay
        .Move cmdStopGif.Left + _
        cmdStopGif.Width + 5, 2, 80, 25
        .Caption = "AutoPlay"
        .value = 1
    End With
    
    With lblShowFrame
        .Move 2, cmdLoadPicture.Top + _
        cmdLoadPicture.Height + 4, 130, 15
        .Caption = "Bildnummer: 0 von 0"
    End With
   
    With lblFrameDelay
        .Move lblShowFrame.Left + _
        lblShowFrame.Width + 4, _
        lblShowFrame.Top, 100, 15
        .Caption = "Pausenzeit: 0 ms"
    End With
   
    With lblFrameCount
        .Move 2, lblFrameDelay.Top + _
        lblFrameDelay.Height + 4, 280, 15
        .Caption = "Wiederholung: 0 von 0"
    End With
    
    ' Ausgabefenster festlegen
    Set oPicGif = picViewPort
    oPicGif.BorderStyle = 0
    oPicGif.Move 2, lblFrameCount.Top + _
    lblFrameCount.Height + 4, 0, 0

    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' Const FrameDimensionTime zu tGuidFDT konvertieren
        Call CLSIDFromString(StrPtr(FrameDimensionTime), tGuidFDT)
        
    Else
        ' Initialisierung fehlgeschlagen
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Timer stoppen
        Call StopTimer
        
        ' ist ein Bitmapobjekt vorhanden
        If lGifBitmap Then
            ' Bitmapobjekt löschen
            If Execute(GdipDisposeImage(lGifBitmap)) = OK Then
                lGifBitmap = 0
            End If
        End If
        
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub

Private Sub cmdPauseGif_Click()
    
    Call StopTimer
    
    cmdPlayGif.Enabled = True
    cmdPauseGif.Enabled = False
    cmdStopGif.Enabled = True
End Sub

Private Sub cmdPlayGif_Click()
    
    Call PlayGif
    
    cmdPlayGif.Enabled = False
    cmdPauseGif.Enabled = True
    cmdStopGif.Enabled = True
End Sub

Private Sub cmdStopGif_Click()
    
    Call StopTimer
    
    cmdPlayGif.Enabled = True
    cmdPauseGif.Enabled = False
    cmdStopGif.Enabled = False

    lShowFrame = 0
    lLoopCount = lFrameLoopCount + 1

    ' Bild anzeigen
    Call DrawGifFrame(lGifBitmap, tGuidFDT, _
    lShowFrame, oPicGif)
End Sub

'--- Ende Formular "frmGDIPlusPlayGif" alias frmGDIPlusPlayGif.frm  ---
'-------- Anfang Modul "modTimer" alias modTimer.bas --------

Option Explicit

' ----==== User32 API Deklarationen ====----
Public Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Public Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
  frmGDIPlusPlayGif.PlayGif
End Sub

'--------- Ende Modul "modTimer" alias modTimer.bas ---------
'----------- Ende Projektdatei GDIPlusPlayGif.vbp -----------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 3 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.