Уменьшаем фотографии методами VBA

Во время проведения проверки, нам потребовалось в оперативном порядке зафиксировать на фото текущее состояние всех объектов. Объем отснятого материала составил — 900 Мб. Сегодня расскажем о том, как нам удалось уменьшить общий размер до 5 Мб, используя VBA?

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

При проведении проверки клининговой компании потребовалось в оперативном порядке сделать выезд и зафиксировать на фото текущее состояние всех объектов в части выполнения условий договора по уборке территорий. В результате выезда было сделано порядка 300 фотографий. При среднем весе одной фотографии в 3 Мб общий объем всего отснятого материала составил около 900 Мб. После этого необходимо было перебросить все фотографии по почте. Но в связи с ограничением почтового сервера пришлось бы делить все фотографии на очень много писем для отправки что привело бы к задержке при передаче информации, которая нужна была еще «вчера». На помощь пришел макрос, написанный в EXCEL, который позволил уменьшить все фотографии в течении нескольких секунд до общего объема в 5 Мб. Это позволило оперативно отправить информацию и сдать проверку в установленные сроки.

Теперь подробнее остановимся на самом инструменте. Для создания нужного нам макроса открываем EXCEL переходим в «Редактор Visual Basic» (Alt+F11). Затем добавляем модуль для написания макроса:

В окне модуля записываем наш код:

Sub Уменьшаем_ФОТО() ' название макроса ' создаем переменные Dim FileName As Variant Dim Img As Object, IP As Object Dim i As Integer, j As Integer, rasmer As Integer Dim FullPath As String, Name As String, Folder As String, Name_I As String ' отключаем обновление экрана Application.ScreenUpdating = False ' задаем размер до которого будут уменьшены фотографии по бОльшей стороне в пикселях. Оптимально для того чтобы уменьшить размер и не потерять качество установить 800 пикселей. (можно подобрать под себя экспертным путем). Информация о размере будет браться с активного листа из ячейки А1. rasmer = Application.ThisWorkbook.ActiveSheet.Range("A1").Value ' запрашиваем имена файлов для уменьшения FileName = Application.GetOpenFilename _ (FileFilter:="Картинки (*.jpg), *.jpg, Все файлы (*.*), *.*", _ FilterIndex:=1, _ Title:="Выберите картинки", _ MultiSelect:=True) ' выводим сообщение в случае отмены работы с диалоговым окном If Not IsArray(FileName) Then MsgBox "Картинки не выбраны." Exit Sub End If Folder = "" ' создаем цикл по уменьшению всех фотографий For i = LBound(FileName) To UBound(FileName) ' создаем объект Windows Image Acquisition (WIA) Set Img = CreateObject("WIA.ImageFile") Set IP = CreateObject("WIA.ImageProcess") ' загружаем фотографию Img.LoadFile FileName(i) IP.Filters.Add IP.FilterInfos("Scale").FilterID ' изменяем текущий размер до заданного нами IP.Filters(1).Properties("MaximumWidth") = rasmer IP.Filters(1).Properties("MaximumHeight") = rasmer ' заменяем загруженную фотографию уменьшенной Set Img = IP.Apply(Img) On Error Resume Next ' в текущей папке создаем папку «Уменьшенные» FullPath = FileName(i) j = InStrRev(FullPath, "\") Name = Mid(FullPath, InStrRev(FullPath, "\") + 1, InStrRev(FullPath, ".") - InStrRev(FullPath, "\") - 1) If Folder = "" Then Folder = Left(FullPath, j - 1) Folder = Folder & "\Уменьшенные\": MkDir Folder End If ' записываем в папку «Уменьшенные» измененную фотографию с добавлением к имени файла значение «У_» Name_I = Folder & "\У_" & Name Do While Dir(Name_I & ".jpg") <> "" Name_I = Name_I & "+" Loop Img.SaveFile Name_I & ".tiff" Next i ' включаем обновление экрана Application.ScreenUpdating = True ' выводим сообщение о завершении работы MsgBox "Готово", vbInformation + vbOKOnly End Sub

Закрываем, сохраняем в формате *.xlsm и пользуемся.

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

Спасибо за внимание!