| Private Function ConvertTo1bppIndexedAndSaveAsTiffGDI6( _
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 ePixelFormat As PixelFormats
Dim tEncoderParameters As EncoderParameters
Dim tCPal() As ColorPalette
' Palette für 1bppIndexed dimensionieren
ReDim tCPal(0 To 1)
' Anzahl der Farben setzen
tCPal(0).Count = UBound(tCPal) + 1
' 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
' PixelFormat von lInBitmap ermitteln
If Execute(GdipGetImagePixelFormat(lInBitmap, ePixelFormat)) = ok Then
' kopie von lInBitmap erstellen
' -> lNewBitmap
If Execute(GdipCloneBitmapArea(0, 0, sWidth, sHeight, ePixelFormat, _
lInBitmap, lNewBitmap)) = ok Then
' optimierte 1bppIndexed Palette
' für lNewBitmap erzeugen
If Execute(GdipInitializePalette( _
VarPtr(tCPal(0)), PaletteTypeOptimal, _
tCPal(0).Count, CLng(Abs(False)), _
lNewBitmap)) = ok Then
' lNewBitmap zu 1bppIndexed Bitmap mit
' erzeugter Palette konvertieren
If Execute(GdipBitmapConvertFormat( _
lNewBitmap, PixelFormat1bppIndexed, _
DitherTypeDualSpiral8x8, _
PaletteTypeOptimal, _
VarPtr(tCPal(0)), 0)) = ok Then
' Speichert lNewBitmap als
' 1bppIndexed Tiff mit
' optimierter Palette
ConvertTo1bppIndexedAndSaveAsTiffGDI6 = _
Execute(GdipSaveImageToFile( _
lNewBitmap, StrPtr(sFileName), _
tPicEncoder, tEncoderParameters))
End If
End If
' Lösche lNewBitmap
Call Execute(GdipDisposeImage(lNewBitmap))
End If
End If
End If
Else
' speichern nicht erfolgreich
ConvertTo1bppIndexedAndSaveAsTiffGDI6 = Aborted
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
End If
End Function
Private Function SaveAsTiff(ByVal sFileName As String, _
ByVal lInBitmap As Long, _
Optional ByVal eTifCompression As EncoderValueConstants _
= EncoderValueCompressionNone) As Status
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
' Speichert lInBitmap als Tiff
SaveAsTiff = Execute(GdipSaveImageToFile(lInBitmap, _
StrPtr(sFileName), tPicEncoder, _
tEncoderParameters))
Else
' speichern nicht erfolgreich
SaveAsTiff = Aborted
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
End If
End Function
Public Function SavePictureAsTiff(ByVal Pic As StdPicture, _
ByVal sFileName As String, _
Optional ByVal eTifCompression As EncoderValueConstants _
= EncoderValueCompressionNone) As Boolean
Dim lRet As Status
Dim lBitmap As Long
' Erzeugt eine GDI+ Bitmap vom
' StdPicture Handle -> lBitmap
If Execute(GdipCreateBitmapFromHBITMAP( _
Pic.Handle, 0, lBitmap)) = ok Then
' Kompressionstyp
Select Case eTifCompression
Case EncoderValueCompressionNone, _
EncoderValueCompressionLZW
lRet = SaveAsTiff( _
sFileName, lBitmap, eTifCompression)
Case Else 'RLE, CCITT3, CCITT4
' für die Komprimierungsmodi RLE, CCITT3, CCITT4
' muss die Bitmap in ein 1bppIndexed Bitmap
' konvertiert werden
' wird GDI+ v6.xx verwendet
If UseGDI6 Then
' !!! ab GDI+ Version 6.xx und höher !!!
lRet = ConvertTo1bppIndexedAndSaveAsTiffGDI6( _
sFileName, lBitmap, eTifCompression)
Else
' oder GDI+ v5.xx
' !!! ab GDI+ Version 5.xx und höher !!!
lRet = ConvertTo1bppIndexedAndSaveAsTiffGDI5( _
sFileName, lBitmap, eTifCompression)
End If
End Select
If lRet = ok Then
' speichern erfolgreich
SavePictureAsTiff = True
Else
' speichern nicht erfolgreich
SavePictureAsTiff = False
End If
' Lösche lBitmap
Call Execute(GdipDisposeImage(lBitmap))
End If
End Function
Public Function SavePictureAsJPG(ByVal Pic As StdPicture, _
ByVal FileName As String, Optional ByVal Quality As Long = 85) _
As Boolean
Dim retStatus As Status
Dim retVal As Boolean
Dim lBitmap As Long
' Erzeugt eine GDI+ Bitmap vom StdPicture Handle -> lBitmap
retStatus = Execute(GdipCreateBitmapFromHBITMAP(Pic.Handle, 0, _
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
If Quality > 100 Then Quality = 100
If Quality < 0 Then Quality = 0
' Initialisieren der Encoderparameter
tParams.Count = 1
With tParams.Parameter(0) ' Quality
' Setzen der Quality GUID
CLSIDFromString StrPtr(EncoderQuality), .GUID
.NumberOfValues = 1
.type = EncoderParameterValueTypeLong
.Value = VarPtr(Quality)
End With
' Speichert lBitmap als JPG
retStatus = Execute(GdipSaveImageToFile(lBitmap, _
StrPtr(FileName), PicEncoder, tParams))
If retStatus = ok Then
SavePictureAsJPG = True
Else
SavePictureAsJPG = False
End If
Else
SavePictureAsJPG = False
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
End If
' Lösche lBitmap
Call Execute(GdipDisposeImage(lBitmap))
End If
End Function
Public Function SavePictureAsPNG(ByVal Pic As StdPicture, _
ByVal sFileName As String) As Boolean
Dim lBitmap As Long
Dim tPicEncoder As GUID
' Erzeugt eine GDI+ Bitmap vom
' StdPicture Handle -> lBitmap
If Execute(GdipCreateBitmapFromHBITMAP( _
Pic.Handle, 0, lBitmap)) = ok Then
' Ermitteln der CLSID vom mimeType Encoder
If GetEncoderClsid(mimePNG, tPicEncoder) = True Then
' Speichert lBitmap als PNG
If Execute(GdipSaveImageToFile(lBitmap, _
StrPtr(sFileName), tPicEncoder, ByVal 0)) = ok Then
' speichern erfolgreich
SavePictureAsPNG = True
Else
' speichern nicht erfolgreich
SavePictureAsPNG = False
End If
Else
' speichern nicht erfolgreich
SavePictureAsPNG = False
MsgBox "Konnte keinen passenden Encoder ermitteln.", _
vbOKOnly, "Encoder Error"
End If
' Lösche lBitmap
Call Execute(GdipDisposeImage(lBitmap))
End If
End Function
Listo es largo pero vale la pena |