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

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

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

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

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

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

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

• 17821 просмотр