Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0712: Kompressionsverfahren einer TIFF-Datei ermitteln

VB 5/6-Tipp 0712: Kompressionsverfahren einer TIFF-Datei ermitteln

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMemory), GdipDisposeImage, GdipGetPropertyItem, GdipGetPropertyItemSize, GdipLoadImageFromFile, GdiplusShutdown, GdiplusStartup

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

'--- Anfang Formular "frmTiffCompresion" alias frmTiffCompresion.frm  ---
' Steuerelement: Standarddialog-Steuerelement "CDlg"
' Steuerelement: Schaltfläche "Command1"
Option Explicit

Private Sub Command1_Click()

    Dim strTiffPath As String
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    strTiffPath = App.Path
    
    If Right$(strTiffPath, 1) <> "\" Then strTiffPath = strTiffPath & "\"
    
    strTiffPath = strTiffPath & "Tiffs\"
    
    ' Parameter für den Commondialog setzen
    With CDlg
        .CancelError = True
        .Filter = "Tif Files (*.tif, *.tiff)|*.tif; *.tiff"
        .InitDir = strTiffPath
        .ShowOpen
    End With
    
    ' Ausgabe der Infos
    MsgBox "Das Kompressionsverfahren der TIFF-Datei " & Chr$(34) & _
        CDlg.FileTitle & Chr$(34) & " ist: " & GetTiffCompression( _
        CDlg.FileName)
        
    Exit Sub
    
errorhandler:

End Sub

' ------------------------------------------------------
' Beschreibung : Form laden
' ------------------------------------------------------
Private Sub Form_Load()

    GdipInitialized = False
    
    ' GDI+ initialisieren
    If StartUpGDIPlus = OK Then
    
        GdipInitialized = True
        
    Else
    
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
        
    End If
    
End Sub

' ------------------------------------------------------
' Beschreibung : Form entladen
' ------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)

    ' ist GDI+ Initialisiert
    If GdipInitialized = True Then
    
        ' GDI+ beenden
        Call ShutDownGDIPlus
        
    End If
    
End Sub
'--- Ende Formular "frmTiffCompresion" alias frmTiffCompresion.frm  ---
'--- Anfang Modul "modTiffCompression" alias modTiffCompression.bas ---
Option Explicit

' ----==== GDIPlus Const ====----
Private Const GdiPlusVersion As Long = 1
Private Const PropertyTagCompression As Long = &H103&
Private Const PropertyTagTypeShort = 3

' ----==== GDI+ Typen ====----
Private Type GdiplusStartupOutput
    NotificationHook As Long
    NotificationUnhook As Long
End Type

Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type PropertyItem
    id As Long
    length As Long
    Type As Integer
    Value As Long
End Type

' ----==== GDI+ Enumerationen ====----
Public 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

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
                         ByVal image 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 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
                         
' ----==== Kernel API Declarations ====----
Private Declare Sub CopyMemory Lib "kernel32" _
                    Alias "RtlMoveMemory" ( _
                    ByRef pDst As Any, _
                    ByRef pSrc As Any, _
                    ByVal ByteLen As Long)
                    
' ----==== Variablen ====----
Private GdipToken As Long
Public GdipInitialized As Boolean

' ------------------------------------------------------
' Funktion     : Execute
' Beschreibung : Gibt im Fehlerfall die entsprechende
'                GDI+ Fehlermeldung aus
' Übergabewert : GDI+ Status
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Private Function Execute(ByVal lReturn As Status) As Status

    Dim lCurErr As Status
    
    If lReturn = OK Then
    
        lCurErr = OK
        
    Else
    
        lCurErr = lReturn
        
        MsgBox GdiErrorString(lReturn) & " GDI+ Error:" & lReturn, _
            vbOKOnly, "GDI Error"
            
    End If
    
    Execute = lCurErr
    
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 ProfileNotFound:           s = "Profile Not Found"
    Case Else:                      s = "Unknown GDI+ Error."
    
    End Select
    
    GdiErrorString = s
    
End Function

' ------------------------------------------------------
' Funktion     : GetTiffCompression
' Beschreibung : Ermitteln des Kompressionstyp einer TIFF-Datei
' Übergabewert : Pfad\Dateiname.ext der TIFF-Bilddatei
' Rückgabewert : Tiff-Kompressionstyp als String
' ------------------------------------------------------
Public Function GetTiffCompression(ByVal sFileName As String) As String

    Dim lngImage As Long
    Dim lngItemSize As Long
    Dim bytItemData() As Byte
    Dim intItem As Integer
    Dim tPropertyItem As PropertyItem
    Dim strRet As String
    
    ' ist in sFileName ein String
    If Len(sFileName) > 0 Then
    
        ' ist GDI+ Initialisiert
        If GdipInitialized = True Then
        
            ' Bilddatei laden -> lngImage
            If Execute(GdipLoadImageFromFile(StrPtr(sFileName), lngImage)) = _
                OK Then
                
                ' größe der Propertydaten auslesen
                If Execute(GdipGetPropertyItemSize(lngImage, _
                    PropertyTagCompression, lngItemSize)) = OK Then
                    
                    ' Array zur Aufname der
                    ' Propertydaten dimensionieren
                    ReDim bytItemData(lngItemSize - 1)
                    
                    ' Propertydaten auslesen -> bytItemData
                    If Execute(GdipGetPropertyItem(lngImage, _
                        PropertyTagCompression, lngItemSize, bytItemData( _
                        0))) = OK Then
                        
                        ' ByteArray nach tPropertyItem kopieren
                        Call CopyMemory(tPropertyItem, bytItemData(0), LenB( _
                            tPropertyItem))
                            
                        ' ist der Propertytyp = Short (Integer)
                        If tPropertyItem.Type = PropertyTagTypeShort Then
                        
                            ' Propertyvalue nach Integer
                            ' kopieren -> intItem
                            Call CopyMemory(intItem, ByVal _
                                tPropertyItem.Value, tPropertyItem.length)
                                
                            ' intItem auswerten
                            Select Case intItem
                            
                            Case 1
                                strRet = "Uncompressed"
                                
                            Case 3
                                strRet = "CCITT3"
                                
                            Case 4
                                strRet = "CCITT4"
                                
                            Case 5
                                strRet = "LZW"
                                
                            Case 6
                                strRet = "JPEG"
                                
                            Case -32763
                                strRet = "RLE"
                                
                            Case Else
                                strRet = "Reserved"
                                
                            End Select
                            
                        End If
                    End If
                End If
                
                ' lngImage löschen
                Call Execute(GdipDisposeImage(lngImage))
                
            End If
        End If
    End If
    
    GetTiffCompression = strRet
    
End Function

' ------------------------------------------------------
' Funktion     : StartUpGDIPlus
' Beschreibung : Initialisiert GDI+ Instanz
' Übergabewert : GDI+ Version
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Public Function StartUpGDIPlus() As Status

    ' Initialisieren der GDI+ Instanz
    Dim tGdipStartupInput As GDIPlusStartupInput
    Dim tGdipStartupOutput As GdiplusStartupOutput
    
    tGdipStartupInput.GdiPlusVersion = GdiPlusVersion
    
    StartUpGDIPlus = Execute(GdiplusStartup(GdipToken, tGdipStartupInput, _
        tGdipStartupOutput))
        
End Function

' ------------------------------------------------------
' Funktion     : ShutDownGDIPlus
' Beschreibung : Beendet die GDI+ Instanz
' Rückgabewert : GDI+ Status
' ------------------------------------------------------
Public Function ShutDownGDIPlus() As Status

    ' Beendet GDI+ Instanz
    ShutDownGDIPlus = GdiplusShutdown(GdipToken)
    
End Function


'--- Ende Modul "modTiffCompression" alias modTiffCompression.bas ---
'--------- Ende Projektdatei GdipTiffCompresion.vbp ---------