Время прочтения: 3 мин.

Добрый день, коллеги!

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

При проведении проверки клининговой компании потребовалось в оперативном порядке сделать выезд и зафиксировать на фото текущее состояние всех объектов в части выполнения условий договора по уборке территорий. В результате выезда было сделано порядка 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 и пользуемся.

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

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