Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0678: Verfügbare GDI+-Encoder und Decoder ermitteln

VB 5/6-Tipp 0678: Verfügbare GDI+-Encoder und Decoder ermitteln

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), GdipGetImageDecoders, GdipGetImageDecodersSize, GdipGetImageEncoders, GdipGetImageEncodersSize, GdiplusShutdown, GdiplusStartup, StringFromCLSID (LongFromCLSID), lstrcpyW, lstrlenW

Download: Download des Beispielprojektes [5,43 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 DGIPlusEnDeCoder.vbp ---------
'--- Anfang Formular "frmDGIPlusEnDeCoder" alias frmDGIPlusEnDeCoder.frm  ---
' Steuerelement: Textfeld "txtListEnDecoder"
' Steuerelement: Schaltfläche "cmdListEnDecoder" (Index von 0 bis 1)

Option Explicit

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

' ----==== Sonstige Typen ====----
Private Type GdipImageDeEncoders
    Clsid As String
    CodecName As String
    FormatDescription As String
    FilenameExtension As String
    mimeType As String
    Flags As ImageCodecFlags
    Version 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+ Typen ====----
Private Type ImageCodecInfo
    Clsid As GUID
    FormatID As GUID
    CodecNamePtr As Long
    DllNamePtr As Long
    FormatDescriptionPtr As Long
    FilenameExtensionPtr As Long
    MimeTypePtr As Long
    Flags As Long
    Version As Long
    SignaturCount As Long
    SignaturSize As Long
    SignaturPatternPtr As Long
    SignaturMaskPtr As Long
End Type

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

' ----==== GDI+ Enumerationen ====----
Private Enum ImageCodecFlags
    ImageCodecFlagsEncoder = &H1
    ImageCodecFlagsDecoder = &H2
    ImageCodecFlagsSupportBitmap = &H4
    ImageCodecFlagsSupportVector = &H8
    ImageCodecFlagsSeekableEncode = &H10
    ImageCodecFlagsBlockingDecode = &H20
    ImageCodecFlagsBuiltin = &H10000
    ImageCodecFlagsSystem = &H20000
    ImageCodecFlagsUser = &H40000
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

' ----==== sonstige Enumerationen ====----
Private Enum EnDecoderType
    Encoder = 0
    Decoder = 1
End Enum

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipGetImageEncoders Lib "gdiplus" _
    (ByVal NumEncoders As Long, ByVal Size As Long, _
    ByRef Encoders As ImageCodecInfo) As Status

Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" _
    (ByRef NumEncoders As Long, ByRef Size As Long) As Status

Private Declare Function GdipGetImageDecoders Lib "gdiplus" _
    (ByVal NumDecoders As Long, ByVal Size As Long, _
    ByRef Decoders As ImageCodecInfo) As Status

Private Declare Function GdipGetImageDecodersSize Lib "gdiplus" _
    (ByRef NumDecoders As Long, ByRef Size 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

' ----==== Kernel32 API Declarationen ====----
Private Declare Function lstrlenW Lib "kernel32" _
    (lpString As Any) As Long

Private Declare Function lstrcpyW Lib "kernel32" _
    (lpString1 As Any, lpString2 As Any) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (pDst As Any, pSrc As Any, _
    ByVal ByteLen As Long)

' ----==== Ole32 API Deklarationen ====----
Private Declare Sub LongFromCLSID Lib "ole32.dll" _
    Alias "StringFromCLSID" (pClsid As GUID, _
    lpszProgID As Long)

' ----==== Variablen ====----
Dim GdipToken As Long
Dim GdipInitialized As Boolean

'------------------------------------------------------
' Funktion     : EnumGDIPlusEnDecoders
' Beschreibung : Auflisten aller GDI+ Encoder, Decoder
'                und auslesen der Infos
' Übergabewert : tGdipImageDeEncoders = Type GdipImageEncoders
'                eEnDecoderType = Enum EnDecoderType
' Rückgabewert : True = auflisten erfolgreich
'                False = auflisten fehlgeschlagen
'------------------------------------------------------
Private Function EnumGDIPlusEnDecoders( _
    ByRef tGdipImageDeEncoders() As GdipImageDeEncoders, _
    Optional eEnDecoderType As EnDecoderType = Decoder) As Boolean
    
    Dim lDataSize As Long
    Dim lNum As Long
    Dim lItem As Long
    Dim lGuid As Long
    Dim sBuffer As String
    Dim sGuid As String * 40
    Dim tImageCodecInfo() As ImageCodecInfo
    
    If eEnDecoderType = Decoder Then
        
        ' Anzahl der Decoder und größe der Daten ermitteln
        ' -> lNum und lDataSize
        Call Execute(GdipGetImageDecodersSize( _
        lNum, lDataSize))
    Else
    
        ' Anzahl der Encoder und größe der Daten ermitteln
        ' -> lNum und lDataSize
        Call Execute(GdipGetImageEncodersSize( _
        lNum, lDataSize))
    End If
    
    ' wenn keine Daten vorhanden sind
    If (lDataSize = 0) Then
        ' fehlgeschlagen
        EnumGDIPlusEnDecoders = False
        Exit Function
    End If
    
    ' Array zur Aufnahme der ImageCodecInfo
    ' Struktur dimensionieren
    ReDim tImageCodecInfo(0 To lDataSize _
    \ Len(tImageCodecInfo(0)) - 1)
    
    ' Array zur Aufnahme der GdipImageDeEncoders
    ' Struktur dimensionieren
    ReDim tGdipImageDeEncoders(0 To (lNum - 1))
    
    If eEnDecoderType = Decoder Then
    
        ' Auslesen aller Decoderinfos -> tImageCodecInfo
        Call Execute(GdipGetImageDecoders(lNum, _
        lDataSize, tImageCodecInfo(0)))
    Else
    
        ' Auslesen aller Encoderinfos -> tImageCodecInfo
        Call Execute(GdipGetImageEncoders(lNum, _
        lDataSize, tImageCodecInfo(0)))
    End If
    
    ' alle Encoder oder Decoder durchlaufen
    For lItem = 0 To (lNum - 1)
        
        ' Decoder GUID nach Long konvertieren -> lGuid
        Call LongFromCLSID( _
        tImageCodecInfo(lItem).Clsid, lGuid)
        
        ' lGuid konvertieren -> sGuid
        Call StrFromPtrW(lGuid, sGuid)
        
        ' sGuid an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).Clsid _
        = sGuid
        
        ' Stringbuffer anlegen
        sBuffer = Space$(lstrlenW( _
        ByVal tImageCodecInfo(lItem).MimeTypePtr))
        
        ' MimeTypePtr in den Buffer übertragen
        Call lstrcpyW(ByVal StrPtr(sBuffer), _
        ByVal tImageCodecInfo(lItem).MimeTypePtr)
        
        ' Buffer an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).mimeType _
        = sBuffer
        
        ' Stringbuffer anlegen
        sBuffer = Space$(lstrlenW( _
        ByVal tImageCodecInfo(lItem).CodecNamePtr))
        
        ' CodecNamePtr in den Buffer übertragen
        Call lstrcpyW(ByVal StrPtr(sBuffer), _
        ByVal tImageCodecInfo(lItem).CodecNamePtr)
        
        ' Buffer an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).CodecName _
        = sBuffer
        
        ' Stringbuffer anlegen
        sBuffer = Space$(lstrlenW( _
        ByVal tImageCodecInfo(lItem).FormatDescriptionPtr))
        
        ' FormatDescriptionPtr in den Buffer übertragen
        Call lstrcpyW(ByVal StrPtr(sBuffer), _
        ByVal tImageCodecInfo(lItem).FormatDescriptionPtr)
        
        ' Buffer an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).FormatDescription _
        = sBuffer
        
        ' Stringbuffer anlegen
        sBuffer = Space$(lstrlenW( _
        ByVal tImageCodecInfo(lItem).FilenameExtensionPtr))
        
        ' FilenameExtensionPtr in den Buffer übertragen
        Call lstrcpyW(ByVal StrPtr(sBuffer), _
        ByVal tImageCodecInfo(lItem).FilenameExtensionPtr)
        
        ' Buffer an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).FilenameExtension _
        = sBuffer
        
        ' Flags an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).Flags _
        = tImageCodecInfo(lItem).Flags
        
        ' Version an tGdipImageDeEncoders übergeben
        tGdipImageDeEncoders(lItem).Version _
        = tImageCodecInfo(lItem).Version
        
    Next lItem
    
    ' tImageCodecInfo löschen
    Erase tImageCodecInfo
    
    ' erfolgreich
    EnumGDIPlusEnDecoders = True
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     : ShutdownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
'------------------------------------------------------
Private Function ShutdownGDIPlus() As Status
    ' Beendet GDI+ Instanz
    ShutdownGDIPlus = GdiplusShutdown(GdipToken)
End Function

'------------------------------------------------------
' 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     : StrFromPtrW
' Beschreibung : Konvertiert einen Pointer auf einen
'                Unicode String zu einem Standard ANSI String
' Übergabewert : pOLESTR = Pointer auf einen Unicode String
'                strOut = String
'------------------------------------------------------
Private Sub StrFromPtrW(ByRef pOLESTR As Long, _
    ByRef strOut As String)
    
    Dim bArray(255) As Byte
    Dim iTemp As Integer
    Dim iCount As Integer
    Dim i As Integer
    
    iTemp = 1
    
    While iTemp <> 0
        CopyMemory iTemp, ByVal pOLESTR + i, 2
        bArray(iCount) = iTemp
        iCount = iCount + 1
        i = i + 2
    Wend
    
    CopyMemory ByVal strOut, bArray(0), iCount
    
End Sub

Private Sub cmdListEnDecoder_Click(Index As Integer)
    
    Dim lItem As Long
    Dim sType As String
    Dim sFileExt As String
    Dim eListType As EnDecoderType
    Dim tEnDecoderData() As GdipImageDeEncoders
    
    ' Typ festlegen
    If Index = 0 Then
        eListType = Encoder
        sType = "Encoder"
    Else
        eListType = Decoder
        sType = "Decoder"
    End If
    
    ' textBox leeren
    txtListEnDecoder.Text = vbNullString
    
    ' Auslesen der Daten
    If EnumGDIPlusEnDecoders(tEnDecoderData, _
    eListType) = True Then
        
        txtListEnDecoder.Text = txtListEnDecoder.Text & _
        "List GDI+ " & sType & vbNewLine & vbNewLine
        
        ' Alle Daten durchlaufen
        For lItem = 0 To UBound(tEnDecoderData)
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " mimeType: " & _
            tEnDecoderData(lItem).mimeType & vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " CodecName: " & _
            tEnDecoderData(lItem).CodecName & vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Version: " & _
            tEnDecoderData(lItem).Version & vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " FormatDescription: " & _
            tEnDecoderData(lItem).FormatDescription & vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " FilenameExtension: " & _
            tEnDecoderData(lItem).FilenameExtension & vbNewLine
            
            sFileExt = sFileExt & _
            tEnDecoderData(lItem).FilenameExtension & ";"
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags in Hex: " & _
            "&H" & Hex$(tEnDecoderData(lItem).Flags) & vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsEncoder) _
            = ImageCodecFlags.ImageCodecFlagsEncoder Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags: ImageCodecFlagsEncoder" & _
            vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsDecoder) _
            = ImageCodecFlags.ImageCodecFlagsDecoder Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags: ImageCodecFlagsDecoder" & _
            vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsBlockingDecode) = _
            ImageCodecFlags.ImageCodecFlagsBlockingDecode Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & _
            " Flags: ImageCodecFlagsBlockingDecode" & vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsBuiltin) _
            = ImageCodecFlags.ImageCodecFlagsBuiltin Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags: ImageCodecFlagsBuiltin" & _
            vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsSeekableEncode) = _
            ImageCodecFlags.ImageCodecFlagsSeekableEncode Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & _
            " Flags: ImageCodecFlagsSeekableEncode" & vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsSupportBitmap) = _
            ImageCodecFlags.ImageCodecFlagsSupportBitmap Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & _
            " Flags: ImageCodecFlagsSupportBitmap" & vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsSupportVector) = _
            ImageCodecFlags.ImageCodecFlagsSupportVector Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & _
            " Flags: ImageCodecFlagsSupportVector" & vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsSystem) _
            = ImageCodecFlags.ImageCodecFlagsSystem Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags: ImageCodecFlagsSystem" & _
            vbNewLine
            
            If (tEnDecoderData(lItem).Flags And _
            ImageCodecFlagsUser) _
            = ImageCodecFlags.ImageCodecFlagsUser Then _
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Flags: ImageCodecFlagsUser" & _
            vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ " & sType & " Clsid: " & _
            tEnDecoderData(lItem).Clsid & vbNewLine
            
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            vbNewLine & vbNewLine
            
        Next lItem
        
        If Index = 0 Then
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ kann in folgenden Bildformaten speichern: " & _
            Mid$(sFileExt, 1, Len(sFileExt) - 1) & vbNewLine
        Else
            txtListEnDecoder.Text = txtListEnDecoder.Text & _
            "GDI+ kann folgende Bildformaten lesen: " & _
            Mid$(sFileExt, 1, Len(sFileExt) - 1) & vbNewLine
        End If
        
    Else
        
        MsgBox "Konnte keine GDI+ " & sType & "daten ermitteln.", _
        vbOKOnly, "GDI Error"
        
    End If
    
    Erase tEnDecoderData
End Sub

Private Sub Form_Load()
    GdipInitialized = False
    
    ' Formparameter setzen
    With Me
        .Height = 5985
        .Width = 6930
        .Caption = "List GDI+ Encoder and Decoder"
    End With
    
    ' TextBoxparameter setzen
    With txtListEnDecoder
        .Move 60, 60, 6700, 5000
        
        ' Parameter im müssen im
        ' Entwurfsmodus gesetzt werden
        '.MultiLine = True
        '.ScrollBars = 3
    End With
    
    ' Buttonparameter setzen
    With cmdListEnDecoder(0)
        .Caption = "List GDI+ Encoder Infos"
        .Move 60, 60 + txtListEnDecoder.Top + _
        txtListEnDecoder.Height, 2085, 400
        .Enabled = False
    End With

    ' Buttonparameter setzen
    With cmdListEnDecoder(1)
        .Caption = "List GDI+ Decoder Infos"
        .Move 60 + cmdListEnDecoder(0).Left + _
        cmdListEnDecoder(0).Width, 60 + _
        txtListEnDecoder.Top + _
        txtListEnDecoder.Height, 2085, 400
        .Enabled = False
    End With
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' Buttons aktivieren
        cmdListEnDecoder(0).Enabled = True
        cmdListEnDecoder(1).Enabled = True
    Else
        ' initialisirung 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
        
        ' GDI+ benden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub
'--- Ende Formular "frmDGIPlusEnDeCoder" alias frmDGIPlusEnDeCoder.frm  ---
'---------- Ende Projektdatei DGIPlusEnDeCoder.vbp ----------