Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0660: Multiframe-Tiff (mehrere Bilder in einer Datei) mit GDI+ erzeugen und auslesen

VB 5/6-Tipp 0660: Multiframe-Tiff (mehrere Bilder in einer Datei) mit GDI+ erzeugen und auslesen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, GdipCreateFromHDC, GdipDeleteGraphics, GdipDisposeImage, GdipDrawImageRect, GdipGetImageDimension, GdipGetImageEncoders, GdipGetImageEncodersSize, GdipImageGetFrameCount, GdipImageSelectActiveFrame, GdipLoadImageFromFile, GdipSaveAdd, GdipSaveAddImage, GdipSaveImageToFile, GdiplusShutdown, GdiplusStartup, lstrcpyW, lstrlenW

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

'--- Anfang Formular "frmGDIPlusMultipleTIFF" alias frmGDIPlusMultipleTIFF.frm  ---
' Steuerelement: Horizontale Scrollbar "HScroll1"
' Steuerelement: Schaltfläche "cmdAddFileToList"
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "cmdSaveAsTiff"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"

Option Explicit

' ----==== GDIPlus Const ====----
Private Const GdiPlusVersion As Long = 1
Private Const mimeTIFF As String = "image/tiff"

Private Const EncoderCompression As String = _
    "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
    
Private Const EncoderSaveFlag As String = _
    "{292266FC-AC40-47BF-8CFC-A85B89A655DE}"
    
Private Const FrameDimensionPage = _
    "{7462DC86-6180-4C7E-8E3F-EE7333A7A483}"
    
Private Const EncoderParameterValueTypeLong As Long = 4

' ----==== Sonstige Types ====----
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

' ----==== GDIPlus Types ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    Type As Long
    Value As Long
End Type

Private Type EncoderParameters
    Count As Long
    Parameter(15) As EncoderParameter
End Type

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
    SigCount As Long
    SigSize As Long
    SigPatternPtr As Long
    SigMaskPtr As Long
End Type

' ----==== GDIPlus Enums ====----
Private Enum Status 'GDI+ 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 EncoderValueConstants
    EncoderValueColorTypeCMYK = 0
    EncoderValueColorTypeYCCK = 1
    EncoderValueCompressionLZW = 2
    EncoderValueCompressionCCITT3 = 3
    EncoderValueCompressionCCITT4 = 4
    EncoderValueCompressionRle = 5
    EncoderValueCompressionNone = 6
    EncoderValueScanMethodInterlaced = 7
    EncoderValueScanMethodNonInterlaced = 8
    EncoderValueVersionGif87 = 9
    EncoderValueVersionGif89 = 10
    EncoderValueRenderProgressive = 11
    EncoderValueRenderNonProgressive = 12
    EncoderValueTransformRotate90 = 13
    EncoderValueTransformRotate180 = 14
    EncoderValueTransformRotate270 = 15
    EncoderValueTransformFlipHorizontal = 16
    EncoderValueTransformFlipVertical = 17
    EncoderValueMultiFrame = 18
    EncoderValueLastFrame = 19
    EncoderValueFlush = 20
    EncoderValueFrameDimensionTime = 21
    EncoderValueFrameDimensionResolution = 22
    EncoderValueFrameDimensionPage = 23
End Enum

' ----==== Sonstige Enums ====----
Private Enum TifCompressionType
    TiffCompressionLZW = EncoderValueConstants.EncoderValueCompressionLZW
    TiffCompressionCCITT3 = EncoderValueConstants.EncoderValueCompressionCCITT3
    TiffCompressionCCITT4 = EncoderValueConstants.EncoderValueCompressionCCITT4
    TiffCompressionRle = EncoderValueConstants.EncoderValueCompressionRle
    TiffCompressionNone = EncoderValueConstants.EncoderValueCompressionNone
End Enum

Private Enum EncoderSaveFlagType
    EncoderMultiFrame = EncoderValueConstants.EncoderValueMultiFrame
    EncoderLastFrame = EncoderValueConstants.EncoderValueLastFrame
    EncoderFlush = EncoderValueConstants.EncoderValueFlush
    EncoderFrameDimensionTime = EncoderValueConstants.EncoderValueFrameDimensionTime
    EncoderFrameDimensionResolution = EncoderValueConstants.EncoderValueFrameDimensionResolution
    EncoderFrameDimensionPage = EncoderValueConstants.EncoderValueFrameDimensionPage
End Enum

' ----==== GDI+ API Declarationen ====----
Private Declare Function GdiplusStartup Lib "gdiplus" _
    (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
    Optional ByRef lpOutput As Any) As Status

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

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

Private Declare Function GdipGetImageDimension Lib "gdiplus" _
    (ByVal image As Long, ByRef Width As Single, _
    ByRef Height As Single) 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 GdipSaveImageToFile Lib "gdiplus" _
    (ByVal image As Long, ByVal FileName As Long, _
    ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Status

Private Declare Function GdipSaveAdd Lib "gdiplus" _
    (ByVal image As Long, ByRef encoderParams As _
    EncoderParameters) As Status

Private Declare Function GdipSaveAddImage Lib "gdiplus" _
    (ByVal image As Long, ByVal newImage As Long, _
    ByRef encoderParams As EncoderParameters) 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 GdipImageGetFrameCount Lib "gdiplus" _
    (ByVal image As Long, ByRef dimensionID As GUID, _
    ByRef Count As Long) As Status
    
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" _
    (ByRef numEncoders As Long, ByRef Size As Long) As Status

Private Declare Function GdipGetImageEncoders Lib "gdiplus" _
    (ByVal numEncoders As Long, ByVal Size As Long, _
    ByRef Encoders As Any) As Status

Private Declare Function GdipCreateFromHDC Lib "gdiplus" _
    (ByVal hdc As Long, ByRef graphics As Long) As Status

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

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

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

' ----==== Kernel API Declarations ====----
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

' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private lBitmap As Long
Private lngGraphics As Long
Private cid As GUID
Private lFrameCount As Long

'------------------------------------------------------
' 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
    GdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
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     : 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 = Status.OK Then
        lCurErr = Status.OK
    Else
        lCurErr = lReturn
        Call 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 lError As Status) As String
    Dim s As String
    
    Select Case lError
    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     : LoadMultipleTiff
' Beschreibung : Lädt ein Bilddatei per GDI+
' Übergabewert : Pfad\Dateiname der Bilddatei
' Rückgabewert : True
'------------------------------------------------------
Public Function LoadMultipleTiff(ByVal PicBox As PictureBox, _
                                 ByVal FileName As String) As Boolean
    Dim retStatus As Status
    
    ' fals vorhanden Bitmaps löschen
    If lngGraphics Then Call Execute(GdipDeleteGraphics(lngGraphics))
    If lBitmap Then Call Execute(GdipDisposeImage(lBitmap))
    
    ' Erzeugen eines Grafikobjekts von PicBox -> lngGraphics
    retStatus = Execute(GdipCreateFromHDC(PicBox.hdc, lngGraphics))
    If retStatus = Status.OK Then
        
        ' Öffnet die Bilddatei in lBitmap
        retStatus = Execute(GdipLoadImageFromFile(StrPtr(FileName), _
            lBitmap))
        
        ' CLSID für MultipleFrameTiff
        Call CLSIDFromString(StrPtr(FrameDimensionPage), cid)
        
        ' Anzahl der Bilder im Tiff ermitteln
        Call Execute(GdipImageGetFrameCount(lBitmap, cid, lFrameCount))
        If lFrameCount - 1 = 0 Then
            HScroll1.Enabled = False
        Else
            HScroll1.Enabled = True
            HScroll1.Max = lFrameCount - 1
            HScroll1.Min = 0
            HScroll1.Value = 0
        End If
        
    ' zeichnen des ersten Frame
    LoadMultipleTiff = UpdateScroll(PicBox, 0)
    
    End If
End Function

'------------------------------------------------------
' Funktion     : UpdateScroll
' Beschreibung : Zeichnet das Frame in die PictureBox
' Übergabewert : PicBox = PictureBox
'                Frame = Framenummmer
' Rückgabewert : True = zeichnen erfolgreich
'                False = zeichnen fehlgeschlagen
'------------------------------------------------------
Public Function UpdateScroll(PicBox As PictureBox, Frame As Long) As Boolean
    Dim sngWidth As Single
    Dim sngHeight As Single
    
    PicBox.Refresh
    
    ' aktiven Frame (Bild in Tiff) auswählen
    If Execute(GdipImageSelectActiveFrame(lBitmap, cid, Frame)) = OK Then
    
        ' ImageDimension des Frame ermitteln
        If Execute(GdipGetImageDimension(lBitmap, sngWidth, sngHeight)) _
            = OK Then
            
            ' aktiven Frame zeichnen
            If GdipDrawImageRect(lngGraphics, lBitmap, _
                                 0, 0, sngWidth, sngHeight) = OK Then
                UpdateScroll = True
            Else
                UpdateScroll = False
            End If
        End If
    End If
End Function

'------------------------------------------------------
' Funktion     : SavePicturesAsMultipleTiff
' Beschreibung : Speichert mehrere Bilder per GDI+ als MultipleTiff
' Übergabewert : sFilenames = StringArray
'                FileName = Pfad\Dateiname.tif
'                TifCompression = Tiff Kompression
' Rückgabewert : True = speichern erfolgreich
'                False = speichern fehlgeschlagen
'------------------------------------------------------
Private Function SavePicturesAsMultipleTiff(ByRef sFilenames() As String, _
    ByVal FileName As String, Optional ByVal TifCompression As _
    TifCompressionType = TiffCompressionNone) As Boolean
    
    Dim retStatus As Status
    Dim retVal As Boolean
    Dim lBitmapTiff() As Long
    Dim paramValue As Long
    Dim i As Long
    Dim FilesCount As Long
    
    Dim PicEncoder As GUID
    Dim tParams As EncoderParameters
    
    '// Ermitteln der CLSID vom mimeType Encoder
    Call GetEncoderClsid(mimeTIFF, PicEncoder)
    
    ' Initialisieren der Encoderparameter
    tParams.Count = 2
    With tParams.Parameter(0) ' Tiff Kompression
        ' Setzen der Kompression GUID
        CLSIDFromString StrPtr(EncoderCompression), .GUID
        .NumberOfValues = 1
        .Type = EncoderParameterValueTypeLong
        .Value = VarPtr(TifCompression)
    End With
    
    With tParams.Parameter(1) ' EncoderSaveFlag
        ' Setzen der EncoderSave GUID
        CLSIDFromString StrPtr(EncoderSaveFlag), .GUID
        .NumberOfValues = 1
        .Type = EncoderParameterValueTypeLong
        .Value = VarPtr(paramValue)
    End With
    
    FilesCount = UBound(sFilenames)
    ReDim lBitmapTiff(FilesCount)
    
    For i = 0 To FilesCount
        
        ' Bild aus sFilenames laden
        If Execute(GdipLoadImageFromFile(StrPtr(sFilenames(i)), _
                                         lBitmapTiff(i))) = OK Then
            
            If i = 0 Then
                ' erstes Bild als Tiff speichern
                paramValue = EncoderValueMultiFrame
                If Execute(GdipSaveImageToFile(lBitmapTiff(0), _
                                               StrPtr(FileName), _
                                               PicEncoder, _
                                               tParams)) <> OK Then
                    Exit For
                End If
            Else
                ' weitere Bilder in Tiff(lBitmap(0)) hinzufügen
                paramValue = EncoderValueFrameDimensionPage
                If Execute(GdipSaveAddImage(lBitmapTiff(0), _
                                            lBitmapTiff(i), _
                                            tParams)) <> OK Then
                    Exit For
                End If
            End If
            
        End If
    Next i
    
    ' abschließen des speicherns
    paramValue = EncoderValueFlush
    If Execute(GdipSaveAdd(lBitmapTiff(0), tParams)) = OK Then
        SavePicturesAsMultipleTiff = True
    Else
        SavePicturesAsMultipleTiff = False
    End If
    
    For i = 0 To FilesCount
        ' Destroy the bitmaps
        Call Execute(GdipDisposeImage(lBitmapTiff(i)))
    Next i

    Erase lBitmapTiff
End Function

'------------------------------------------------------
' Funktion     : GetEncoderClsid
' Beschreibung : Ermittelt die Clsid des Encoders
' Übergabewert : mimeType = mimeType des Encoders
'                pClsid = CLSID des Encoders (in/out)
' Rückgabewert : True = Ermitteln erfolgreich
'                False = Ermitteln fehlgeschlagen
'------------------------------------------------------
Private Function GetEncoderClsid(mimeType As String, _
    pClsid As GUID) As Boolean
    
    Dim num As Long
    Dim Size As Long
    Dim pImageCodecInfo() As ImageCodecInfo
    Dim j As Long
    Dim buffer As String
    
    Call GdipGetImageEncodersSize(num, Size)
    If (Size = 0) Then
        GetEncoderClsid = False  '// fehlgeschlagen
        Exit Function
    End If
    
    ReDim pImageCodecInfo(0 To Size \ Len(pImageCodecInfo(0)) - 1)
    Call GdipGetImageEncoders(num, Size, pImageCodecInfo(0))
    
    For j = 0 To num - 1
        buffer = Space$(lstrlenW(ByVal pImageCodecInfo(j).MimeTypePtr))
        
        Call lstrcpyW(ByVal StrPtr(buffer), _
            ByVal pImageCodecInfo(j).MimeTypePtr)
        
        If (StrComp(buffer, mimeType, vbTextCompare) = 0) Then
            pClsid = pImageCodecInfo(j).Clsid
            Erase pImageCodecInfo
            GetEncoderClsid = True  '// erfolgreich
            Exit Function
        End If
    Next j
    
    Erase pImageCodecInfo
    GetEncoderClsid = False  '// fehlgeschlagen
End Function

Private Sub cmdAddFileToList_Click()
    On Error Goto errorhandler
    
    If GdipInitialized = True Then
        
        With CommonDialog1
            .Filter = "Images Files (*.bmp;*.gif;*.jpg;*.png;*.tif)|" & _
                      "*.bmp;*.gif;*.jpg;*.png;*.tif"
            .CancelError = True
            .ShowOpen
        End With
        
        List1.AddItem CommonDialog1.FileName
        
        If List1.ListCount > 0 Then cmdSaveAsTiff.Enabled = True
    End If
    
    Exit Sub
errorhandler:

End Sub

Private Sub cmdLoadPicture_Click()
    On Error Goto errorhandler
    
    If GdipInitialized = True Then
        
        With CommonDialog1
            .Filter = "Images Files (*.tif;*.tiff)|*.tif;*.tiff"
            .CancelError = True
            .ShowOpen
        End With
        
        Call LoadMultipleTiff(Picture1, CommonDialog1.FileName)
        
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub cmdSaveAsTiff_Click()
    Dim sFiles() As String
    Dim retVal As Boolean
    Dim i As Long
    
    On Error Goto errorhandler
    
    If GdipInitialized = True Then
        
        With CommonDialog1
            .Filter = "Images Files (*.tif;*.tiff)|*.tif;*.tiff"
            .FileName = "*.tif"
            .CancelError = True
            .Flags = cdlOFNOverwritePrompt
            .ShowSave
        End With
        
        ReDim sFiles(List1.ListCount - 1)
        
        For i = 0 To List1.ListCount - 1
            sFiles(i) = List1.List(i)
        Next i
        
        retVal = SavePicturesAsMultipleTiff(sFiles, _
                                            CommonDialog1.FileName, _
                                            TiffCompressionLZW)
        
        If retVal = False Then
            MsgBox "Das speichern der Tiff ist fehlgeschlagen.", _
                vbOKOnly, "Error"
            
            'bei einem Fehlschlag wird dennoch eine Datei erzeugt, die aber
            'fehlerhaft ist. Daher kann diese erstellte Datei wieder
            'gelöscht werden.
            Kill CommonDialog1.FileName
        End If
        
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub Form_Load()
    Dim retStatus As Status
    GdipInitialized = False
    
    retStatus = Execute(StartUpGDIPlus(GdiPlusVersion))
    If retStatus = OK Then
        GdipInitialized = True
    Else
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
    End If
    
    cmdSaveAsTiff.Enabled = False
    HScroll1.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim retStatus As Status

    If GdipInitialized = True Then
        ' Destroy the bitmap
        If lBitmap Then Call Execute(GdipDisposeImage(lBitmap))
        If lngGraphics Then Call Execute(GdipDeleteGraphics(lngGraphics))

        retStatus = Execute(ShutdownGDIPlus)
    End If
End Sub

Private Sub HScroll1_Change()
    Call UpdateScroll(Picture1, HScroll1.Value)
End Sub

Private Sub HScroll1_Scroll()
    Call UpdateScroll(Picture1, HScroll1.Value)
End Sub
'--- Ende Formular "frmGDIPlusMultipleTIFF" alias frmGDIPlusMultipleTIFF.frm  ---
'-------- Ende Projektdatei GDIPlusMultipleTIFF.vbp  --------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 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.