Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0658: Optimierte Darstellung von Bilddateien per GDI+

VB 5/6-Tipp 0658: Optimierte Darstellung von Bilddateien per GDI+

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipCreateFromHDC, GdipDeleteGraphics, GdipDisposeImage, GdipDrawImageRect, GdipGetCompositingMode, GdipGetCompositingQuality, GdipGetImageDimension, GdipGetInterpolationMode, GdipGetPixelOffsetMode, GdipGetSmoothingMode, GdipLoadImageFromFile, GdipSetCompositingMode, GdipSetCompositingQuality, GdipSetInterpolationMode, GdipSetPixelOffsetMode, GdipSetSmoothingMode, GdiplusShutdown, GdiplusStartup

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

'--- Anfang Formular "frmGDIPlusDrawImage" alias frmGDIPlusDrawImage.frm  ---
' Steuerelement: Bildfeld-Steuerelement "Picture1" (Index von 0 bis 3)
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"

Option Explicit

' ----==== GDIPlus Const ====----
Private Const GdiPlusVersion As Long = 1&

Private Const QualityModeInvalid As Long = -1&
Private Const QualityModeDefault As Long = 0&
Private Const QualityModeLow As Long = 1&
Private Const QualityModeHigh As Long = 2&

' ----==== GDIPlus Types ====----
Private Type GDIPlusStartupInput
    GdiPlusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs 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 InterpolationMode
    InterpolationModeInvalid = QualityModeInvalid
    InterpolationModeDefault = QualityModeDefault
    InterpolationModeLowQuality = QualityModeLow
    InterpolationModeHighQuality = QualityModeHigh
    InterpolationModeBilinear = QualityModeHigh + 1
    InterpolationModeBicubic = QualityModeHigh + 2
    InterpolationModeNearestNeighbor = QualityModeHigh + 3
    InterpolationModeHighQualityBilinear = QualityModeHigh + 4
    InterpolationModeHighQualityBicubic = QualityModeHigh + 5
End Enum

Private Enum SmoothingMode
    SmoothingModeInvalid = QualityModeInvalid
    SmoothingModeDefault = QualityModeDefault
    SmoothingModeHighSpeed = QualityModeLow
    SmoothingModeHighQuality = QualityModeHigh
    SmoothingModeNone = QualityModeHigh + 1
    SmoothingModeAntiAlias8x4 = QualityModeHigh + 2
    SmoothingModeAntiAlias = SmoothingModeAntiAlias8x4
    'SmoothingModeAntiAlias8x8
End Enum

Private Enum PixelOffsetMode
    PixelOffsetModeInvalid = QualityModeInvalid
    PixelOffsetModeDefault = QualityModeDefault
    PixelOffsetModeHighSpeed = QualityModeLow
    PixelOffsetModeHighQuality = QualityModeHigh
    PixelOffsetModeNone = QualityModeHigh + 1
    PixelOffsetModeHalf = QualityModeHigh + 2
End Enum

Private Enum CompositingQualityMode
    CompositingQualityInvalid = QualityModeInvalid
    CompositingQualityDefault = QualityModeDefault
    CompositingQualityHighSpeed = QualityModeLow
    CompositingQualityHighQuality = QualityModeHigh
    CompositingQualityGammaCorrected = QualityModeHigh + 1
    CompositingQualityAssumeLinear = QualityModeHigh + 2
End Enum

Private Enum CompositingModeMode
    CompositingModeSourceOver = 0
    CompositingModeSourceCopy = 1
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 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 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 GdipGetImageDimension Lib "gdiplus" _
    (ByVal image As Long, ByRef Width As Single, _
    ByRef Height As Single) As Status

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

Private Declare Function GdipSetInterpolationMode Lib "gdiplus" _
    (ByVal graphics As Long, ByVal InterpolationMode As _
    InterpolationMode) As Status

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

Private Declare Function GdipSetSmoothingMode Lib "gdiplus" _
    (ByVal graphics As Long, ByVal SmoothingMode As _
    SmoothingMode) As Status

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

Private Declare Function GdipSetPixelOffsetMode Lib "gdiplus" _
    (ByVal graphics As Long, ByVal PixelOffsetMode As _
    PixelOffsetMode) As Status

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

Private Declare Function GdipSetCompositingQuality Lib "gdiplus" _
    (ByVal graphics As Long, ByVal CompositingQuality As _
    CompositingQualityMode) As Status

Private Declare Function GdipGetCompositingQuality Lib "gdiplus" _
    (ByVal graphics As Long, ByRef CompositingQuality As _
    CompositingQualityMode) As Status

Private Declare Function GdipSetCompositingMode Lib "gdiplus" _
    (ByVal graphics As Long, ByVal CompositingMode As _
    CompositingModeMode) As Status

Private Declare Function GdipGetCompositingMode Lib "gdiplus" _
    (ByVal graphics As Long, ByRef CompositingMode As _
    CompositingModeMode) As Status

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

'------------------------------------------------------
' 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     : DrawImageFromFile
' Beschreibung : Lädt ein Bilddatei per GDI+
' Übergabewert : FileName = Pfad\Dateiname der Bilddatei
'                Percent = Größe in Prozent (100% = 1:1)
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function DrawImageFromFile(ByVal FileName As String, _
    ByVal DrawHdc As Long, ByVal Percent As Long, _
    Optional ByVal Interpolation As InterpolationMode = _
    InterpolationModeDefault, Optional ByVal Smoothing As SmoothingMode _
    = SmoothingModeNone, Optional ByVal PixelOffset As PixelOffsetMode = _
    PixelOffsetModeNone, Optional ByVal CompositingQuality As _
    CompositingQualityMode = CompositingQualityDefault, Optional ByVal _
    CompositingMode As CompositingModeMode = CompositingModeSourceOver) _
    As Boolean
    
    Dim retStatus As Status
    Dim lBitmap As Long
    Dim lngGraphics As Long
    Dim ImageWidth As Single
    Dim ImageHeight As Single
    Dim IW As Single
    Dim IH As Single
    
    ' Erzeugen eines Grafikobjekts von DrawHdc -> lngGraphics
    retStatus = Execute(GdipCreateFromHDC(DrawHdc, lngGraphics))
    If retStatus = OK Then
        
        ' Setzen der Optimierungsmodis
        Call Execute(GdipSetSmoothingMode(lngGraphics, _
            Smoothing))
            
        Call Execute(GdipSetInterpolationMode(lngGraphics, _
            Interpolation))
            
        Call Execute(GdipSetPixelOffsetMode(lngGraphics, _
            PixelOffset))
        
        Call Execute(GdipSetCompositingQuality(lngGraphics, _
            CompositingQuality))
            
        Call Execute(GdipSetCompositingMode(lngGraphics, _
            CompositingMode))
        
        ' Öffnet die Bilddatei in lBitmap
        retStatus = Execute(GdipLoadImageFromFile(StrPtr(FileName), _
            lBitmap))
        
        If retStatus = OK Then
            
            ' Ermitteln der ImageDimensionen
            Call Execute(GdipGetImageDimension(lBitmap, ImageWidth, _
                ImageHeight))
                
            IW = (ImageWidth * Percent) \ 100
            IH = (ImageHeight * Percent) \ 100
            
            ' Image erzeugen
            retStatus = Execute(GdipDrawImageRect(lngGraphics, lBitmap, _
                                                  0, 0, IW, IH))
            
            ' Lösche lBitmap
            Call Execute(GdipDisposeImage(lBitmap))
            
        End If
        ' Lösche das Grafikobjekt
        Call Execute(GdipDeleteGraphics(lngGraphics))
    End If
End Function

Private Sub cmdLoadPicture_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
   
        Picture1(0).Picture = LoadPicture("")
        Picture1(1).Picture = LoadPicture("")
        Picture1(2).Picture = LoadPicture("")
        Picture1(3).Picture = LoadPicture("")

        Call DrawImageFromFile(CommonDialog1.FileName, _
            Picture1(0).hdc, 100)
            
        Call DrawImageFromFile(CommonDialog1.FileName, Picture1(1).hdc, _
            400, InterpolationModeHighQualityBicubic, SmoothingModeNone)
        
        Call DrawImageFromFile(CommonDialog1.FileName, Picture1(2).hdc, _
            400, , SmoothingModeAntiAlias)
        
        Call DrawImageFromFile(CommonDialog1.FileName, Picture1(3).hdc, _
            400, InterpolationModeNearestNeighbor)
            
        Picture1(0).Picture = Picture1(0).image
        Picture1(1).Picture = Picture1(1).image
        Picture1(2).Picture = Picture1(2).image
        Picture1(3).Picture = Picture1(3).image
    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
    
End Sub

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

    If GdipInitialized = True Then
        retStatus = Execute(ShutdownGDIPlus)
    End If
End Sub
'--- Ende Formular "frmGDIPlusDrawImage" alias frmGDIPlusDrawImage.frm  ---
'---------- Ende Projektdatei GDIPlusDrawImage.vbp ----------