Grabar un PNG

[jc_moty]

Bueno, buscando por ahi me tope con un código que permite convertir el contenido de un Picturebox a JPG y con unas cuantas modificaciones he logrado hacer que guarde imagenes en formato: GIF, PNG, BMP y obviamente JPG.
Aqui dejo el código:

En un Modulo:

Código:

Option Explicit

' ----==== GDIPlus Const ====----
Const GdiPlusVersion As Long = 1
Private Const EncoderParameterValueTypeLong As Long = 4
Private Const EncoderQuality As String = _
    "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

' ----==== Sonstige Types ====----
Public Enum MimeType
    JPG = 0
    GIF = 1
    PNG = 2
    BMP = 3
End Enum

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 ====----
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+ 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 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 GdipCreateBitmapFromHBITMAP Lib "gdiplus" _
    (ByVal hbm As Long, ByVal hpal As Long, _
    ByRef Bitmap 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


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)

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 retStatus As Status
Private GdipToken As Long
Private GdipInitialized As Boolean

Private Function StartUpGDIPlus(ByVal GdipVersion As Long) As Status
    Dim GdipStartupInput As GDIPlusStartupInput
    GdipStartupInput.GdiPlusVersion = GdipVersion
    StartUpGDIPlus = GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
End Function

Private Function ShutdownGDIPlus() As Status
   ShutdownGDIPlus = GdiplusShutdown(GdipToken)
End Function

Private Function Execute(ByVal lReturn As Status) As Status
    Dim lCurErr As Status
    If lReturn = Status.OK Then
        lCurErr = Status.OK
    Else
        lCurErr = lReturn
        
    End If
    Execute = lCurErr
End Function

Public Function Convertir(ByVal Pic As StdPicture, _
    ByVal FileName As String, Optional ByVal Quality As Long = 85, _
    Optional ByVal FileType As MimeType = JPG) _
    As Boolean
    
    Dim retStatus As Status
    Dim retVal As Boolean
    Dim lBitmap As Long
    '// Variable para el MimeType
    Dim mimeT As String
    
    Iniciar
    
    If GdipInitialized = False Then Exit Function
    ' 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
        
        '// Seleccion de casos para el MimeType
        Select Case FileType
            Case JPG
                mimeT = "image/jpeg"
            Case GIF
                mimeT = "image/gif"
            Case PNG
                mimeT = "image/png"
            Case BMP
                mimeT = "image/bmp"
        End Select
        
        '// Ermitteln der CLSID vom mimeType Encoder
        retVal = GetEncoderClsid(mimeT, 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
                  Convertir = True
              Else
                  Convertir = False
              End If
        Else
              Convertir = False
              MsgBox "Konnte keinen passenden Encoder ermitteln.", _
              vbOKOnly, "Encoder Error"
        End If
        
        ' Lösche lBitmap
        Call Execute(GdipDisposeImage(lBitmap))
        
    Dim ret As Long

    If GdipInitialized = True Then
       ret = Execute(ShutdownGDIPlus)
    End If
    End If
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
        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
              Exit Function
        End If
    Next j
    
    Erase pImageCodecInfo
    GetEncoderClsid = False
End Function

Private Sub Iniciar()
 Dim ret As Long
 ret = Execute(StartUpGDIPlus(1))
    If ret = 0 Then
        GdipInitialized = True
    Else
        MsgBox "El GDI no está inicializado", vbOKOnly, "GDI Error"
    End If
End Sub

Su uso desde un CommandButton:

Código:

Private Sub Command1_Click()
    Convertir Picture1, "C:\Bitmap.bmp", , BMP
    Convertir Picture1, "C:\ImagenPNG.png", , PNG
    Convertir Picture1, "C:\ImagenJPG.jpg", , JPG
    Convertir Picture1, "C:\ImagenGIF.gif", , GIF
End Sub

Tene en cuenta que este codigo hace uso de las funciones contenidas en la libreria gdiplus.dll y esta solamente viene incluida con Windows XP, es decir que para ejecutar este programa en versiones anteriores de Windows, debes descargar esta libreria; aqui dejo un vinculo donde podes descargarla: Descargar GDI+.

Agradecimientos a: Leandro (por postear el codigo), y a Luciano (por su modificacion y simplificacion).

Saludos