MyTetra Share
Делитесь знаниями!
Макросы для получения размера изображения, и создания уменьшенной копии картинки
Время создания: 16.03.2019 23:43
Текстовые метки: Работа со звуком и изображениями, Функции WinAPI Изображения,(картинки,Средства Windows
Раздел: !Закладки - VBA - Excel - Shapes

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



ВНИМАНИЕ: Данная программа использует вызов системных функций - WinAPI
Поскольку синтаксис вызова этих функций в различных версиях Windows и Office может отличаться, работа программы на всех компьютерах не гарантируется!
Все размещённые на сайте макросы тестировались в Excel 2003 - 2010 под управлением 32-битной версии Windows XP

Если вы работаете в 64-битной версии Windows, или используете Office 2010 или 2013 (в котором встроена 7-я версия VBA),
то есть вероятность, что макрос работать не будет (потребуется доработка вызова функций WinAPI)
По указанным причинам, макрос не будет работать под управлением MacOS Excel 2004, 2008, 2011 и т.п.)

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

 

Эти макросы нашли применение в универсальной надстройке для вставки картинок в 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 просмотр
Так же в этом разделе:
 
MyTetra Share v.0.53
Яндекс индекс цитирования