Время прочтения: 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 и пользуемся.
Кроме того, данный инструмент можно использовать для оптимизации дискового пространства на компьютере за счет уменьшения объема памяти отводящееся на все фотографии/картинки.
Спасибо за внимание!