Cjpeg

[Bourne]

' ----==== 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
Private Declare Function GetModuleHandle Lib "kernel32" _
Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" _
(ByVal hModule As Long, ByVal lpProcName As String) As Long

Private Declare Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long
' ----==== Variablen ====----
Private GdipToken As Long
Private GdipInitialized As Boolean
Public UseGDI6 As Boolean


Public 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
Public Function ShutdownGDIPlus() As Status
' Beendet GDI+ Instanz
ShutdownGDIPlus = GdiplusShutdown(GdipToken)
End Function
Public Function Execute(ByVal lReturn As Status) As Status
Dim lCurErr As Status
If lReturn = Status.ok Then
lCurErr = Status.ok
Else
lCurErr = lReturn
MsgBox GdiErrorString(lReturn) & " GDI+ Error:" & lReturn, _
vbOKOnly, "GDI Error"
End If
Execute = lCurErr
End Function

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
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
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 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
Public Function UseGDI_v_6xx() As Boolean

Dim hMod As Long
Dim Loaded As Boolean
Dim sFunction As String
Dim sModule As String

' GDIPLUS.DLL
sModule = "GDIPLUS"

' eine Funktion die erst ab der
' GDI+ 6.xx vorhanden ist
sFunction = "GdipDrawImageFX"

'Handle der DLL erhalten
hMod = GetModuleHandle(sModule)

' Falls DLL nicht registriert ...
If hMod = 0 Then
' DLL in den Speicher laden.
hMod = LoadLibrary(sModule)
If hMod Then Loaded = True
End If

If hMod Then
If GetProcAddress(hMod, sFunction) Then UseGDI_v_6xx = True
End If

If Loaded Then Call FreeLibrary(hMod)

End Function
Private Function ConvertTo1bppIndexedAndSaveAsTiffGDI5( _
ByVal sFileName As String, _
ByVal lInBitmap As Long, _
Optional ByVal eTifCompression As EncoderValueConstants _
= EncoderValueCompressionNone) As Status

Dim lNewBitmap As Long
Dim sWidth As Single
Dim sHeight As Single
Dim tPicEncoder As GUID
Dim tEncoderParameters As EncoderParameters

' Ermitteln der CLSID vom mimeType Encoder
If GetEncoderClsid(mimeTIFF, tPicEncoder) = True Then

' Initialisieren der Encoderparameter
tEncoderParameters.Count = 1
With tEncoderParameters.Parameter(0)
' Setzen der Kompressions GUID
CLSIDFromString StrPtr(EncoderCompression), .GUID
.NumberOfValues = 1
.type = EncoderParameterValueTypeLong
' Kompressionstyp
.Value = VarPtr(eTifCompression)
End With

' Dimensionen von lInBitmap ermitteln
If Execute(GdipGetImageDimension(lInBitmap, sWidth, sHeight)) = ok Then

' 1bppIndexed kopie von lInBitmap
' erstellen -> lNewBitmap
If Execute(GdipCloneBitmapArea( _
0, 0, sWidth, sHeight, _
PixelFormat1bppIndexed, _
lInBitmap, lNewBitmap)) = ok Then

' Speichert lNewBitmap als
' 1bppIndexed Tiff
ConvertTo1bppIndexedAndSaveAsTiffGDI5 = _
Execute(GdipSaveImageToFile( _
lNewBitmap, StrPtr(sFileName), _
tPicEncoder, tEncoderParameters))

' Lösche lNewBitmap
Call Execute(GdipDisposeImage(lNewBitmap))
End If
End If
Else
' speichern nicht erfolgreich
ConvertTo1bppIndexedAndSaveAsTiffGDI5 = Aborted
MsgBox "Konnte keinen passenden Encoder ermitteln.", vbOKOnly, "Encoder Error"
End If
End Function