001
20.05.2006, 21:04 Uhr
Audron-AT-www
http://www.sXene.de Audron@sxene.de
(Operator)
|
Mit GDI+ ist es möglich JPEG-Grafiken verlustfrei zu drehen.
Hierfür sind jedoch nur bestimmte Winkel zugelassen. Zusätzlich kann die Grafik ebenfalls verlustfrei an den Achsen gespiegelt werden.
| Visual Basic: |
'Dieser Source stammt von 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 GDIPlusRotateJPGLoosless.vbp -----
' Die Komponente 'Microsoft Common Dialog Control 6.0 (comdlg32.ocx)'
' wird benötigt.
'--- Anfang Formular "frmGDIPlusRotateJPGLoosless" alias
' frmGDIPlusRotateJPGLoosless.frm ---
' Steuerelement: Listen-Steuerelement "List1"
' Steuerelement: Schaltfläche "cmdSaveAsRotatedJpg"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "cmdLoadPicture"
Option Explicit
' ----==== GDIPlus Const ====----
Private Const GdiPlusVersion As Long = 1
Private Const mimeJPG As String = "image/jpeg"
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const EncoderTransformation As String = _
"{8D0EB2D1-A58E-4EA8-AA14-108074B7B6F9}"
' ----==== 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
Private Type GUID
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
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 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
' ----==== 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 EncoderValueConstants
EncoderValueColorTypeCMYK = 0
EncoderValueColorTypeYCCK = 1
EncoderValueCompressionLZW = 2
EncoderValueCompressionCCITT3 = 3
EncoderValueCompressionCCITT4 = 4
EncoderValueCompressionRle = 5
EncoderValueCompressionNone = 6
EncoderValueScanMethodInterlaced = 7
EncoderValueScanMethodNonInterlaced = 8
EncoderValueVersionGif87 = 9
EncoderValueVersionGif89 = 10
EncoderValueRenderProgressive = 11
EncoderValueRenderNonProgressive = 12
EncoderValueTransformRotate90 = 13
EncoderValueTransformRotate180 = 14
EncoderValueTransformRotate270 = 15
EncoderValueTransformFlipHorizontal = 16
EncoderValueTransformFlipVertical = 17
EncoderValueMultiFrame = 18
EncoderValueLastFrame = 19
EncoderValueFlush = 20
EncoderValueFrameDimensionTime = 21
EncoderValueFrameDimensionResolution = 22
EncoderValueFrameDimensionPage = 23
End Enum
' ----==== Sonstige Enums ====----
Public Enum JpgTransformType
JpgTransformRotate90 = _
EncoderValueConstants.EncoderValueTransformRotate90
JpgTransformRotate180 = _
EncoderValueConstants.EncoderValueTransformRotate180
JpgTransformRotate270 = _
EncoderValueConstants.EncoderValueTransformRotate270
JpgTransformFlipHorizontal = _
EncoderValueConstants.EncoderValueTransformFlipHorizontal
JpgTransformFlipVertical = _
EncoderValueConstants.EncoderValueTransformFlipVertical
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 GdipLoadImageFromFile Lib "gdiplus" _
(ByVal FileName As Long, ByRef image As Long) 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
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal Bitmap As Long, ByRef hbmReturn As Long, _
ByVal background As Long) As Status
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" _
(ByRef numEncoders As Long, ByRef Size As Long) 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 GdipDisposeImage Lib "gdiplus" _
(ByVal image As Long) As Status
' ----==== OLE API Declarations ====----
Private Declare Function CLSIDFromString Lib "ole32" _
(ByVal str As Long, id As GUID) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" _
(lpPictDesc As PICTDESC, riid As IID, _
ByVal fOwn As Boolean, lplpvObj As Object)
' ----==== Kernel API Declarations ====----
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 InJpgFileName As String
Private InJpgFileTitle As String
'------------------------------------------------------
' 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 : RotateJPGLossless
' Beschreibung : Verlustfreies Rotieren von JPG´s per GDI+
' Übergabewert : InFileName = Pfad\Dateiname.jpg
' OutFileName = Pfad\Dateiname.jpg
' JpgTransform = Rotationstyp
' Rückgabewert : True = rotation erfolgreich
' False = rotation fehlgeschlagen
'------------------------------------------------------
Private Function RotateJPGLossless(ByVal InFilename As String, _
ByVal OutFilename As String, _
ByVal JpgTransform As JpgTransformType) As Boolean
Dim retStatus As Long
Dim lBitmap As Long
Dim retVal As Boolean
retStatus = Execute(GdipLoadImageFromFile(StrPtr(InFilename), _
lBitmap))
If retStatus = OK Then
Dim PicEncoder As GUID
Dim tParams As EncoderParameters
'// Ermitteln der CLSID vom mimeType Encoder
retVal = GetEncoderClsid(mimeJPG, PicEncoder)
If retVal = True Then
' Initialisieren der Encoderparameter
tParams.Count = 1
With tParams.Parameter(0) ' Transformation
' Setzen der Transformations GUID
CLSIDFromString StrPtr(EncoderTransformation), .GUID
.NumberOfValues = 1
.Type = EncoderParameterValueTypeLong
.Value = VarPtr(JpgTransform)
End With
' Speichert lBitmap als JPG
retStatus = Execute(GdipSaveImageToFile(lBitmap, _
StrPtr(OutFilename), PicEncoder, tParams))
If retStatus = OK Then
RotateJPGLossless = True
Else
RotateJPGLossless = False
End If
Else
RotateJPGLossless = False
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
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
'------------------------------------------------------
' 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
GetEncoderClsid = False '// fehlgeschlagen
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
GetEncoderClsid = True '// erfolgreich
Exit Function
End If
Next j
Erase pImageCodecInfo
GetEncoderClsid = False '// fehlgeschlagen
End Function
Private Sub cmdLoadPicture_Click()
On Error Goto errorhandler
If GdipInitialized = True Then
With CommonDialog1
.Filter = "JPG Files (*.jpg)|*.jpg"
.CancelError = True
.ShowOpen
End With
Picture1.Picture = LoadPicturePlus(CommonDialog1.FileName)
InJpgFileName = CommonDialog1.FileName
InJpgFileTitle = CommonDialog1.FileTitle
If Not Picture1.Picture Is Nothing Then _
cmdSaveAsRotatedJpg.Enabled = True
End If
Exit Sub
errorhandler:
End Sub
Private Sub cmdSaveAsRotatedJpg_Click()
If GdipInitialized = True Then
Dim retVal As Boolean
Dim Transform As JpgTransformType
Dim TransformFileName As String
Select Case List1.List(List1.ListIndex)
Case "JpgTransformRotate90"
Transform = JpgTransformRotate90
Case "JpgTransformRotate180"
Transform = JpgTransformRotate180
Case "JpgTransformRotate270"
Transform = JpgTransformRotate270
Case "JpgTransformFlipHorizontal"
Transform = JpgTransformFlipHorizontal
Case "JpgTransformFlipVertical"
Transform = JpgTransformFlipVertical
End Select
'temporären Dateinamen erstellen
TransformFileName = Mid$(InJpgFileName, 1, Len(InJpgFileName) - _
Len(InJpgFileTitle)) & "_" & InJpgFileTitle
' JPG transformieren
retVal = RotateJPGLossless(InJpgFileName, TransformFileName, _
Transform)
If retVal = True Then
'lösche Originaldatei
Kill InJpgFileName
'temporäre Datei in Original umbenennen
Name TransformFileName As InJpgFileName
'Datei wieder laden und anzeigen
Picture1.Picture = LoadPicturePlus(InJpgFileName)
Else
MsgBox "Das rotieren der JPG ist fehlgeschlagen.", _
vbOKOnly, "Error"
End If
End If
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
cmdSaveAsRotatedJpg.Enabled = False
List1.AddItem "JpgTransformRotate90"
List1.AddItem "JpgTransformRotate180"
List1.AddItem "JpgTransformRotate270"
List1.AddItem "JpgTransformFlipHorizontal"
List1.AddItem "JpgTransformFlipVertical"
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 "frmGDIPlusRotateJPGLoosless" alias
' frmGDIPlusRotateJPGLoosless.frm ---
'------ Ende Projektdatei GDIPlusRotateJPGLoosless.vbp ------
|
(von www.ActiveVB.de)
--
Mit freundlichen Grüßen
Audron, audron@sxene.de
|
