Изображения - Изменение размеров

По материалам: http://www.sql.ru/forum/360201/rabota-s-risunkami#3424634

ВНИМАНИЕ!
Требуется ссылка на библиотеку: OLE Automation

Пример использования:

Private Sub Test()

Dim SrcPic As StdPicture, DstPic As StdPicture

Set SrcPic = LoadPicture("d:\Temp\Test.JPG")

Set DstPic = FitToSizeBitmap(SrcPic.Handle, 175)

SavePicture DstPic, "d:\Temp\Test.bmp"

SavePictureToJPEG DstPic, "d:\Temp\Test1.JPG", 80

Set DstPic = FitToSizeBitmap(SrcPic.Handle, 75)

SavePicture DstPic, "d:\Temp\test2.bmp"

SavePictureToJPEG DstPic, "C:\test2.jpg", 80

End Sub

     Желательно выполнять на ОС с ядром NT (NT 4.0, 2000, XP, 2003, Vista). В случае 95/98/Me режима STRETCH_HALFTONE нет (согласно документации - не проверял), придётся пользоваться STRETCH_DELETESCANS, он чуть менее качественный.

Для записи в JPEG требуется, чтобы была установлена библиотека GDI+. Она входит в ОС начиная с XP, для более ранних доступна с сайта MS (1МБ). Наличие на компьютере можно проверить поиском файла GdiPlus.dll.

Модуль:

'-------------------------------------------------------------------------------

' Module : modResizePicture

' Autor : Бенедикт

' www.sql.ru/forum/actualthread.aspx?bid=46&tid=360201#3424634

'-------------------------------------------------------------------------------

Option Explicit

Option Compare Database

'---------------- Описания структур, функций, констант Win32 API ---------------

Private Type Bitmap '24 bytes

bmType As Long

bmWidth As Long

bmHeight As Long

bmWidthBytes As Long

bmPlanes As Integer

bmBitsPixel As Integer

bmBits As Long

End Type

Private Declare Function SelectObject Lib "gdi32" ( _

ByVal hDC As Long, ByVal hObject As Long) As Long

'Private Declare Function DeleteObject Lib "gdi32" ( _

ByVal hObject As Long) As Long

Private Declare Function GetObjectA Lib "gdi32" ( _

ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function GetObjectType Lib "gdi32" ( _

ByVal hgdiobj As Long) As Long

Private Const OBJ_BITMAP = 7

Private Declare Function CreateCompatibleDC Lib "gdi32" ( _

ByVal hDC As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" ( _

ByVal hDC As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _

ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SetStretchBltMode Lib "gdi32" ( _

ByVal hDC As Long, ByVal nStretchMode As Long) As Long

Private Const STRETCH_DELETESCANS = 3

Private Const STRETCH_HALFTONE = 4

Private Declare Function StretchBlt Lib "gdi32" ( _

ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _

ByVal nWidth As Long, ByVal nHeight As Long, _

ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _

ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _

ByVal dwRop As Long) As Long

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

Private Const PICTYPE_BITMAP = 1

Private Type PicBmp

Size As Long

Type As Long

hBmp As Long

hPal As Long

Reserved As Long

End Type

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _

PicDesc As PicBmp, RefIID As GUID, _

ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type GdiplusStartupInput

GdiplusVersion As Long

DebugEventCallback As Long

SuppressBackgroundThread As Long

SuppressExternalCodecs As Long

End Type

Private Type CLSID 'частный вид GUID-а

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

Private Enum EncoderParameterValueType

[EncoderParameterValueTypeByte] = 1

[EncoderParameterValueTypeASCII] = 2

[EncoderParameterValueTypeShort] = 3

[EncoderParameterValueTypeLong] = 4

[EncoderParameterValueTypeRational] = 5

[EncoderParameterValueTypeLongRange] = 6

[EncoderParameterValueTypeUndefined] = 7

[EncoderParameterValueTypeRationalRange] = 8

End Enum

Private Type EncoderParameter

GUID As CLSID

NumberOfValues As Long

Type As EncoderParameterValueType

Value As Long

End Type

Private Type EncoderParameters

Count As Long

Parameter As EncoderParameter

End Type

Private Enum GpStatus

[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

End Enum

Private Type ImageCodecInfo

ClassID As CLSID

FormatID As CLSID

CodecName As Long

DllName As Long

FormatDescription As Long

FilenameExtension As Long

MimeType As Long

flags As Long

Version As Long

SigCount As Long

SigSize As Long

SigPattern As Long

SigMask As Long

End Type

Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _

ByVal hBmp As Long, ByVal hPal As Long, Bitmap As Long) As GpStatus

Private Declare Function GdiplusStartup Lib "gdiplus" ( _

token As Long, inputbuf As GdiplusStartupInput, _

Optional ByVal outputbuf As Long = 0) As GpStatus

Private Declare Function GdiplusShutdown Lib "gdiplus" ( _

ByVal token As Long) As GpStatus

Private Declare Function GdipSaveImageToFile Lib "gdiplus" ( _

ByVal image As Long, ByVal FileNameW As Long, _

clsidEncoder As CLSID, encoderParams As Any) As GpStatus

Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" ( _

numEncoders As Long, Size As Long) As GpStatus

Private Declare Function GdipGetImageEncoders Lib "gdiplus" ( _

ByVal numEncoders As Long, ByVal Size As Long, encoders As Any) As GpStatus

Private Declare Function GdipDisposeImage Lib "gdiplus" ( _

ByVal image As Long) As GpStatus

Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _

Dest As Any, Src As Any, ByVal cb As Long) As Long

'Private Declare Function CLSIDFromString Lib "ole32" ( _

ByVal lpszProgID As Long, pCLSID As CLSID) As Long

Private Declare Function lstrlenW Lib "kernel32" ( _

ByVal psString As Any) As Long

'Private Const EncoderQuality$ = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

Private GdIHandle As Long

'-------------------------------------------------------------------------------

'Из Q161299

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' CreateBitmapPicture

' - Creates a bitmap type Picture object from a bitmap and

' palette.

'

' hBmp

' - Handle to a bitmap.

'

' hPal

' - Handle to a Palette.

' - Can be null if the bitmap doesn't use a palette.

'

' Returns

' - Returns a Picture object containing the bitmap.

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As StdPicture

Dim R As Long

Dim Pic As PicBmp

' IPicture requires a reference to "Standard OLE Types."

Dim IPic As IPicture

Dim IID_IDispatch As GUID

' Fill in with IDispatch Interface ID.

With IID_IDispatch

.Data1 = &H20400

.Data4(0) = &HC0

.Data4(7) = &H46

End With

' Fill Pic with necessary parts.

With Pic

.Size = Len(Pic) ' Length of structure.

.Type = PICTYPE_BITMAP ' Type of Picture (bitmap).

.hBmp = hBmp ' Handle to bitmap.

.hPal = hPal ' Handle to palette (may be null).

End With

' Create Picture object.

R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.

Set CreateBitmapPicture = IPic

End Function

Public Function FitToSizeBitmap( _

ByVal hBitmap As Long, _

Optional ByVal nWidth As Long = 0, _

Optional ByVal nHeight As Long = 0) As StdPicture

Dim bm As Bitmap

Dim cbSize As Long

Dim cbCopied As Long

Dim hdcSrc As Long

Dim hdcDst As Long

Dim hbmpOldSrc As Long

Dim hbmpOldDst As Long

Dim hbmpNew As Long

Dim r0 As Double

Dim nDstWidth As Long, nDstHeight As Long

If (hBitmap = 0) Or (nWidth < 0) Or (nHeight < 0) Then Exit Function

If GetObjectType(hBitmap) <> OBJ_BITMAP Then Exit Function

'Получаем заголовок битмапа, чтобы извлечь из него размеры изображения

'в пикселях

cbSize = LenB(bm)

cbCopied = GetObjectA(hBitmap, cbSize, bm)

If cbCopied <> cbSize Then Exit Function

'Подгонка размера

r0 = bm.bmWidth / bm.bmHeight

If nWidth = 0 Then

'Пользователя не интересует ширина - вписываем в высоту

If nHeight = 0 Then

'Пользователя не интересует и высота - странно. Просто

'сохраняем оригинальные размеры

nDstWidth = bm.bmWidth

nDstHeight = bm.bmHeight

Else

nDstHeight = nHeight

nDstWidth = Int(nDstHeight * r0 + 0.5)

If nDstWidth <= 0 Then nDstWidth = 1

End If

ElseIf nHeight = 0 Then

'Пользователя не интересует высота - вписываем в ширину

nDstWidth = nWidth

nDstHeight = Int(nDstWidth / r0 + 0.5)

If nDstHeight <= 0 Then nDstHeight = 1

Else

'Пользователь хочет вписать битмап в прямоугольник с размерами

'не больше заданных

If r0 < nWidth / nHeight Then

nDstHeight = nHeight

nDstWidth = Int(nHeight * r0 + 0.5)

If nDstWidth <= 0 Then nDstWidth = 1

Else

nDstWidth = nWidth

nDstHeight = Int(nHeight / r0 + 0.5)

If nDstHeight <= 0 Then nDstHeight = 1

End If

End If

'Создаём контексты устройств, совместимых с экраном, в памяти

'Картинка будет иметь логическое разрешение, как у экрана (обычно 96 dpi)

hdcSrc = CreateCompatibleDC(0)

hdcDst = CreateCompatibleDC(hdcSrc)

'Создаём битмап, совместимый с оригинальным, в памяти

hbmpOldSrc = SelectObject(hdcSrc, hBitmap)

hbmpNew = CreateCompatibleBitmap(hdcSrc, nDstWidth, nDstHeight)

If hbmpNew = 0 Then

SelectObject hdcSrc, hbmpOldSrc

DeleteDC hdcDst

DeleteDC hdcSrc

Exit Function

End If

hbmpOldDst = SelectObject(hdcDst, hbmpNew)

'Отрисовываем оригинальный битмап на целевой с перемасштабированием

SetStretchBltMode hdcDst, STRETCH_HALFTONE 'Есть только в ОС с ядром NT

StretchBlt hdcDst, 0, 0, nDstWidth, nDstHeight, _

hdcSrc, 0, 0, bm.bmWidth, bm.bmHeight, SRCCOPY

'Создаём StdPicture, владеющий битмапом

Set FitToSizeBitmap = CreateBitmapPicture(hbmpNew, 0)

'Очищаем объекты GDI

SelectObject hdcSrc, hbmpOldSrc

SelectObject hdcDst, hbmpOldDst

'DeleteObject hbmpNew 'Третий параметр OleCreatePictureIndirect,

'установленний в TRUE, заставляет убивать битмап

'при уменьшении счётчика ссылок на картинку до нуля

DeleteDC hdcDst

DeleteDC hdcSrc

End Function

Public Function SavePictureToJPEG( _

Picture As StdPicture, FileName As String, JPGQuality As Long) As Boolean

Dim gplRet As Long

Dim hImg As Long

Dim uEncCLSID As CLSID

Dim uEncParams As EncoderParameters

Dim GpInput As GdiplusStartupInput

GpInput.GdiplusVersion = 1

If GdiplusStartup(GdIHandle, GpInput) <> [OK] Then Exit Function

If JPGQuality > 100 Then JPGQuality = 100

If JPGQuality < 1 Then JPGQuality = 1

'-- Create bitmap from HBITMAP

gplRet = GdipCreateBitmapFromHBITMAP(Picture.Handle, Picture.hPal, hImg)

If gplRet = [OK] Then

GetEncoderClsID "image/jpeg", uEncCLSID

'Установка качества

uEncParams.Count = 1

With uEncParams.Parameter

.NumberOfValues = 1

.Type = [EncoderParameterValueTypeLong]

With .GUID

.Data1 = &H1D5BE4B5

.Data2 = &HFA4A

.Data3 = &H452D

.Data4(0) = &H9C

.Data4(1) = &HDD

.Data4(2) = &H5D

.Data4(3) = &HB3

.Data4(4) = &H51

.Data4(5) = &H5

.Data4(6) = &HE7

.Data4(7) = &HEB

End With

'CLSIDFromString StrPtr(EncoderQuality), .GUID

.Value = VarPtr(JPGQuality)

End With

gplRet = GdipSaveImageToFile(hImg, StrPtr(FileName), uEncCLSID, uEncParams)

SavePictureToJPEG = gplRet = [OK]

gplRet = GdipDisposeImage(hImg)

End If

GdiplusShutdown GdIHandle

End Function

Private Function GetEncoderClsID(strMimeType As String, ClassID As CLSID)

Dim Num As Long, Size As Long, i As Long

Dim ICI() As ImageCodecInfo

Dim Buffer() As Byte

GetEncoderClsID = -1

GdipGetImageEncodersSize Num, Size

If Size = 0 Then Exit Function

ReDim ICI(1 To Num) As ImageCodecInfo

ReDim Buffer(1 To Size) As Byte

GdipGetImageEncoders Num, Size, Buffer(1)

CopyMemory ICI(1), Buffer(1), (Len(ICI(1)) * Num)

For i = 1 To Num

If StrComp(LPWSTR2String(ICI(i).MimeType), strMimeType, _

vbTextCompare) = 0 Then

ClassID = ICI(i).ClassID

GetEncoderClsID = i

Exit For

End If

Next

Erase ICI

Erase Buffer

End Function

Private Function LPWSTR2String(ByVal lpWStr As Long) As String

Dim nStrLen As Long

nStrLen = lstrlenW(lpWStr)

LPWSTR2String = String$(nStrLen, vbNullChar)

CopyMemory ByVal StrPtr(LPWSTR2String), ByVal lpWStr, nStrLen * 2

End Function