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

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

 

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

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

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

 



' Функция для получения размеров изображения
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

Комментарии

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

при работе в цикле 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

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

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

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

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

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

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

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

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

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

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

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

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

Тут есть одна особенность. Почему функция  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+

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

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

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

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
   ___    ___   _              ____          
/ _ \ |_ _| | |__ ___ |___ \ _ _
| (_) | | | | '_ \ / __| __) | | | | |
\__, | | | | |_) | | (__ / __/ | |_| |
/_/ |___| |_.__/ \___| |_____| \__, |
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.