This uses Windows Imaging Component to convert a bitmap (a 32-bit DIB) to a JPEG stream purely in memory.
Paste the following code in a .bas module:
Here is the sample Form1 that exercises the WicConvertToJpeg function above
The test code above needs another .bas module with the WicLoadPicture function
Posted all this code with all API declares to be searchable in the forums as WIC is quite apocryphal technology here.
cheers,
</wqw>
Paste the following code in a .bas module:
Code:
Option Explicit
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown
Private Declare Function IStream_Size Lib "shlwapi" (ByVal pStream As stdole.IUnknown, uiSize As Any) As Long
Private Declare Function IStream_Reset Lib "shlwapi" (ByVal pStream As stdole.IUnknown) As Long
Private Declare Function IStream_Read Lib "shlwapi" (ByVal pStream As stdole.IUnknown, pvBuf As Any, ByVal cbSize As Long) As Long
'--- WIC
Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateStream_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIWICStream As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateEncoder_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, guidContainerFormat As Any, pguidVendor As Any, ppIEncoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateBitmapFromMemory_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long, pixelFormat As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any, ppIBitmap As stdole.IUnknown) As Long
Private Declare Function IWICStream_InitializeFromIStream_Proxy Lib "windowscodecs" (ByVal pIWICStream As stdole.IUnknown, ByVal pIStream As stdole.IUnknown) As Long
Private Declare Function IWICBitmapEncoder_Initialize_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown, ByVal pIStream As stdole.IUnknown, ByVal cacheOption As Long) As Long
Private Declare Function IWICBitmapEncoder_CreateNewFrame_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown, ppIFrameEncode As stdole.IUnknown, ppIEncoderOptions As stdole.IUnknown) As Long
Private Declare Function IWICBitmapEncoder_Commit_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown) As Long
Private Declare Function IWICBitmapFrameEncode_Initialize_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal pIEncoderOptions As stdole.IUnknown) As Long
Private Declare Function IWICBitmapFrameEncode_SetSize_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long) As Long
Private Declare Function IWICBitmapFrameEncode_WriteSource_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal pIBitmapSource As stdole.IUnknown, pWicRect As Any) As Long
Private Declare Function IWICBitmapFrameEncode_Commit_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown) As Long
Private Declare Function IPropertyBag2_Write_Proxy Lib "windowscodecs" (ByVal pPropBag As stdole.IUnknown, ByVal cProperties As Long, pBag As Any, pvarValue As Variant) As Long
Private m_pWicFactory As stdole.IUnknown
Public Function WicConvertToJpeg(baOutput() As Byte, ByVal lWidth As Long, ByVal lHeight As Long, baInput() As Byte, ByVal lQuality As Long) As Boolean
Const WINCODEC_SDK_VERSION1 As Long = &H236&
Const WINCODEC_SDK_VERSION2 As Long = &H237&
Const WICBitmapEncoderNoCache As Long = 2
Dim aGUID(0 To 3) As Long
Dim pBitmap As stdole.IUnknown
Dim pWicStream As stdole.IUnknown
Dim pStream As stdole.IUnknown
Dim pEncoder As stdole.IUnknown
Dim pFrame As stdole.IUnknown
Dim pPropBag As stdole.IUnknown
Dim cSize As Currency
Dim aBag(0 To 7) As Long
On Error GoTo EH
If m_pWicFactory Is Nothing Then
If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
GoTo QH
End If
End If
End If
'--- GUID_WICPixelFormat32bppPBGRA
aGUID(0) = &H6FDDC324
aGUID(1) = &H4BFE4E03
aGUID(2) = &H773D85B1
aGUID(3) = &H10C98D76
If pvCheckHResult(IWICImagingFactory_CreateBitmapFromMemory_Proxy(m_pWicFactory, lWidth, lHeight, aGUID(0), lWidth * 4, UBound(baInput) + 1, baInput(0), pBitmap)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICImagingFactory_CreateStream_Proxy(m_pWicFactory, pWicStream)) < 0 Then
GoTo QH
End If
Set pStream = SHCreateMemStream(ByVal 0, 0)
If pvCheckHResult(IWICStream_InitializeFromIStream_Proxy(pWicStream, pStream)) < 0 Then
GoTo QH
End If
'--- GUID_ContainerFormatJpeg
aGUID(0) = &H19E4A5AA
aGUID(1) = &H4FC55662
aGUID(2) = &H5817C0A0
aGUID(3) = &H57108E02
If pvCheckHResult(IWICImagingFactory_CreateEncoder_Proxy(m_pWicFactory, aGUID(0), ByVal 0, pEncoder)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapEncoder_Initialize_Proxy(pEncoder, pWicStream, WICBitmapEncoderNoCache)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapEncoder_CreateNewFrame_Proxy(pEncoder, pFrame, pPropBag)) < 0 Then
GoTo QH
End If
aBag(3) = StrPtr("ImageQuality")
If pvCheckHResult(IPropertyBag2_Write_Proxy(pPropBag, 1, aBag(0), CSng(lQuality) / 100!)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapFrameEncode_Initialize_Proxy(pFrame, pPropBag)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapFrameEncode_SetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapFrameEncode_WriteSource_Proxy(pFrame, pBitmap, ByVal 0)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapFrameEncode_Commit_Proxy(pFrame)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapEncoder_Commit_Proxy(pEncoder)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IStream_Size(pStream, cSize)) < 0 Then
GoTo QH
End If
cSize = cSize * 10000
If pvCheckHResult(IStream_Reset(pStream)) < 0 Then
GoTo QH
End If
If cSize > 0 Then
ReDim baOutput(0 To cSize - 1) As Byte
If pvCheckHResult(IStream_Read(pStream, baOutput(0), cSize)) < 0 Then
GoTo QH
End If
Else
baOutput = vbNullString
End If
'--- success
WicConvertToJpeg = True
QH:
Exit Function
EH:
Debug.Print Err.Description
End Function
Private Function pvCheckHResult(ByVal hResult As Long) As Long
If hResult < 0 Then
Err.Raise hResult
End If
pvCheckHResult = pvCheckHResult
End FunctionCode:
Option Explicit
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Sub Form_Load()
Dim lWidth As Long
Dim lHeight As Long
Dim baBitmap() As Byte
Dim baJpeg() As Byte
If Not WicLoadPicture("d:\temp\aaa.bmp", lWidth, lHeight, baBitmap) Then
GoTo QH
End If
If Not WicConvertToJpeg(baJpeg, lWidth, lHeight, baBitmap, 80) Then
GoTo QH
End If
WriteBinaryFile "d:\temp\aaa.jpg", baJpeg
QH:
End Sub
Public Sub WriteBinaryFile(sFile As String, baBuffer() As Byte)
Dim nFile As Integer
Call DeleteFile(sFile)
nFile = FreeFile
Open sFile For Binary Access Write Shared As nFile
If UBound(baBuffer) >= 0 Then
Put nFile, , baBuffer
End If
Close nFile
End SubCode:
Option Explicit
'--- WIC
Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateDecoderFromFilename_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal wzFilename As Long, pguidVendor As Any, ByVal dwDesiredAccess As Long, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateFormatConverter_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIFormatConverter As stdole.IUnknown) As Long
Private Declare Function IWICBitmapDecoder_GetFrame_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal lIndex As Long, ppIBitmapFrame As stdole.IUnknown) As Long
Private Declare Function IWICBitmapSource_CopyPixels_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, prc As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any) As Long
Private Declare Function IWICBitmapSource_GetSize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, puiWidth As Long, puiHeight As Long) As Long
Private Declare Function IWICFormatConverter_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, dstFormat As Any, ByVal lDither As Long, ByVal pIPalette As stdole.IUnknown, ByVal dblAlphaThresholdPercent As Double, ByVal lPaletteTranslate As Long) As Long
Private m_pWicFactory As stdole.IUnknown
Public Function WicLoadPicture( _
sFileName As String, _
lWidth As Long, _
lHeight As Long, _
baOutput() As Byte) As Boolean
Const WINCODEC_SDK_VERSION1 As Long = &H236&
Const WINCODEC_SDK_VERSION2 As Long = &H237&
Const GENERIC_READ As Long = &H80000000
Dim pDecoder As stdole.IUnknown
Dim pFrame As stdole.IUnknown
Dim pConverter As stdole.IUnknown
Dim aGUID(0 To 3) As Long
If m_pWicFactory Is Nothing Then
If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
GoTo QH
End If
End If
End If
If pvCheckHResult(IWICImagingFactory_CreateDecoderFromFilename_Proxy(m_pWicFactory, StrPtr(sFileName), ByVal 0, GENERIC_READ, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, 0, pFrame)) < 0 Or pFrame Is Nothing Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapSource_GetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then
GoTo QH
End If
If pvCheckHResult(IWICImagingFactory_CreateFormatConverter_Proxy(m_pWicFactory, pConverter)) < 0 Or pConverter Is Nothing Then
GoTo QH
End If
'--- GUID_WICPixelFormat32bppPBGRA
aGUID(0) = &H6FDDC324
aGUID(1) = &H4BFE4E03
aGUID(2) = &H773D85B1
aGUID(3) = &H10C98D76
If pvCheckHResult(IWICFormatConverter_Initialize_Proxy(pConverter, pFrame, aGUID(0), 0, Nothing, 0#, 0)) < 0 Then
GoTo QH
End If
ReDim baOutput(0 To lWidth * lHeight * 4 - 1) As Byte
If pvCheckHResult(IWICBitmapSource_CopyPixels_Proxy(pConverter, ByVal 0&, lWidth * 4, lWidth * lHeight * 4, baOutput(0))) < 0 Then
GoTo QH
End If
'--- success
WicLoadPicture = True
QH:
End Function
Private Function pvCheckHResult(ByVal hResult As Long) As Long
If hResult < 0 Then
Err.Raise hResult
End If
pvCheckHResult = pvCheckHResult
End Functioncheers,
</wqw>