Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0661: Grafik mittels GDI+ um freien Winkel drehen

VB 5/6-Tipp 0661: Grafik mittels GDI+ um freien Winkel drehen

 von Frank Schüler

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipCreateBitmapFromHBITMAP, GdipCreateFromHDC, GdipDeleteGraphics, GdipDisposeImage, GdipDrawImageRect, GdipGetImageDimension, GdipResetWorldTransform, GdipRotateWorldTransform, GdipTranslateWorldTransform, GdiplusShutdown, GdiplusStartup

Download: Download des Beispielprojektes [16,05 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 GDIPlusRotateAngleImage.vbp  -----
'--- Anfang Formular "frmGDIPlusRotateAngleImage" alias frmGDIPlusRotateAngleImage.frm  ---
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

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

' ----==== 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 MatrixOrder
    MatrixOrderPrepend = 0
    MatrixOrderAppend = 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 GdipGetImageDimension Lib "gdiplus" _
    (ByVal image As Long, ByRef Width As Single, _
    ByRef Height As Single) As Status

Private Declare Function GdipRotateWorldTransform Lib "gdiplus" _
    (ByVal graphics As Long, ByVal angle As Single, _
    ByVal order As MatrixOrder) As Status

Private Declare Function GdipTranslateWorldTransform Lib "gdiplus" _
    (ByVal graphics As Long, ByVal dx As Single, ByVal dy As Single, _
    ByVal order As MatrixOrder) As Status

Private Declare Function GdipResetWorldTransform 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 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 GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
    (ByVal hbm As Long, ByVal hpal As Long, _
    ByRef Bitmap As Long) As Status

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

' ----==== Variablen ====----
Private GdipToken As Long
Private 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 NotTrueTypeFont:           s = "Not TrueType Font."
    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

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

Private Sub Picture1_Click()
    
    Dim retStatus As Long
    Dim lBitmap As Long
    Dim lngGraphics As Long
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim sngAngle As Single
    
    Static running As Boolean
    If running Then Exit Sub
    
    running = True
    
    If GdipInitialized = True Then
        
        retStatus = Execute(GdipCreateFromHDC(Picture1.hdc, lngGraphics))
        
        If retStatus = OK Then
            
            retStatus = Execute(GdipCreateBitmapFromHBITMAP( _
            Picture1.Picture.Handle, 0, lBitmap))
            
            If retStatus = OK Then
                
                Call Execute(GdipGetImageDimension(lBitmap, sngWidth, _
                    sngHeight))
                
                For sngAngle = 180 To 540
                    Call Execute(GdipRotateWorldTransform(lngGraphics, _
                    sngAngle, MatrixOrderPrepend))
                    
                    Call Execute(GdipTranslateWorldTransform(lngGraphics, _
                    sngWidth \ 2, sngHeight \ 2, MatrixOrderAppend))
                    
                    Call Execute(GdipDrawImageRect(lngGraphics, lBitmap, _
                    sngWidth \ 2, sngHeight \ 2, -sngWidth, -sngHeight))
                    
                    Call Execute(GdipResetWorldTransform(lngGraphics))
                    
                    DoEvents
                Next sngAngle
                
                ' Destroy the bitmap
                Call Execute(GdipDisposeImage(lBitmap))
                
            End If
            
            Call Execute(GdipDeleteGraphics(lngGraphics))
            
        End If
        
    End If
    
    running = False
End Sub
'--- Ende Formular "frmGDIPlusRotateAngleImage" alias frmGDIPlusRotateAngleImage.frm  ---
'------ Ende Projektdatei GDIPlusRotateAngleImage.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.