Сделал такой вариант:
- Код: Выделить всё
Option Private Module
Option Explicit
Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As Long, bitmap As Long) As GpStatus
Public Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal image As Long, Width As Single, Height As Single) As GpStatus
Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus
Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus
Public Declare Function GdipGetImageHorizontalResolution Lib "gdiplus" (ByVal image As Long, resolution As Single) As GpStatus
Public Declare Function GdipGetImageVerticalResolution Lib "gdiplus" (ByVal image As Long, resolution As Single) As GpStatus
Public Declare Function GdipGetImageThumbnail Lib "gdiplus" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, _
Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As GpStatus
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
Public 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
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Function LoadImage(ByVal strFName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
Dim imgThumb As Long
Dim imgHeight As Single, imgWidth As Single
uGdiInput.GdiplusVersion = 1
'Запускаем GDI+
If GdiplusStartup(hGdiPlus, uGdiInput) = OK Then
'Создаём изображение в памяти
If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = OK Then
'Получаем размеры изображения
Call GdipGetImageDimension(hGdiImage, imgWidth, imgHeight)
'Делаем из изображения уменьшенное
Call GdipGetImageThumbnail(hGdiImage, ItemWidth, ItemWidth * imgHeight / imgWidth, imgThumb)
'Указатель на изображение
Call GdipCreateHBITMAPFromBitmap(imgThumb, hBitmap, 0)
'Конвертируем изображение в IPicture
Set LoadImage = ConvertToIPicture(hBitmap)
GdipDisposeImage hGdiImage
End If
GdiplusShutdown hGdiPlus
Else
MsgBox "Ошибка при загрузке GDI+!", vbCritical
End If
End Function
Public Function ConvertToIPicture(ByVal hPic As Long) As IPicture
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
Const PICTYPE_BITMAP = 1
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set ConvertToIPicture = IPic
End Function
Основная функция LoadImage, которая возвращает IPicture для передачи картинки на панель инструментов Word.
Проблема в том, что мне нужно получить картинку с фиксированными размерами, но так, чтобы пропорции исходного изображения, которое может быть любым, не менялись.
Допустим мне нужно получить картинку 150×200 из изображения 600×480. Если его пропорционально уменьшить в четыре раза по ширине, то получим 150×120, меня это не устраивает. Нужно сделать, чтобы картинка 150×120 располагалась в центре холста с размерами 150×200. Пока что я использую GdipGetImageThumbnail, но она работает только с фиксированным размером и пропорции искажает.
Думаю, что нужно после загрузки изображения в память изменять холст так, чтобы пропорции становились равными пропорциям уменьшенного изображения, а затем уже получать Thumbnail. Т,е. в моём примере нужно изменить изображение с 640×480 до 640×800, дополнив недостающее изображение пустым фоном.
Но вот как менять холст? Создавать изображение с нужными пропорциями, а потом накладывать на него то, которое у меня есть?
