Макросы для получения размера изображения, и создания уменьшенной копии картинки

В данной статье опубликованы макросы для уменьшения размеров изображения (в графическом файле),
и для получения размеров картинки из файла.

Эти макросы нашли применение в универсальной надстройке для вставки картинок в Excel

Там они используются для выполнения функции сжатия изображений перед вставкой
(сначала рассчитываются нужные размеры изображения на листе Excel,
затем создаётся уменьшенная копия исходной картинки (с заданными размерами),
и потом уже уменьшенная картинка вставляется на лист Excel)

Если вы не можете разобраться, как применить эти макросы для своих задач, — просто воспользуйтесь готовой надстройкой.
(там уже все сделано — достаточно нажать одну кнопку для вставки уменьшенных (сжатых) изображений)

Функции WinAPI (необходимы для приведённых ниже макросов)

#If VBA7 Then
    Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As LongPtr
    Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As LongPtr, ByVal FileName As LongPtr, clsidEncoder As GUID, encoderParams As Any) As LongPtr
    Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As LongPtr
    Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (Token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As GpStatus
    Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal FileName As LongPtr, Bitmap As LongPtr) As GpStatus
    Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal Bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As GpStatus
    Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As GpStatus
    Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal Token As LongPtr) As LongPtr
    Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Declare PtrSafe Function GdipGetImageDimension Lib "GDIPlus" (ByVal Image As LongPtr, Width As Single, Height As Single) As GpStatus
    Declare PtrSafe Function GdipGetImageWidth Lib "GDIPlus" (ByVal Image As LongPtr, Width As LongPtr) As GpStatus
    Declare PtrSafe Function GdipGetImageHeight Lib "GDIPlus" (ByVal Image As LongPtr, Height As LongPtr) As GpStatus
    Declare PtrSafe Function GdipGetImageHorizontalResolution Lib "GDIPlus" (ByVal Image As LongPtr, resolution As Single) As GpStatus
    Declare PtrSafe Function GdipGetImageVerticalResolution Lib "GDIPlus" (ByVal Image As LongPtr, resolution As Single) As GpStatus
    Declare PtrSafe Function GdipGetImageThumbnail Lib "GDIPlus" (ByVal Image As LongPtr, ByVal thumbWidth As LongPtr, ByVal thumbHeight As LongPtr, thumbImage As LongPtr, Optional ByVal callback As LongPtr = 0, Optional ByVal callbackData As LongPtr = 0) As GpStatus
    Declare PtrSafe Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal FileName As String, Image As LongPtr) As GpStatus
    Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As LongPtr
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As LongPtr) As LongPtr
    Declare PtrSafe Function PatBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As LongPtr, ByVal Y As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr, ByVal dwRop As LongPtr) As LongPtr
    Declare PtrSafe Function CreateBitmap Lib "gdi32" (ByVal nWidth As LongPtr, ByVal nHeight As LongPtr, ByVal nPlanes As LongPtr, ByVal nBitCount As LongPtr, lpBits As Any) As LongPtr
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus.dll" (ByVal hDC As LongPtr, GpGraphics As LongPtr) As LongPtr
    Declare PtrSafe Function GdipSetInterpolationMode Lib "gdiplus.dll" (ByVal Graphics As LongPtr, ByVal InterMode As LongPtr) As LongPtr
    Declare PtrSafe Function GdipDrawImageRectI Lib "gdiplus.dll" (ByVal Graphics As LongPtr, ByVal Img As LongPtr, ByVal X As LongPtr, ByVal Y As LongPtr, ByVal Width As LongPtr, ByVal Height As LongPtr) As LongPtr
    Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus.dll" (ByVal Graphics As LongPtr) As LongPtr
    Declare PtrSafe Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal Graphics As LongPtr, ByVal GpImage As LongPtr, ByVal dstx As LongPtr, ByVal dsty As LongPtr, ByVal dstwidth As LongPtr, ByVal dstheight As LongPtr, ByVal srcx As LongPtr, ByVal srcy As LongPtr, ByVal srcwidth As LongPtr, ByVal srcheight As LongPtr, ByVal srcUnit As LongPtr, ByVal imageAttributes As LongPtr, ByVal callback As LongPtr, ByVal callbackData As LongPtr) As LongPtr

Type GUID: Data1 As LongPtr: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Type PICTDESC: size As LongPtr: Type As LongPtr: hPic As LongPtr: hPal As LongPtr: End Type
Type GdiplusStartupInput: GdiplusVersion As LongPtr: DebugEventCallback As LongPtr: SuppressBackgroundThread As LongPtr: SuppressExternalCodecs As LongPtr: End Type
Type EncoderParameter: GUID As GUID: NumberOfValues As LongPtr: Type As LongPtr: Value As LongPtr: End Type
Type EncoderParameters: Count As LongPtr: Parameter As EncoderParameter: End Type
Enum GpStatus
    Status_OK = 0: Status_GenericError = 1: Status_InvalidParameter = 2: Status_OutOfMemory = 3: Status_ObjectBusy = 4: Status_InsufficientBuffer = 5
    Status_NotImplemented = 6: Status_Win32Error = 7: Status_WrongState = 8: Status_Aborted = 9: Status_FileNotFound = 10: Status_ValueOverflow = 11
    Status_AccessDenied = 12: Status_UnknownImageFormat = 13: Status_FontFamilyNotFound = 14: Status_FontStyleNotFound = 15: Status_NotTrueTypeFont = 16
    Status_UnsupportedGdiplusVersion = 17: Status_GdiplusNotInitialized = 18: Status_PropertyNotFound = 19: Status_PropertyNotSupported = 20
End Enum
 
#Else
    Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
    Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    Declare Function GdiplusStartup Lib "GDIPlus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
    Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal FileName As Long, Bitmap As Long) As GpStatus
    Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal Bitmap As Long, hbmReturn As Long, ByVal background As Long) As GpStatus
    Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As GpStatus
    Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal Token As Long) As Long
    Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare Function GdipGetImageDimension Lib "GDIPlus" (ByVal Image As Long, Width As Single, Height As Single) As GpStatus
    Declare Function GdipGetImageWidth Lib "GDIPlus" (ByVal Image As Long, Width As Long) As GpStatus
    Declare Function GdipGetImageHeight Lib "GDIPlus" (ByVal Image As Long, Height As Long) As GpStatus
    Declare Function GdipGetImageHorizontalResolution Lib "GDIPlus" (ByVal Image As Long, resolution As Single) As GpStatus
    Declare Function GdipGetImageVerticalResolution Lib "GDIPlus" (ByVal Image As Long, resolution As Single) As GpStatus
    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
    Declare Function GdipLoadImageFromFile Lib "GDIPlus" (ByVal FileName As String, Image As Long) As GpStatus
    Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
    Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
    Declare Function GdipCreateFromHDC Lib "gdiplus.dll" (ByVal hDC As Long, GpGraphics As Long) As Long
    Declare Function GdipSetInterpolationMode Lib "gdiplus.dll" (ByVal Graphics As Long, ByVal InterMode As Long) As Long
    Declare Function GdipDrawImageRectI Lib "gdiplus.dll" (ByVal Graphics As Long, ByVal Img As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Long
    Declare Function GdipDeleteGraphics Lib "gdiplus.dll" (ByVal Graphics As Long) As Long
    Declare Function GdipDrawImageRectRectI Lib "gdiplus.dll" (ByVal Graphics As Long, ByVal GpImage As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long

Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte: End Type
Type PICTDESC: size As Long: Type As Long: hPic As Long: hPal As Long: End Type
Type GdiplusStartupInput: GdiplusVersion As Long: DebugEventCallback As Long: SuppressBackgroundThread As Long: SuppressExternalCodecs As Long: End Type
Type EncoderParameter: GUID As GUID: NumberOfValues As Long: Type As Long: Value As Long: End Type
Type EncoderParameters: Count As Long: Parameter As EncoderParameter: End Type
Enum GpStatus
    Status_OK = 0: Status_GenericError = 1: Status_InvalidParameter = 2: Status_OutOfMemory = 3: Status_ObjectBusy = 4: Status_InsufficientBuffer = 5
    Status_NotImplemented = 6: Status_Win32Error = 7: Status_WrongState = 8: Status_Aborted = 9: Status_FileNotFound = 10: Status_ValueOverflow = 11
    Status_AccessDenied = 12: Status_UnknownImageFormat = 13: Status_FontFamilyNotFound = 14: Status_FontStyleNotFound = 15: Status_NotTrueTypeFont = 16
    Status_UnsupportedGdiplusVersion = 17: Status_GdiplusNotInitialized = 18: Status_PropertyNotFound = 19: Status_PropertyNotSupported = 20
End Enum
#End If
 
Type PWMFRect16: Left As Integer: Top As Integer: Right As Integer: Bottom As Integer: End Type
Public Const CF_BITMAP = 2, IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4, CF_ENHMETAFILE As Long = 14
Public Const PLANES = 14, BITSPIXEL = 12, PATCOPY = &HF00021, InterpolationModeHighQualityBicubic = 7

' Функция для получения размеров изображения

Sub ПолучениеРазмеровИзображения()
    Dim h As Single, w As Single
    file$ = "D:\картинки\pictures_20110623-l67-72kb.jpg"
 
    If GetPictureSizeNew(file$, w, h) Then
        Debug.Print "Высота: " & h & ", ширина: " & w
    Else
        Debug.Print "Не удалось загрузить размеры картинки"
    End If
End Sub

Function GetPictureSizeNew(ByVal FileName$, ByRef imgWidth As Single, ByRef imgHeight As Single) As Boolean
    On Error Resume Next:
    #If VBA7 Then
        Dim hGdiImage As LongPtr, uGdiInput As GdiplusStartupInput, hGdiPlus As LongPtr
    #Else
        Dim hGdiImage As Long, uGdiInput As GdiplusStartupInput, hGdiPlus As Long
    #End If
    uGdiInput.GdiplusVersion = 1
 
    If GdiplusStartup(hGdiPlus, uGdiInput) = Status_OK Then
        If GdipCreateBitmapFromFile(StrPtr(FileName), hGdiImage) = Status_OK Then        'Создаём изображение в памяти
            Call GdipGetImageDimension(hGdiImage, imgWidth, imgHeight)        'Получаем размеры изображения
            GdipDisposeImage hGdiImage        ' освобождаем память
        End If
        GdiplusShutdown hGdiPlus
    End If
    GetPictureSizeNew = imgWidth * imgHeight > 0
End Function

' Функция для изменения размеров картинки (можно сохранять картинку в JPG, GIF, PNG, BMP)

Sub ИзменениеРазмеровКартинки()
    On Error Resume Next: Dim file1$, file2$, i&, t&
    Dim uGdiInput As GdiplusStartupInput, hGdiPlus As Long
    uGdiInput.GdiplusVersion = 1
 
    If GdiplusStartup(hGdiPlus, uGdiInput) = Status_OK Then    'Запускаем GDI+
        ' путь к исходной картинке
        file1$ = "C:\Documents and Settings\Admin\Рабочий стол\file.jpg"
        ' имя файла для уменьшенного изображения
        file2$ = "C:\Documents and Settings\Admin\Рабочий стол\file_new.jpg"
 
        ' запускаем уменьшение картинки, задавая её новые размеры
        LoadImage file1$, file2$, 150, 100
        GdiplusShutdown hGdiPlus
    Else
        MsgBox "Ошибка при загрузке GDI+!", vbCritical
    End If
End Sub

Function LoadImage(ByVal FileName As String, ByVal newFilename As String, ByVal NewWidth&, ByVal NewHeight&) As Boolean
    On Error Resume Next
    #If VBA7 Then
        Dim hGdiImage As LongPtr, hBitmap As LongPtr, imgThumb As LongPtr, quality As LongPtr, hGdiPlus As LongPtr, uGdiInput As GdiplusStartupInput
        Dim lRes As LongPtr, lGDIP As LongPtr, tJpgEncoder As GUID, tParams As EncoderParameters
        Dim hDC As LongPtr, hBrush As LongPtr, Graphics As LongPtr, hResizedBitmap As LongPtr
    #Else
        Dim hGdiImage As Long, hBitmap As Long, imgThumb As Long, quality As Long, hGdiPlus As Long, uGdiInput As GdiplusStartupInput
        Dim lRes As Long, lGDIP As Long, tJpgEncoder As GUID, tParams As EncoderParameters
        Dim hDC As Long, hBrush As Long, Graphics As Long, hResizedBitmap As Long
    #End If
 
    uGdiInput.GdiplusVersion = 1: quality = 80
 
    If GdiplusStartup(hGdiPlus, uGdiInput) = Status_OK Then    'Запускаем GDI+

        If GdipCreateBitmapFromFile(StrPtr(FileName), hGdiImage) = Status_OK Then    'Создаём изображение в памяти
            'Делаем из изображения уменьшенное

            ' Create a memory DC and select a bitmap into it, fill it in with the backcolor
            hDC = CreateCompatibleDC(ByVal 0&)
            hBitmap = CreateBitmap(NewWidth&, NewHeight&, GetDeviceCaps(hDC, PLANES), GetDeviceCaps(hDC, BITSPIXEL), ByVal 0&)
            hBitmap = SelectObject(hDC, hBitmap)
            hBrush = CreateSolidBrush(vbWhite)
            hBrush = SelectObject(hDC, hBrush)
            PatBlt hDC, 0, 0, NewWidth&, NewHeight&, PATCOPY
            DeleteObject SelectObject(hDC, hBrush)
 
            ' Resize the picture
            GdipCreateFromHDC hDC, Graphics
            GdipSetInterpolationMode Graphics, InterpolationModeHighQualityBicubic
 
            lRes = GdipDrawImageRectI(Graphics, hGdiImage, 0, 0, NewWidth&, NewHeight&)
            GdipDeleteGraphics Graphics
            GdipDisposeImage hGdiImage
 
            ' Get the bitmap back
            hBitmap = SelectObject(hDC, hBitmap)
            DeleteDC hDC
 
            If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hResizedBitmap) = 0 Then
 
                '    Select Case PicType
                '        Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
                '        Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
                '        Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
                '        Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
                '    End Select
                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder    ' Initialize the encoder GUID
                tParams.Count = 1    ' Initialize the encoder parameters
                With tParams.Parameter    ' Quality
                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' Set the Quality GUID
                    .NumberOfValues = 1: .Type = 4: .Value = VarPtr(quality)
                End With
 
                lRes = GdipSaveImageToFile(hResizedBitmap, StrPtr(newFilename), tJpgEncoder, tParams)     ' Save the image
                If lRes = 0 Then LoadImage = True Else Debug.Print "Ошибка сохранения уменьшенного файла: " & lRes
                GdipDisposeImage hResizedBitmap    ' Destroy the bitmap
            Else
                Debug.Print "Ошибка преобразования размеров файла"
            End If
        End If
        GdiplusShutdown hGdiPlus
    Else
        Debug.Print "Ошибка при загрузке GDI+!"
    End If
End Function

31881 просмотр

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Станислав, 8 Май 2018 - 17:06.#1

Подскажите, пожалуйста, как заставить работать макрос по определению размера картинки. У меня VBA ругается на GdiplusStartupInput, говорит "User-defined type not defined"
-----------------------------------------------------------
Такая же ошибка. Все API вынесены в отдельный модуль. Заранее спасибо!

Игорь (администратор сайта), 6 Май 2018 - 14:35.#2

Станислав, спасибо что сообщили. Исправил.

Станислав, 6 Май 2018 - 14:05.#3

Не открывается вкладка "Функции WinAPI (необходимы для приведённых ниже макросов)". Проверял в Chrome и Opera.

Иии, 10 Июл 2017 - 18:34.#4

Пардон, не в x64, а в Word2013

Иии, 10 Июл 2017 - 16:45.#5

На x64 не работает функция
If GdipCreateBitmapFromFile (StrPtr(FileName), hGdiImage) = Status_OK Then
возвращает код 2 Status_InvalidParameter

Как узнать про какой параметр идет речь? есть ли возможность отладки внутри самой GdipCreateBitmapFromFile?

Игорь (администратор сайта), 14 Май 2016 - 19:44.#6

Сначала скачиваете файл на диск
http://excelvba.ru/code/DownloadFile
а потом уже у скачанного файла размеры определяете

Кроме того, для ресайза и скачивания картинок можете применять готовое решение
http://excelvba.ru/programmes/PastePictures

Ser123, 14 Май 2016 - 18:34.#7

Подскажите, пожалуйста, как получить размеры картинки вида: "http://site.com/image.jpg"
Что-то с сайта, не хочет макрос определять размеры..

Ser123, 14 Май 2016 - 16:48.#8

Спасибо, большое, я видел, но не знал, что надо вставлять перед ними, теперь всё заработало!

Игорь (администратор сайта), 14 Май 2016 - 16:41.#9

В начале статьи есть спойлер «Функции WinAPI (необходимы для приведённых ниже макросов)»
Там есть код WinAPI функций, которые надо вставить над остальными макросами, чтобы все заработало.

Ser123, 14 Май 2016 - 16:37.#10

Пожалуйста, очень надо.

Игорь (администратор сайта), 24 Апр 2015 - 07:49.#11

Excel для Androind НЕ поддерживает макросы.
Вообще никакие.

Гость, 24 Апр 2015 - 00:06.#12

Добрый вечер!
А будет ли макрос работать на андроеде если у меня есть эсель на планшете?

Игорь (администратор сайта), 23 Апр 2015 - 19:16.#13

Проблему с отображением кодов решим в течение 2-3 дней (пока не получается)

Гость, 23 Апр 2015 - 19:03.#14

Я жудко извиняюсь, код на странице не отображается.
Написано, что "Проблема с отображением кодов макросов будет решена в конце марта 2015 года". Срок продлен? Можно как-нибудь получить код? Ооооочень нужно :(

Игорь (администратор сайта), 12 Янв 2015 - 03:19.#15

Пётр, спасибо за совет насчёт DeleteObject, применю в своей программе.
Тоже сталкивался как-то с проблемой нехватки памяти

Петр, 12 Янв 2015 - 02:33.#16

при работе в цикле LoadImage забивает память http://s52.radikal.ru/i135/1501/21/17db8afda852.png
из-за чего в дальнейшем GdipCreateBitmapFromHBITMAP выдает третью ошибку

выявить на одиночном запуске функции это можно например так - LoadImage file1$, file2$, 10000, 10000
из двух обращений в память одно из них не выгружается http://s012.radikal.ru/i319/1501/7b/1fb993a8c054.png
таким образом забивая память

нужно добавить строчку в конец функции
DeleteObject hBitmap
работа станет такой http://s013.radikal.ru/i325/1501/a2/522b4a5a1055.png

Петр, 10 Янв 2015 - 22:39.#17

на х64 офисе LoadImage работает без параметра качества:
заменить
lRes = GdipSaveImageToFile(hResizedBitmap, StrPtr(newFilename), tJpgEncoder, tParams)
на
lRes = GdipSaveImageToFile(hResizedBitmap, StrPtr(newFilename), tJpgEncoder, Null)

Игорь (администратор сайта), 9 Янв 2015 - 03:03.#18

Здравствуйте, Петр.
На сайте была выложена старая версия кода - потому выскакивала ошибка.
Исправил код функции GetPictureSizeNew - теперь должно работать на 64-битной системе

Петр, 8 Янв 2015 - 23:47.#19

на 64 офисе не хочет работать (на 32 офисе работает нормально)
в чем причина?

Петр, 8 Янв 2015 - 22:19.#20

что значит "Ошибка сохранения уменьшенного файла: 2" ?

Петр, 5 Янв 2015 - 09:36.#21

на 64 офисе нужны строчки
Dim uGdiInput As GdiplusStartupInput, hGdiPlus As LongPtr
Dim hGdiImage As LongPtr, uGdiInput As GdiplusStartupInput, hGdiPlus As LongPtr

Продвинутый чайник, 27 Янв 2014 - 19:13.#22

Спасибо наиогромнейшее. То что надо.

Сергей, 6 Окт 2013 - 15:43.#23

Спасибо, проблема с качеством решена, сам бы никогда не разобрался. Мне кажется функция для изменения размеров картинки должна быть немного другой: мы задаём лишь высоту или ширину конечной картинки, а недостающий размер должна рассчитывать сама функции пропорционально исходного изображения. Но с этим я уже и сам разберусь.

Игорь (администратор сайта), 6 Окт 2013 - 14:11.#24

Переделал функцию сжатия изображений, - теперь всё работает как надо,
качество при сжатии не ухудшается.

Выложил новый код (и WinAPI функции) в статье.

Игорь (администратор сайта), 6 Окт 2013 - 06:48.#25

Здравствуйте, Сергей.

Проблема в том, что я использовал неверный подход для масштабирования (ресайза) картинок)

Описание проблемы (и метод решения) нашел на форумах:

Тут есть одна особенность. Почему функция GdipGetImageThumbnail () называется именно так, а не GdipCreateImageThumbnail()? Потому что эта функция именно извлекает встроенные эскизы, которые могут присутствовать, например, в файлах .jpg или .tif. Если таковой есть, то он масштабируется в заданные размеры, в противном случае эскиз создается из оригинального изображения. В данном примере как раз первый случай. А так как размеры встроенного эскиза небольшие (если вызвать _GDIPlus_GetImageThumbnail($CurImage, 0, 0), то получите встроенный эскиз оригинального размера), то результирующее изображение получится паршивого качества.

Если исходное изображение будет, например, в формате .png (встроенных эскизов здесь не предусмотрено), то на выходе получите изображение хорошего качества, т.к. масштабироваться будет оригинальное изображение, а не эскиз.

Как быть? Либо применить GDIPlus_BitmapCreateHBITMAPFromBitmap() + GDIPlus_BitmapCreateFromHBITMAP() перед вызовом GDIPlus_GetImageThumbnail(), тем самым автоматически избавиться от встроенного эскиза, либо, что предпочтительнее, масштабировать с помощью GDIPlus_GraphicsDrawImageRectRect().

Нашел и пример подходящего кода на VB: Load and Resize Pictures with GDI+

Как будет время, - переделаю опубликованные здесь функции

Сергей, 6 Окт 2013 - 03:02.#26

Макросы работают на Excel 2007 в 64-битной Windows 7. Но есть одна проблема, уменьшенные изображения получаются ужасного качества. Изображение размером 600х500px выглядят так, словно их сначала уменьшили до 100px, а потом увеличили. пробовал ставить параметр quality = 100. Размер картинки растёт, но качество такое же плохое. Не подскажете в чём может быть проблема?

Макросы для получения размера изображения, и создания уменьшенной копии картинки

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL