Wenas. Antes de nada decir que he buscado mucho por el foro, google etc y he leido bastante información pero sigo sin conseguir pasar imagenes de bmp a jpg. Alguien puede explicar paso a paso como llevarlo a cabo y que dll necesitaría. Muchas gracias. Es que he exo un troyano y las capturas de pantalla me las guarda en bmp (3mb) y tarda mucho en transferirmelas a mi pc.
Gracias de nuevo
He buscado la cjpeg.cls dijpeg.dll con ejemplos y todo pero es que no tengo ni idea de como se utilizar para pasar una imagen que sea "c:\captura.bmp" a "c:\captura.jpg"
Si alguien me ayudara le estaría enormente agradecido
Sigo buscando y haciendo pruebas pero no hay manera. Tengo esto parado. Por favor se que algun experto podría ayudarme y creo que no es muy dificil(creo). Por favor quien lo sepa q postee.
Muchas gracias
http://www.vbaccelerator.com/codelib/gfx/savejpeg.zip
http://heliso.tripod.com/programm/jpeg/jpeg.htm
En google tienes muchisimos ejemplos....
Salu2
PD: Si encuentras alguno para convertir a png (codigo no dll) eso si que me interesaria.
Este es un modulo que sirve para leer imágenes Tiff y Png y también poder guardarlas o convertir con los formatos .TIF .PNG .JPG
Este ejemplo trabaja con GDI+ a lo que solo funcionara con Windows XP, excepto que la versión anterior a XP que lo ejecute tenga instalado GDI+
El código para el modulo:
Option Explicit
' ----==== GDIPlus Const ====----
Public Const GdiPlusVersion As Long = 1
Private Const mimeJPG As String = "image/jpeg"
Private Const mimePNG As String = "image/png"
Private Const mimeTIFF As String = "image/tiff"
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const EncoderCompression As String = "{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"
' ----==== 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 GdiplusStartupOutput
NotificationHook As Long
NotificationUnhook 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
' ----==== GDI+ 5.xx und 6.xx Enumerationen ====----
Private Type ARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Type ColorPalette
Flags As PaletteFlags
Count As Long
Entries As ARGB
End Type
Public 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
Private Enum PaletteFlags
PaletteFlagsHasAlpha = &H1
PaletteFlagsGrayScale = &H2
PaletteFlagsHalftone = &H4
End Enum
Private Enum PixelFormats
PixelFormatUndefined = &H0&
PixelFormatDontCare = PixelFormatUndefined
PixelFormatMax = &HF&
PixelFormat1_8 = &H100&
PixelFormat4_8 = &H400&
PixelFormat8_8 = &H800&
PixelFormat16_8 = &H1000&
PixelFormat24_8 = &H1800&
PixelFormat32_8 = &H2000&
PixelFormat48_8 = &H3000&
PixelFormat64_8 = &H4000&
PixelFormat16bppRGB555 = &H21005
PixelFormat16bppRGB565 = &H21006
PixelFormat16bppGrayScale = &H101004
PixelFormat16bppARGB1555 = &H61007
PixelFormat24bppRGB = &H21808
PixelFormat32bppRGB = &H22009
PixelFormat32bppARGB = &H26200A
PixelFormat32bppPARGB = &HD200B
PixelFormat48bppRGB = &H10300C
PixelFormat64bppARGB = &H34400D
PixelFormat64bppPARGB = &H1C400E
PixelFormatGDI = &H20000
PixelFormat1bppIndexed = &H30101
PixelFormat4bppIndexed = &H30402
PixelFormat8bppIndexed = &H30803
PixelFormatAlpha = &H40000
PixelFormatIndexed = &H10000
PixelFormatPAlpha = &H80000
PixelFormatExtended = &H100000
PixelFormatCanonical = &H200000
End Enum
' ----==== Sonstige Enumerationen ====----
Public Enum TifCompressionType
' EncoderValueConstants.EncoderValueCompressionLZW
TiffCompressionLZW = 2
'EncoderValueConstants.EncoderValueCompressionCCITT3
TiffCompressionCCITT3 = 3
'EncoderValueConstants.EncoderValueCompressionCCITT4
TiffCompressionCCITT4 = 4
'EncoderValueConstants.EncoderValueCompressionRle
TiffCompressionRle = 5
'EncoderValueConstants.EncoderValueCompressionNone
TiffCompressionNone = 6
End Enum
' ----==== GDIPlus Enums ====----
Public 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
' ----==== GDI+ 6.xx Enumerationen ====----
Private Enum DitherType
DitherTypeNone = 0
DitherTypeSolid = 1
DitherTypeOrdered4x4 = 2
DitherTypeOrdered8x8 = 3
DitherTypeOrdered16x16 = 4
DitherTypeOrdered91x91 = 5
DitherTypeSpiral4x4 = 6
DitherTypeSpiral8x8 = 7
DitherTypeDualSpiral4x4 = 8
DitherTypeDualSpiral8x8 = 9
DitherTypeErrorDiffusion = 10
End Enum
Private Enum PaletteType
PaletteTypeCustom = 0
PaletteTypeOptimal = 1
PaletteTypeFixedBW = 2
PaletteTypeFixedHalftone8 = 3
PaletteTypeFixedHalftone27 = 4
PaletteTypeFixedHalftone64 = 5
PaletteTypeFixedHalftone125 = 6
PaletteTypeFixedHalftone216 = 7
PaletteTypeFixedHalftone252 = 8
PaletteTypeFixedHalftone256 = 9
End Enum
' ----==== GDI+ 5.xx und 6.xx API Deklarationen ====----
Private Declare Function GdipCloneBitmapArea Lib "gdiplus" _
(ByVal x As Single, ByVal y As Single, ByVal Width As Single, _
ByVal Height As Single, ByVal format As PixelFormats, _
ByVal srcBitmap As Long, ByRef dstBitmap As Long) As Status
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(ByVal FileName As Long, ByRef BITMAP 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 GdipCreateHBITMAPFromBitmap Lib "gdiplus" _
(ByVal BITMAP As Long, ByRef hbmReturn As Long, _
ByVal background As Long) As Status
Private Declare Function GdipDisposeImage Lib "gdiplus" _
(ByVal image 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 GdipGetImageEncodersSize Lib "gdiplus" _
(ByRef numEncoders As Long, ByRef Size As Long) As Status
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" _
(ByVal image As Long, ByRef PixelFormat As PixelFormats) As Status
Private Declare Function GdipGetImageDimension Lib "gdiplus" _
(ByVal image As Long, ByRef sngWidth As Single, _
ByRef sngHeight As Single) As Status
Private Declare Function GdiplusShutdown Lib "gdiplus" _
(ByVal token As Long) As Status
Private Declare Function GdiplusStartup Lib "gdiplus" _
(ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, _
Optional ByRef lpOutput As Any) 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
' ----==== GDI+ 6.xx API Deklarationen ====----
Private Declare Function GdipBitmapConvertFormat Lib "gdiplus" _
(ByVal pInputBitmap As Long, _
ByVal PixelFormat As PixelFormats, _
ByVal DitherType As DitherType, _
ByVal PaletteType As PaletteType, _
ByVal palette As Any, _
ByVal alphaThresholdPercent As Single) As Status
Private Declare Function GdipInitializePalette Lib "gdiplus" _
(ByVal palette As Any, _
ByVal PaletteType As PaletteType, _
ByVal optimalColors As Long, _
ByVal useTransparentColor As Long, _
ByVal BITMAP 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
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
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
Bueno algo extenso no? y para probarlo hacemos lo siguiente agregamos al formulario:
* 2 Commandbutton (Command1 y Command2)
* 1 CommonDialog1
* 1 Picture1
Option Explicit
Private Sub Form_Load()
Dim retStatus As Status
'UseGDI6 = UseGDI_v_6xx
'Muy importante iniciarlo
retStatus = Execute(StartUpGDIPlus(GdiPlusVersion))
Command1.Caption = "Abrir"
Command2.Caption = "Guardar"
End Sub
Private Sub Command1_Click()
On Error GoTo Cancelar
With CommonDialog1
.Filter = "Archivos de Imagen(*.bmp;*.gif;*.jpg;*.png;*.tif)" & _
"|*.bmp;*.gif;*.jpg;*.png;*.tif"
.CancelError = True
.FileName = ""
.ShowOpen
End With
Picture1.Picture = LoadPicturePlus(CommonDialog1.FileName)
Exit Sub
Cancelar:
End Sub
Private Sub Command2_Click()
On Error GoTo Cancelar
With CommonDialog1
.Filter = "Imagen JPEG(*.jpg)|*.jpg|Imagen TIFF(*.tif)|*.tif|" & _
"Imagen PNG(*.png)|*.png|Imagen Mapa de bits(.bmp)|*.bmp"
.CancelError = True
.Flags = cdlOFNOverwritePrompt
.FileName = ""
.ShowSave
End With
Select Case UCase(Right(CommonDialog1.FileName, 3))
Case "JPG"
SavePictureAsJPG Picture1, CommonDialog1.FileName, 85
Case "TIF"
SavePictureAsTiff Picture1, CommonDialog1.FileName, TiffCompressionNone
Case "PNG"
SavePictureAsPNG Picture1, CommonDialog1.FileName
Case Else
SavePicture Picture1, CommonDialog1.FileName
End Select
Exit Sub
Cancelar:
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim retStatus As Status
'finalizamos
retStatus = Execute(ShutdownGDIPlus)
End Sub
Pues yo se una forma sin hacerlo con VB, pues simplemente abres la imagen luego le das "editar con paint" y luego le das guardar como... y la guardas con formato .jpg y listo...
Pero si lo quieres saber con VB ahi si pailas... :rolleyes: :rolleyes:
Cita de: .:CorTeX:. en 21 Marzo 2006, 01:47 AM
Pues yo se una forma sin hacerlo con VB, pues simplemente abres la imagen luego le das "editar con paint" y luego le das guardar como... y la guardas con formato .jpg y listo...
Pero si lo quieres saber con VB ahi si pailas... :rolleyes: :rolleyes:
Que bueno no se nos havia ocurrido :o :o :o :o ;D
Cita de: .:CorTeX:. en 21 Marzo 2006, 01:47 AM
Pues yo se una forma sin hacerlo con VB, pues simplemente abres la imagen luego le das "editar con paint" y luego le das guardar como... y la guardas con formato .jpg y listo...
Pero si lo quieres saber con VB ahi si pailas... :rolleyes: :rolleyes:
Me muero de ganas por hacer un chiste y no se me ocurre cual... :o