Конвертация bmp в jpg на VB6

[Сергій]

VB6 сохраняет изображения в формате bmp. А как можно сохранять или конвертировать в ipg ?

 

[Dragokas]

С помощью GDI+.
Держи JPEG Encoder Class от John Korejwa.

 

[Сергій]

С помощью GDI+.
Держи JPEG Encoder Class от John Korejwa.

Спасибо.

 

[Dragokas]

Без сторонних DLL через GDI+ (на основе примера от The Trick "Сохранение скриншота в байтовый массив"):

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
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 As EncoderParameter
End Type

Private Declare Function LoadImage Lib "user32" Alias "LoadImageW" (ByVal hinst As Long, ByVal lpszName As Long, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32" (ByVal ppstm As Long, hGlobal As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function GdipSaveImageToStream Lib "GDIPlus" (ByVal Image As Long, ByVal Stream As IUnknown, clsidEncoder As Any, encoderParams As Any) As Long
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

Private Const IMAGE_BITMAP = 0&
Private Const LR_LOADFROMFILE = &H10&

Private Sub Form_Load()
    ConvertBmpToJpeg "c:\temp\akel_calc.bmp", "c:\temp\akel_calc.jpg"
End Sub

Function ConvertBmpToJpeg(SourceFile As String, DestinationFile As String, Optional Quality As Byte) As Boolean
    Dim hBmp    As Long
    Dim IStream As IUnknown
    Dim hMem    As Long
    Dim lSize   As Long
    Dim lPt     As Long
    Dim Dat()   As Byte
    Dim fNum    As Integer
    Dim FileSrc As String
    Dim FileDst As String

    hBmp = LoadImage(0&, StrPtr(SourceFile), IMAGE_BITMAP, 0&, 0&, LR_LOADFROMFILE)
    If hBmp = 0 Then MsgBox "Ошибка загрузки файла: " & SourceFile: Exit Function

    If CreateStreamOnHGlobal(0&, 1&, IStream) Then MsgBox "Ошибка создание потока": Exit Function
    If Not SaveJPG(hBmp, IStream, Quality) Then MsgBox "Ошибка сохранение файла в поток": DeleteObject (hBmp): Exit Function
    DeleteObject hBmp

    If GetHGlobalFromStream(ObjPtr(IStream), hMem) Then MsgBox "Ошибка получения хендла памяти": Exit Function
    lSize = GlobalSize(hMem)
    If lSize Then
        lPt = GlobalLock(hMem)
        ReDim Dat(0 To lSize - 1)
        CopyMemory Dat(0), ByVal lPt, lSize
        GlobalUnlock hMem
    End If

    fNum = FreeFile()
    Open DestinationFile For Binary As fNum
    Put fNum, , Dat
    Close fNum
    ConvertBmpToJpeg = True
End Function

Private Function SaveJPG(hBitmap As Long, Stream As IUnknown, Optional Quality As Byte = 50) As Boolean
    Dim SI As GdiplusStartupInput
    Dim token As Long, lBmp As Long
    Dim JpgEnc As GUID, Res As Long
    Dim Par As EncoderParameters

    SI.GdiplusVersion = 1
    If GdiplusStartup(token, SI) Then Exit Function
    If GdipCreateBitmapFromHBITMAP(hBitmap, 0, lBmp) Then GdiplusShutdown (token): Exit Function
    CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), JpgEnc
    Par.Count = 1
    Par.Parameter.NumberOfValues = 1
    Par.Parameter.type = 4
    Par.Parameter.Value = VarPtr(Quality)
    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), Par.Parameter.GUID
    Res = GdipSaveImageToStream(lBmp, Stream, JpgEnc, Par)
    GdipDisposeImage lBmp
    GdiplusShutdown token
    If Res Then Exit Function
    SaveJPG = True
End Function

Качество можно регулировать 3-м параметром функции ConvertBmpToJpeg.

 

[Сергій]

Круто!!!
(3-й параметр: 1 = наилучшее, 255 = наихудшее качество)

ConvertBmpToJpeg "c:\temp\akel_calc.bmp", "c:\temp\akel_calc.jpg", 128

- я правильно понял?
наоборот 255-0

 

[Dragokas]

0 - 100.

0 - самое высокое сжатие.
100 - самое высокое качество.

Encoder.Quality - поле (System.Drawing.Imaging)

Категория Quality определяет уровень сжатия для изображения. При использовании для создания EncoderParameter диапазон полезных значений для категории качества — от 0 до 100. Чем ниже указанное число, тем выше сжатие и, таким образом, ниже качество изображения. При нуле качество изображения будет самым низким, а при 100 – самым высоким.

 

[Сергій]

0 - 100.

0 - самое высокое сжатие.
100 - самое высокое качество.

Encoder.Quality - поле (System.Drawing.Imaging)

Я подумал, что если третий параметр - as byte, то - до 255