Как уменьшить размер фото в эксель

Как уменьшить размер фото в эксель

Argument ‘Topic id’ is null or empty

Сейчас на форуме

© Николай Павлов, Planetaexcel, 2006-2023
info@planetaexcel.ru

Использование любых материалов сайта допускается строго с указанием прямой ссылки на источник, упоминанием названия сайта, имени автора и неизменности исходного текста и иллюстраций.

ООО «Планета Эксел» ИНН 7735603520 ОГРН 1147746834949

ИП Павлов Николай Владимирович ИНН 633015842586 ОГРНИП 310633031600071

Как уменьшить размер файла Excel

При работе с файлами Excel, может сложиться ситуация, когда файл неожиданно стал весить непростительно много мегабайт, в этой статье мы рассмотрим основные методы, как возможно уменьшить размер файла Excel.

Способ 1. Удаление лишних строк в Excel

Итак, у нас есть файл из нескольких строк, который вдруг начал тормозить и весить десятки мегабайт. Самая распространенная причина – это лишние строки. Формат файла Excel устроен таким образом, что он сохраняет информацию о всех ячейках, в которых есть какие либо данные, в том числе информация о форматировании ячейки.

Нажмите комбинацию клавиш Ctrl+End, что бы переместиться в конец области с данными. Если вы переместились на строку, в которой нет нужной вам информации, то их можно удалить.

Для этого выделите строку, кликнув на ее номер левой клавишей мышки:

Далее нажмите клавишу Shift и удерживая ее, кликните на номер строки, находящейся сразу под вашей таблицей. Таким образом вы выделите лишний диапазон строк, которые нужно удалить:

Далее нажмите правой кнопкой мыши в любом месте выделенного диапазона и выберите команду «Удалить».

Теперь сохраните файл, его размер должен значительно уменьшится.

Способ 2. Удаление скрытых имен в Excel

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

Что бы удалить скрытые имена, вам понадобится следующий макрос:

Sub DeleteHiddenNames()
Dim n As Name
Dim Count As Integer
On Error Resume Next
For Each n In ActiveWorkbook.Names
If Not n.Visible Then
n.Delete
Count = Count + 1
End If
Next n
MsgBox «Скрытые имена в количестве » & Count & » удалены»
End Sub

Запустите его и подождите выполнения. После этого сохраните файл и оцените результат.

Если вы не умеете работать с макросами, то прочитайте нашу статью «Как удалить скрытые имена в Excel», в ней все подробно описано.

Способ 3. Удаление лишних стилей в Excel

Как и в случае со скрытыми именами, при копировании листов из других файлов, в ваш файл могут попасть стили, которые вы не используете, но они увеличивают размер файла.

Для того, чтобы их удалить воспользуйтесь следующим макросом:

Sub StyleKiller()
Dim N As Long, i As Long
With ActiveWorkbook
N = .Styles.Count
For i = N To 1 Step -1
If Not .Styles(i).BuiltIn Then .Styles(i).Delete
Next i
End With
MsgBox («Лишние стили удалены»)
End Sub

Запустите его, дождитесь окончания выполнения, сохраните файл.

Если вы не знакомы с макросами, то прочитайте нашу статью «Как удалить лишние стили в Excel», в ней мы подробно описали, что надо делать.

Способ 4. Уменьшение размера рисунка в Excel

Вы вставили рисунок в Excel и файл неожиданно стал весить слишком много. Это можно исправить изменением этого рисунка.

Для этого нажмите на рисунок, далее на вкладке «Формат» выберите команду «Сжать рисунки»:

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

Уменьшение размера файла рисунка в Microsoft Office

Excel для Microsoft 365 Word для Microsoft 365 Outlook для Microsoft 365 PowerPoint для Microsoft 365 Классический клиент Project Online Excel для Microsoft 365 для Mac Word для Microsoft 365 для Mac PowerPoint для Microsoft 365 для Mac Excel 2021 Word 2021 Outlook 2021 PowerPoint 2021 Project профессиональный 2021 Project стандартный 2021 Excel 2021 для Mac Word 2021 для Mac PowerPoint 2021 для Mac Excel 2019 Word 2019 Outlook 2019 PowerPoint 2019 Project профессиональный 2019 Project стандартный 2019 Excel 2019 для Mac Word 2019 для Mac PowerPoint 2019 для Mac Excel 2016 Word 2016 Outlook 2016 PowerPoint 2016 Project профессиональный 2016 Project стандартный 2016 Excel 2016 для Mac Word 2016 для Mac PowerPoint 2016 для Mac Excel 2013 Word 2013 Outlook 2013 PowerPoint 2013 Project профессиональный 2013 Project стандартный 2013 Excel 2010 Word 2010 Outlook 2010 PowerPoint 2010 Excel 2007 Word 2007 PowerPoint 2007 Excel для Mac 2011 Word для Mac 2011 PowerPoint для Mac 2011 Еще. Меньше

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

Эти функции недоступны в Microsoft 365 для Интернета, но только классические версии приложений Office.

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

Сжатие отдельных рисунков

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

1. Открыв файл в приложении Microsoft Office, выберите один или несколько рисунков для сжатия.
2. В разделе Работа с рисунками на вкладке Формат в группе Настройка выберите Сжать рисунки. Если вкладки Работа с рисунками и Формат не отображаются, убедитесь, что рисунок выделен. Дважды щелкните рисунок, чтобы выделить его и открыть вкладку Формат. В зависимости от размера экрана в группе Изменение могут отображаться только значки. В этом случае кнопка Сжать рисунки отображается без подписи.
3. Чтобы выполнить сжатие только для выбранных, а не для всех рисунков в документе, установите флажок Применить только к этому рисунку. Снятие флажка Применить только к этому рисунку перекроет любые изменения, внесенные для других отдельных рисунков в этом документе.
4. В разделе Разрешение выберите нужный вариант и нажмите кнопку ОК.

• Разрешение изображения по умолчанию в Office — 220 пикселей на дюйм. Вы можете изменить разрешение рисунка по умолчанию или отключить сжатие рисунков.
• Сжатие применяется после закрытия этого диалогового окна. Если вас не устраивают результаты, вы можете отменить изменения.
• Сжатие рисунка может привести к по-другому из-за потери деталей. Поэтому перед применением художественного эффекта необходимо сжать рисунок и сохранить файл.

Щелкните заголовки ниже, чтобы получить дополнительные сведения.

Изменение разрешения рисунка, используемого по умолчанию, во всех документах

Важно: Этот параметр применяется только к рисункам в текущем документе или в документе, выбранном из списка рядом с разделом Размер и качество изображения. Чтобы использовать его для всех новых документов, нужно выбрать другое значение в раскрывающемся списке.

Обратите внимание на то, что эта функция недоступна в Microsoft Project 2013 или Office 2007.

1. Откройте вкладку Файл.
2. Нажмите кнопку Параметры и выберите пункт Дополнительно.
3. В разделе Размер и качество изображения в раскрывающемся списке укажите, применить ли изменения к определенному документу, или применять их ко всем создаваемым документам.
4. Выберите разрешение, которое вы хотите использовать по умолчанию, и нажмите кнопку ОК.

Удаление всех данных об изменении рисунка

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

Примечание: Эта функция недоступна в Microsoft Project 2013 или Microsoft Project 2016.

1. Откройте вкладку Файл.
2. Нажмите кнопку Параметры и выберите пункт Дополнительно.
3. В разделе Размер и качество изображения выберите документ, из которого необходимо удалить данные о редактировании рисунка.
4. В разделе Размер и качество изображения установите флажок Отменить данные редактирования.

Примечание: Этот параметр применяется только к рисункам в текущем документе или в документе, выбранном из списка рядом с разделом Размер и качество изображения.

См. также

Сжатие отдельных рисунков

1. Чтобы сжать все изображения в документе, на ленте выберите Файл >Сжать рисунки (или Файл >уменьшить размер файла). Чтобы сжать только выбранные рисунки, удерживая нажатой клавишу SHIFT, щелкните рисунки, которые нужно сжать, а затем нажмите кнопку Сжать рисункина вкладке Формат рисунка .
2. Выберите параметр в поле Качество изображения . Наибольшее разрешение отображается первым, а наименьшее — последним.

Совет: Если вы обрезали какие-то из рисунков, то размер файла можно дополнительно уменьшить, установив флажок Удалить обрезанные области рисунков.

Примечание: Если вы используете менюФайл для выбора всех изображений на шаге 1, эти параметры будут недоступны. Сжатие будет применено ко всем изображениям в документе.

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

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

Там они используются для выполнения функции сжатия изображений перед вставкой
(сначала рассчитываются нужные размеры изображения на листе 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 = "" ' Case pictypeGIF: sType = "" ' Case pictypePNG: sType = "" ' Case pictypeJPG: sType = "" ' End Select CLSIDFromString StrPtr(""), tJpgEncoder ' Initialize the encoder GUID tParams.Count = 1 ' Initialize the encoder parameters With tParams.Parameter ' Quality CLSIDFromString StrPtr(""), .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

• 31042 просмотра