VB 5/6-Tipp 0659: Grafik mittels GDI+ drehen und spiegeln
von Frank Schüler
Beschreibung
Dieser Tipp zeigt wie man unter Verwendung von GDI+ Grafiken um feste Winkel drehen kann bzw. auch wahlweise auch an einer oder beiden Achsen spiegeln kann.
Schwierigkeitsgrad: | Verwendete API-Aufrufe: GdipCreateBitmapFromFile, GdipCreateBitmapFromHBITMAP, GdipCreateHBITMAPFromBitmap, GdipDisposeImage, GdipImageRotateFlip, GdiplusShutdown, GdiplusStartup, OleCreatePictureIndirect | Download: |
'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 GDIPlusFliprotateImage.vbp ------ ' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (comdlg32.ocx)' wird benötigt. '--- Anfang Formular "frmGDIPlusFliprotateImage" alias frmGDIPlusFliprotateImage.frm --- ' Steuerelement: Listen-Steuerelement "List1" ' Steuerelement: Schaltfläche "cmdFlipRotate" ' Steuerelement: Bildfeld-Steuerelement "Picture1" ' Steuerelement: Standarddialog-Steuerelement "CommonDialog1" ' Steuerelement: Schaltfläche "cmdLoadPicture" '------------------------------------------------------ ' Benötigt : CommonDialog = CommonDialog1 ' PictureBox = Picture1 ' CommandButton = cmdLoadPicture ' CommandButton = cmdFlipRotate ' ListBox = List1 '------------------------------------------------------ Option Explicit ' ----==== GDIPlus Const ====---- Private Const GdiPlusVersion As Long = 1 ' ----==== Sonstige Types ====---- Private Type PICTDESC cbSizeOfStruct As Long picType As Long hgdiObj As Long hPalOrXYExt As Long End Type Private Type IID 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 ' ----==== 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 RotateFlipType RotateNoneFlipNone = 0 Rotate90FlipNone = 1 Rotate180FlipNone = 2 Rotate270FlipNone = 3 RotateNoneFlipX = 4 Rotate90FlipX = 5 Rotate180FlipX = 6 Rotate270FlipX = 7 RotateNoneFlipY = Rotate180FlipX Rotate90FlipY = Rotate270FlipX Rotate180FlipY = RotateNoneFlipX Rotate270FlipY = Rotate90FlipX RotateNoneFlipXY = Rotate180FlipNone Rotate90FlipXY = Rotate270FlipNone Rotate180FlipXY = RotateNoneFlipNone Rotate270FlipXY = Rotate90FlipNone 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 GdipCreateBitmapFromFile Lib "gdiplus" _ (ByVal FileName As Long, ByRef Bitmap 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 GdipCreateBitmapFromHBITMAP Lib "gdiplus" _ (ByVal hbm As Long, ByVal hpal As Long, ByRef Bitmap As Long) As Status Private Declare Function GdipImageRotateFlip Lib "gdiplus" _ (ByVal image As Long, ByVal rfType As RotateFlipType) As Status Private Declare Function GdipDisposeImage Lib "gdiplus" _ (ByVal image As Long) As Status ' ----==== OLE API Declarations ====---- Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _ (lpPictDesc As PICTDESC, riid As IID, ByVal fOwn As Boolean, _ lplpvObj As Object) ' ----==== 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 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 : LoadPicturePlus ' Beschreibung : Lädt ein Bilddatei per GDI+ ' Übergabewert : Pfad\Dateiname der Bilddatei ' Rückgabewert : StdPicture Objekt '------------------------------------------------------ Public Function LoadPicturePlus(ByVal FileName As String) As StdPicture Dim retStatus As Status Dim lBitmap As Long Dim hBitmap As Long ' Öffnet die Bilddatei in lBitmap retStatus = Execute(GdipCreateBitmapFromFile(StrPtr(FileName), _ lBitmap)) If retStatus = OK Then ' Erzeugen einer GDI Bitmap lBitmap -> hBitmap retStatus = Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _ hBitmap, 0)) If retStatus = 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 : FlipRotatePicture ' Beschreibung : Drehen von Bildern per GDI+ ' Übergabewert : Pic = StdPicture ' FlipRotate = RotateFlipType ' Rückgabewert : StdPicture Objekt '------------------------------------------------------ Private Function FlipRotatePicture(ByVal Pic As StdPicture, _ Optional ByVal FlipRotate As RotateFlipType = _ RotateNoneFlipNone) As StdPicture Dim retStatus As Status Dim lBitmap As Long Dim hBitmap As Long ' Erzeuge ein GDI+ Bitmap vom Image Handle retStatus = Execute(GdipCreateBitmapFromHBITMAP(Pic.Handle, 0, lBitmap)) If retStatus = OK Then ' FlipRotate retStatus = Execute(GdipImageRotateFlip(lBitmap, FlipRotate)) If retStatus = OK Then ' Erzeugen der GDI bitmap retStatus = Execute(GdipCreateHBITMAPFromBitmap(lBitmap, _ hBitmap, 0)) If retStatus = OK Then ' Erzeugen des StdPicture Objekts Set FlipRotatePicture = HandleToPicture(hBitmap, _ vbPicTypeBitmap) End If End If ' Lösche lBitmap Call Execute(GdipDisposeImage(lBitmap)) End If End Function '------------------------------------------------------ ' Funktion : HandleToPicture ' Beschreibung : Umwandeln einer GDI+ Bitmap Handle in ein StdPicture Objekt ' Übergabewert : hGDIHandle = GDI+ 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 Private Sub cmdFlipRotate_Click() If GdipInitialized = True Then Dim RotateFlip As RotateFlipType Select Case List1.List(List1.ListIndex) Case "RotateNoneFlipNone" RotateFlip = RotateNoneFlipNone Case "Rotate90FlipNone" RotateFlip = Rotate90FlipNone Case "Rotate180FlipNone" RotateFlip = Rotate180FlipNone Case "Rotate270FlipNone" RotateFlip = Rotate270FlipNone Case "RotateNoneFlipX" RotateFlip = RotateNoneFlipX Case "Rotate90FlipX" RotateFlip = Rotate90FlipX Case "Rotate180FlipX" RotateFlip = Rotate180FlipX Case "Rotate270FlipX" RotateFlip = Rotate270FlipX Case "RotateNoneFlipY" RotateFlip = RotateNoneFlipY Case "Rotate90FlipY" RotateFlip = Rotate90FlipY Case "Rotate180FlipY" RotateFlip = Rotate180FlipY Case "Rotate270FlipY" RotateFlip = Rotate270FlipY Case "RotateNoneFlipXY" RotateFlip = RotateNoneFlipXY Case "Rotate90FlipXY" RotateFlip = Rotate90FlipXY Case "Rotate180FlipXY" RotateFlip = Rotate180FlipXY Case "Rotate270FlipXY" RotateFlip = Rotate270FlipXY End Select Picture1.Picture = FlipRotatePicture(Picture1, RotateFlip) End If End Sub 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.Picture = LoadPicturePlus(CommonDialog1.FileName) If Not Picture1.Picture Is Nothing Then cmdFlipRotate.Enabled = True 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 cmdFlipRotate.Enabled = False List1.AddItem "RotateNoneFlipNone" List1.AddItem "Rotate90FlipNone" List1.AddItem "Rotate180FlipNone" List1.AddItem "Rotate270FlipNone" List1.AddItem "RotateNoneFlipX" List1.AddItem "Rotate90FlipX" List1.AddItem "Rotate180FlipX" List1.AddItem "Rotate270FlipX" List1.AddItem "RotateNoneFlipY" List1.AddItem "Rotate90FlipY" List1.AddItem "Rotate180FlipY" List1.AddItem "Rotate270FlipY" List1.AddItem "RotateNoneFlipXY" List1.AddItem "Rotate90FlipXY" List1.AddItem "Rotate180FlipXY" List1.AddItem "Rotate270FlipXY" List1.ListIndex = 0 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 "frmGDIPlusFliprotateImage" alias frmGDIPlusFliprotateImage.frm --- '------- Ende Projektdatei GDIPlusFliprotateImage.vbp -------
Tipp-Kompatibilität:
Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
VB4 | |||||||
VB5 | |||||||
VB6 |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.
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.
Kommentar von Pietro Cecchi am 30.05.2005 um 19:56
"Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?"
Ja, es funktionierte sehr gut!
Und dabei: es sheint daß es nicht die Datei schließt!!!
So, danke shön für die Kode!!!
Grüssen von Pietro
Kommentar von Pietro Cecchi am 30.05.2005 um 15:35
I hoffe this code funkzioniert...
Aber hatte eine frage betreffend: wie es moeglich ist UNLOCK eine file, nach die Call GdipLoadImageFromFile (die ungluecklich LOCKS die file)?
Ob Sie eine antwort haben, bitte wiederholen Sie mir bitte.
Danke shoen fuer Euere Freundlichkeit,
Pietro