Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0688: Grafik mittels GDI+ als TIFF speichern

VB 5/6-Tipp 0688: Grafik mittels GDI+ als TIFF speichern

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CLSIDFromString, GdipCreateBitmapFromGdiDib (GdipCreateBitmapFromGdiDib256), GdipDisposeImage, GdipSaveImageToFile, GdiplusShutdown, GdiplusStartup, GetDC, GetDIBits (GetDIBits256), GetObjectA (GetObject), ReleaseDC

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

'--- Anfang Formular "frmGDIPlusSaveAsTiff" alias frmGDIPlusSaveAsTiff.frm  ---
' Steuerelement: Rahmensteuerelement "frCompression"
' Steuerelement: Optionsfeld-Steuerelement "obCompression" (Index von 0 bis 4) auf frCompression
' Steuerelement: Rahmensteuerelement "frPixelFormat"
' Steuerelement: Optionsfeld-Steuerelement "obPixelFormat" (Index von 0 bis 5) auf frPixelFormat
' Steuerelement: Schaltfläche "cmdSavePicture"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"
' Steuerelement: Bildfeld-Steuerelement "picOrg"
Option Explicit

' ----==== GDI+ Const ====----
Private Const EncoderCompression As String = _
    "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
    
Private Const EncoderParameterValueTypeLong As Long = 4&

Private Const GdiPlusVersion As Long = 1&

Private Const mimeTIFF As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"

' ----==== sonstige Const ====----
Private Const DIB_RGB_COLORS As Long = 0&
Private Const BI_RGB As Long = 0&

' ----==== sonstige Types ====----
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

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

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private Type BITMAPINFO256
    bmiHeader As BITMAPINFOHEADER
    bmiColors(0 To 255) As RGBQUAD
End Type

' ----==== GDI+ Types ====----
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 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+ Enums ====----
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 Enums ====----
Private Enum PixelFormat
    Format1bppIndexed = 1
    Format4bppIndexed = 4
    Format8bppIndexed = 8
    Format16bppRGB = 16
    Format24bppRGB = 24
    Format32bppRGB = 32
End Enum

Private Enum TifCompressionType
    TiffCompressionLZW = 2
    TiffCompressionCCITT3 = 3
    TiffCompressionCCITT4 = 4
    TiffCompressionRle = 5
    TiffCompressionNone = 6
End Enum

' ----==== GDI+ Deklarationen ====----
Private Declare Function GdipCreateBitmapFromGdiDib256 Lib "GDIPLUS" _
                         Alias "GdipCreateBitmapFromGdiDib" ( _
                         ByRef mGdiBitmapInfo As BITMAPINFO256, _
                         ByVal mGdiBitmapData As Long, _
                         ByRef mBitmap As Long) As Status
                         
Private Declare Function GdipDisposeImage Lib "GDIPLUS" ( _
                         ByVal mImage 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
                         
Private Declare Function GdipSaveImageToFile Lib "GDIPLUS" ( _
                         ByVal image As Long, _
                         ByVal FileName As Long, _
                         ByRef clsidEncoder As GUID, _
                         ByRef encoderParams As Any) As Status
                         
' ----==== GDI32 Deklarationen ====----
Private Declare Function GetDIBits256 Lib "gdi32" _
                         Alias "GetDIBits" ( _
                         ByVal aHDC As Long, _
                         ByVal hBitmap As Long, _
                         ByVal nStartScan As Long, _
                         ByVal nNumScans As Long, _
                         ByRef lpBits As Any, _
                         ByRef lpBI As BITMAPINFO256, _
                         ByVal wUsage As Long) As Long
                         
Private Declare Function GetObject Lib "gdi32" _
                         Alias "GetObjectA" ( _
                         ByVal hObject As Long, _
                         ByVal nCount As Long, _
                         ByRef lpObject As Any) As Long
                         
' ----==== OLE32 Deklarationen ====----
Private Declare Function CLSIDFromString Lib "ole32" ( _
                         ByVal str As Long, _
                         ByRef id As GUID) As Long
                         
' ----==== USER32 Deklarationen ====----
Private Declare Function GetDC Lib "user32" ( _
                         ByVal Hwnd As Long) As Long
                         
Private Declare Function ReleaseDC Lib "user32" ( _
                         ByVal Hwnd As Long, _
                         ByVal hdc As Long) As Long
                         
' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Private OldIndex As Long
Private LastPixelFormat As PixelFormat
Private LastCompress As TifCompressionType

' ------------------------------------------------------
' Funktion     : SaveTiff_AllRes
' Beschreibung : Speichert ein StdPicture als TIFF
' Übergabewert : InPicture = StdPicture
'                FileName = Pfad\Datei.tif
'                eBitsPerPixel = Enum PixelFormat
'                eTifCompression = Enum TifCompressionType
' Rückgabewert : True = speichern war erfolgreich
'                False = speichern war nicht erfolgreich
' ------------------------------------------------------
Private Function SaveTiff_AllRes(ByVal InPicture As StdPicture, ByVal _
    FileName As String, ByVal eBitsPerPixel As PixelFormat, Optional _
    ByVal eTifCompression As TifCompressionType = TiffCompressionNone) _
    As Boolean
    
    Dim lngDC As Long
    Dim lngBitmap As Long
    Dim lngStride As Long
    Dim tBitmap As BITMAP
    Dim tBITMAPINFO As BITMAPINFO256
    Dim bytData() As Byte
    Dim bolRet As Boolean
    Dim tPicEncoder As GUID
    Dim tEncoderParameters As EncoderParameters
    
    ' ist GDI+ initialisiert
    If GdipInitialized Then
    
        ' BitsPerPixel auf gültige Werte prüfen
        Select Case eBitsPerPixel
        
        Case 1, 4, 8, 16, 24, 32
        
            ' wenn kein Bild vorhanden oder
            ' kein Dateiname angegeben ist
            If InPicture = Empty Or Len(FileName) = 0 Then
            
                ' Funktion verlassen
                Exit Function
                
            End If
            
        Case Else
        
            MsgBox "Fehler!" & vbCrLf & "Dieses Bildformat wird nicht " & _
                "unterstützt!"
                
            ' Funktion verlassen
            Exit Function
            
        End Select
        
        ' RLE, CCITT3, CCITT4
        If eTifCompression = TiffCompressionRle Or eTifCompression = _
            TiffCompressionCCITT3 Or eTifCompression = _
            TiffCompressionCCITT4 Then
            
            eBitsPerPixel = Format1bppIndexed
            
        End If
        
        ' InPicture.Handle -> tBitmap
        If GetObject(InPicture.Handle, Len(tBitmap), tBitmap) <> 0 Then
        
            tBITMAPINFO.bmiHeader.biHeight = tBitmap.bmHeight
            tBITMAPINFO.bmiHeader.biWidth = tBitmap.bmWidth
            tBITMAPINFO.bmiHeader.biPlanes = tBitmap.bmPlanes
            tBITMAPINFO.bmiHeader.biBitCount = eBitsPerPixel
            tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader)
            tBITMAPINFO.bmiHeader.biCompression = BI_RGB
            
            ' Breite einer Zeile, inklusiv eventuell vorhander PadBytes, in
            ' Abhängigkeit vom PixelFormat berechnen
            Select Case eBitsPerPixel
            
            Case 1
                lngStride = ((tBitmap.bmWidth + 31) And Not 31) \ 8
                
            Case 4
                lngStride = ((tBitmap.bmWidth + 7) And Not 7) \ 2
                
            Case 8
                lngStride = (tBitmap.bmWidth + 3) And Not 3
                
            Case 16
                lngStride = ((tBitmap.bmWidth * 2) + 2) And Not 2
                
            Case 24
                lngStride = ((tBitmap.bmWidth * 3) + 3) And Not 3
                
            Case 32
                lngStride = tBitmap.bmWidth * 4
                
            End Select
            
            ' ByteArray zur Aufnahme der DIB-Daten dimensionieren
            ReDim bytData((tBitmap.bmHeight * lngStride) - 1)
            
            ' DC des Desktop ermitteln
            lngDC = GetDC(0&)
            
            ' ist ein DC vorhanden
            If lngDC <> 0 Then
            
                ' DIB-Daten auslesen -> bytData
                If GetDIBits256(lngDC, InPicture.Handle, 0&, _
                    tBitmap.bmHeight, bytData(0), tBITMAPINFO, _
                    DIB_RGB_COLORS) <> 0 Then
                    
                    ' GDI+ Bitmap aus den DIB-Daten erstellen -> lngBitmap
                    If Execute(GdipCreateBitmapFromGdiDib256(tBITMAPINFO, _
                        VarPtr(bytData(0)), lngBitmap)) = OK Then
                        
                        ' mimeTIFF -> tPicEncoder
                        If CLSIDFromString(StrPtr(mimeTIFF), tPicEncoder) = 0 _
                            Then
                            
                            tEncoderParameters.Count = 1
                            
                            With tEncoderParameters.Parameter(0)
                            
                                ' Setzen der Kompressions GUID
                                CLSIDFromString StrPtr( _
                                    EncoderCompression), .GUID
                                    
                                .NumberOfValues = 1
                                .Type = EncoderParameterValueTypeLong
                                
                                ' Kompressionstyp
                                .Value = VarPtr(eTifCompression)
                                
                            End With
                            
                            ' lngBitmap als Bitmap speichern
                            If Execute(GdipSaveImageToFile(lngBitmap, _
                                StrPtr(FileName), tPicEncoder, _
                                tEncoderParameters)) = OK Then
                                
                                ' das speichern war erfolgreich
                                bolRet = True
                                
                            End If
                            
                        End If
                        
                        ' lngBitmap löschen
                        Call Execute(GdipDisposeImage(lngBitmap))
                        
                    End If
                    
                End If
                
                ' DC freigeben
                Call ReleaseDC(0&, lngDC)
                
            End If
            
        End If
        
    End If
    
    ' Status des speicherns zurückliefern
    SaveTiff_AllRes = bolRet
    
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     : 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 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 ProfileNotFound:           s = "Profile Not Found"
    Case Else:                      s = "Unknown GDI+ Error."
    
    End Select
    
    GdiErrorString = s
    
End Function

Private Sub cmdLoadPicture_Click()

    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized Then
    
        ' Dialogparameter setzen
        With CommonDialog1
        
            .Filter = "All Picture Files (*.BMP;*.DIB;*.JPG;*.GIF;*.EM" & _
                "F;*.WMF;*.ICO;*.CUR)|*.BMP;*.DIB;*.JPG;*.GIF;*.EMF;*." & _
                "WMF;*.ICO;*.CUR"
                
            .CancelError = True
            
            .ShowOpen
            
        End With
        
        ' Frame und Button aktivieren
        frPixelFormat.Enabled = True
        frCompression.Enabled = True
        cmdSavePicture.Enabled = True
        
        ' Bild laden
        picOrg.Picture = LoadPicture(CommonDialog1.FileName)
        
    End If
    
    Exit Sub
    
errorhandler:

End Sub

Private Sub cmdSavePicture_Click()

    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized Then
    
        ' Dialogparameter setzen
        With CommonDialog1
        
            .Filter = "TIFF Files (*.TIF|*.TIF"
            .FileName = "*.tif"
            .CancelError = True
            .ShowSave
            .Flags = cdlOFNOverwritePrompt
            
        End With
        
        ' Bild konvertieren und speichern
        If SaveTiff_AllRes(picOrg.Picture, CommonDialog1.FileName, _
            LastPixelFormat, LastCompress) Then
            
            MsgBox "Das speichern der TIFF war erfolgreich.", vbOKOnly Or _
                vbInformation
                
        Else
        
            MsgBox "Das speichern der TIFF war nicht erfolgreich.", _
                vbOKOnly Or vbCritical
                
        End If
        
    End If
    
    Exit Sub
    
errorhandler:

End Sub

Private Sub Form_Load()

    GdipInitialized = False
    LastPixelFormat = Format24bppRGB
    LastCompress = TiffCompressionNone
    cmdSavePicture.Enabled = False
    cmdLoadPicture.Enabled = False
    frPixelFormat.Enabled = False
    frCompression.Enabled = False
    
    ' GDI+ starten
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
    
        GdipInitialized = True
        
        cmdLoadPicture.Enabled = True
        
    Else
    
        MsgBox "GDI+ not inizialized.", vbOKOnly, "GDI Error"
        
    End If
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    If GdipInitialized = True Then
    
        ' GDI+ beenden
        Call Execute(ShutdownGDIPlus)
        
    End If
    
End Sub

Private Sub obCompression_Click(Index As Integer)

    Dim lngZ As Long
    
    Select Case Index
    
    Case 0
        LastCompress = TiffCompressionLZW
        
    Case 1
        LastCompress = TiffCompressionCCITT3
        
    Case 2
        LastCompress = TiffCompressionCCITT4
        
    Case 3
        LastCompress = TiffCompressionRle
        
    Case 4
        LastCompress = TiffCompressionNone
        
    End Select
    
    ' RLE, CCITT3, CCITT4
    If LastCompress = TiffCompressionRle Or LastCompress = _
        TiffCompressionCCITT3 Or LastCompress = TiffCompressionCCITT4 _
        Then
        
        If obPixelFormat(0).Value = False Then
        
            For lngZ = 1 To 5
            
                If obPixelFormat(lngZ).Value = True Then OldIndex = lngZ
                
                If obPixelFormat(lngZ).Enabled = True Then obPixelFormat( _
                    lngZ).Enabled = False
                    
            Next lngZ
            
            obPixelFormat(0).Value = True
            
        End If
        
    Else
    
        For lngZ = 1 To 5
        
            If obPixelFormat(lngZ).Enabled = False Then obPixelFormat( _
                lngZ).Enabled = True
                
            If lngZ = OldIndex Then obPixelFormat(lngZ).Value = True
            
        Next lngZ
        
    End If
    
End Sub

Private Sub obPixelFormat_Click(Index As Integer)

    Select Case Index
    
    Case 0
        LastPixelFormat = Format1bppIndexed
        
    Case 1
        LastPixelFormat = Format4bppIndexed
        
    Case 2
        LastPixelFormat = Format8bppIndexed
        
    Case 3
        LastPixelFormat = Format16bppRGB
        
    Case 4
        LastPixelFormat = Format24bppRGB
        
    Case 5
        LastPixelFormat = Format32bppRGB
        
    End Select
    
    If Index > 0 Then OldIndex = Index
    
End Sub
'--- Ende Formular "frmGDIPlusSaveAsTiff" alias frmGDIPlusSaveAsTiff.frm  ---
'--------- Ende Projektdatei GDIPlusSaveAsTiff.vbp  ---------

Archivierte Nutzerkommentare 

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