Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0676: DPI eines Bildes mit GDI+ auslesen und setzen

VB 5/6-Tipp 0676: DPI eines Bildes mit GDI+ auslesen und setzen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipBitmapSetResolution, GdipCreateBitmapFromFile, GdipCreateBitmapFromHBITMAP, GdipCreateFromHDC, GdipCreateHBITMAPFromBitmap, GdipDeleteGraphics, GdipDisposeImage, GdipGetDpiX, GdipGetDpiY, GdipGetImageEncoders, GdipGetImageEncodersSize, GdipGetImageHorizontalResolution, GdipGetImageVerticalResolution, GdipSaveImageToFile, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect, lstrcpyW, lstrlenW

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

'--- Anfang Formular "frmGDIPlusGetSetResolution" alias frmGDIPlusGetSetResolution.frm  ---
' Steuerelement: Rahmensteuerelement "fmDPI" (Index von 0 bis 1)
' Steuerelement: Beschriftungsfeld "lblDpiY" auf fmDPI
' Steuerelement: Beschriftungsfeld "lblDpiX" auf fmDPI
' Steuerelement: Beschriftungsfeld "lblGraphicsDpiY" auf fmDPI
' Steuerelement: Beschriftungsfeld "lblGraphicsDpiX" auf fmDPI
' Steuerelement: Kontrollkästchen-Steuerelement "ckDPI"
' Steuerelement: Schaltfläche "cmdSavePicture"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Bildfeld-Steuerelement "picOrg"
' Steuerelement: Schaltfläche "cmdLoadPicture"

Option Explicit

' ----==== GDI+ Konstanten ====----
Private Const GdiPlusVersion As Long = 1&
Private Const mimeJPG As String = "image/jpeg"

' ----==== Sonstige Typen ====----
Private Type DpiXY
    sngDpiX As Single
    sngDpiY As Single
End Type

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

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

Private Type PICTDESC
    cbSizeOfStruct As Long
    picType As Long
    hgdiObj As Long
    hPalOrXYExt As Long
End Type

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

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

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

' ----==== GDI+ API Deklarationen ====----
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" _
    (ByVal bitmap As Long, ByVal xDPI As Single, _
    ByVal yDPI As Single) As Status

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

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
    (ByVal hbm As Long, ByVal hpal As Long, _
    ByRef bitmap As Long) As Status

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

Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
    (ByVal bitmap As Long, ByRef hbmReturn As Long, _
    ByVal background As Long) As Status

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

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

Private Declare Function GdipGetDpiX Lib "gdiplus" _
    (ByVal graphics As Long, ByRef xDPI As Single) As Status

Private Declare Function GdipGetDpiY Lib "gdiplus" _
    (ByVal graphics As Long, ByRef yDPI As Single) 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 GdipGetImageEncodersSize Lib "gdiplus" _
    (ByRef numEncoders As Long, ByRef Size As Long) As Status

Private Declare Function GdipGetImageHorizontalResolution _
    Lib "gdiplus" (ByVal image As Long, _
    ByRef HorizontalResolution As Single) As Status

Private Declare Function GdipGetImageVerticalResolution _
    Lib "gdiplus" (ByVal image As Long, _
    ByRef VerticalResolution As Single) 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

' ----==== OLEOUT32 API Deklarationen ====----
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _
    (lpPictDesc As PICTDESC, riid As IID, _
    ByVal fOwn As Boolean, lplpvObj As Object)

' ----==== Kernel API Deklarationen ====----
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 sDpiX As Single
Private sDpiY As Single

'------------------------------------------------------
' 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 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     : 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
        ' fehlgeschlagen
        GetEncoderClsid = False
        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
            ' erfolgreich
            GetEncoderClsid = True
            Exit Function
        End If
    Next j
    
    Erase pImageCodecInfo
    
    ' fehlgeschlagen
    GetEncoderClsid = False
End Function

'------------------------------------------------------
' Funktion     : HandleToPicture
' Beschreibung : Umwandeln eines Bitmap Handle in
'                ein StdPicture Objekt
' Übergabewert : hGDIHandle = Bitmap Handle
'                ObjectType = Bitmaptyp
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function HandleToPicture(ByVal hGDIHandle As Long, _
ByVal ObjectType As PictureTypeConstants, _
Optional ByVal hpal As Long = 0) As StdPicture
    
    Dim tPictDesc As PICTDESC
    Dim IID_IPicture As IID
    Dim oPicture As IPicture
    
    ' Initialisiert die PICTDESC Structur
    With tPictDesc
        .cbSizeOfStruct = Len(tPictDesc)
        .picType = ObjectType
        .hgdiObj = hGDIHandle
        .hPalOrXYExt = hpal
    End With
    
    ' Initialisiert das IPicture Interface ID
    With IID_IPicture
        .Data1 = &H7BF80981
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(3) = &HAA
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    ' Erzeugen des Objekts
    OleCreatePictureIndirect tPictDesc, _
    IID_IPicture, True, oPicture
    
    ' Rückgabe des Pictureobjekts
    Set HandleToPicture = oPicture
    
End Function

'------------------------------------------------------
' Funktion     : LoadPicturePlus
' Beschreibung : Lädt ein Bilddatei per GDI+
' Übergabewert : Pfad\Dateiname der Bilddatei
' Rückgabewert : StdPicture Objekt
'------------------------------------------------------
Private Function LoadPicturePlus( _
ByVal sFileName As String) As StdPicture
    
    Dim lBitmap As Long
    Dim hBitmap As Long
    
    ' Laden der Bilddatei -> lBitmap
    If Execute(GdipCreateBitmapFromFile(StrPtr(sFileName), _
    lBitmap)) = OK Then
        
        ' Auslesen der DPI vom lBitmap
        Call Execute(GdipGetImageHorizontalResolution(lBitmap, sDpiX))
        Call Execute(GdipGetImageVerticalResolution(lBitmap, sDpiY))
        
        ' Handle von lBitmap -> hBitmap
        If Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _
        hBitmap, 0)) = OK Then
            
            ' Erzeugen des StdPicture Objekts von hBitmap
            Set LoadPicturePlus = HandleToPicture(hBitmap, _
            vbPicTypeBitmap)
            
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
    End If
End Function

'------------------------------------------------------
' Funktion     : SavePicturePlus
' Beschreibung : speichert ein Picture als Datei
' Übergabewert : Pfad\Dateiname.jpg der Bilddatei
'                WithDPI = True  / False
' Rückgabewert : True = speichern erfolgreich
'                False = speichern fehlgeschlagen
'------------------------------------------------------
Private Function SavePicturePlus(ByVal oPic As StdPicture, _
ByVal sFileName As String, ByVal bWithDPI As Boolean) As Boolean
    
    Dim lBitmap As Long
    Dim PicEncoder As GUID
    Dim retStatus As Status
    
    ' GDI+ Bitmapobjekt vom Handle erstellen -> lBitmap
    If Execute(GdipCreateBitmapFromHBITMAP(oPic.Handle, _
    0, lBitmap)) = OK Then
        
        ' DPI für lBitmap setzen
        If bWithDPI = True Then _
        Call Execute(GdipBitmapSetResolution(lBitmap, sDpiX, sDpiY))
        
        ' Ermitteln der CLSID vom mimeType Encoder
        If GetEncoderClsid(mimeJPG, PicEncoder) = True Then
            
            ' speichern von lBitmap mit Standardparametern
            retStatus = Execute(GdipSaveImageToFile(lBitmap, _
            StrPtr(sFileName), PicEncoder, ByVal 0))
            
            If retStatus = OK Then
                SavePicturePlus = True
            Else
                SavePicturePlus = False
            End If
            
        Else
            SavePicturePlus = False
            MsgBox "Konnte keinen passenden Encoder ermitteln.", _
            vbOKOnly, "Encoder Error"
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
    End If
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     : GetPictureBoxDPI
' Beschreibung : DPI einer PictureBox ermitteln
' Übergabewert : CtrlPictureBox = PictureBox
' Rückgabewert : Type DpiXY
'------------------------------------------------------
Private Function GetPictureBoxDPI( _
    ByVal CtrlPictureBox As PictureBox) As DpiXY
    
    Dim lGraphics As Long
    Dim tDpiXY As DpiXY
    
    ' Graphicsobjekt vom HDC erstellen -> lGraphics
    If Execute(GdipCreateFromHDC(CtrlPictureBox.hdc, _
    lGraphics)) = OK Then
        
        ' Auslesen der DPI von lGraphics
        Call Execute(GdipGetDpiX(lGraphics, tDpiXY.sngDpiX))
        Call Execute(GdipGetDpiX(lGraphics, tDpiXY.sngDpiY))
        
        ' Graphicsobjekt löschen
        Call Execute(GdipDeleteGraphics(lGraphics))
    End If
    
    ' Rückgabewert übergeben
    GetPictureBoxDPI = tDpiXY
End Function

Private Sub cmdLoadPicture_Click()
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Dialogparameter setzen
        With CommonDialog1
            .Filter = "JPEG Files (*.JPG;*.JPEG;*.JPE;*.JFIF)" & _
            "|*.JPG;*.JPEG;*.JPE;*.JFIF"
            .CancelError = True
            .ShowOpen
        End With
        
        ' Bild laden
        picOrg.Picture = LoadPicturePlus(CommonDialog1.FileName)

        ' ist ein Bild vorhanden
        If Not picOrg.Picture = Empty Then
            
            ' Button aktivieren
            cmdSavePicture.Enabled = True
            
            ' DPI des geladenen Bildes anzeigen
            lblDpiX.Caption = "DpiX = " & CStr(Round(sDpiX, 0))
            lblDpiY.Caption = "DpiY = " & CStr(Round(sDpiY, 0))
        End If
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub cmdSavePicture_Click()
    
    ' Fehlerbehandlung
    On Error Goto errorhandler
    
    ' ist GDI+ initialisiert
    If GdipInitialized = True Then
        
        ' Dialogparameter setzen
        With CommonDialog1
            .Filter = "All Files (*.JPG|*.JPG"
            .FileName = "*.jpg"
            .Flags = cdlOFNOverwritePrompt
            .CancelError = True
            .ShowSave
        End With
        
        ' In diesem Beispiel wird das geladene Bild als JPEG
        ' mit Standardparametern abgespeichert.
        ' Es können auch andere GDI+ MimeTypes
        ' zum speichern verwendet werden.
        
        ' speichern des Bildes aus der PictureBox als JPEG
        ' mit Standardparametern
        If SavePicturePlus(picOrg.Picture, _
        CommonDialog1.FileName, _
        CBool(ckDPI.Value * -1)) = False Then
             MsgBox "Das speichern ist fehlgeschlagen.", _
             vbOKOnly, "Speichern"
        End If
    End If
    
    Exit Sub
errorhandler:
End Sub

Private Sub Form_Load()
    
    Dim tDpiXY As DpiXY
    GdipInitialized = False
    
    ' Button deaktivieren
    cmdSavePicture.Enabled = False
    
    ' GDI+ initialisieren
    If Execute(StartUpGDIPlus(GdiPlusVersion)) = OK Then
        GdipInitialized = True
        
        ' DPI der PictureBox ermitteln
        tDpiXY = GetPictureBoxDPI(picOrg)
        
        ' DPI der PictureBox anzeigen
        lblGraphicsDpiX.Caption = "DpiX = " & _
        CStr(Round(tDpiXY.sngDpiX, 0))
        
        lblGraphicsDpiY.Caption = "DpiY = " & _
        CStr(Round(tDpiXY.sngDpiY, 0))
        
    Else
        ' Initialisierung 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+ beenden
        Call Execute(ShutdownGDIPlus)
    End If
End Sub
'--- Ende Formular "frmGDIPlusGetSetResolution" alias frmGDIPlusGetSetResolution.frm  ---
'------ Ende Projektdatei GDIPlusGetSetResolution.vbp  ------