Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Изменение размеров графического файла - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Изменение размеров графического файла (Макросы/Sub)
Изменение размеров графического файла
gorart Дата: Четверг, 28.04.2022, 13:44 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

Добрый день. Работая с фильтрами imageprocess, я могу изменять размер изображения сохраняя пропорции, а чем можно воспользоваться, если я хочу добавить в фото пустого пространства? Например, есть фото 300×400, а я хочу сделать его 400×400 так, чтобы само изображение было в центре, а по бокам появилось пустое пространство в 50 пикселей.
 
Ответить
СообщениеДобрый день. Работая с фильтрами imageprocess, я могу изменять размер изображения сохраняя пропорции, а чем можно воспользоваться, если я хочу добавить в фото пустого пространства? Например, есть фото 300×400, а я хочу сделать его 400×400 так, чтобы само изображение было в центре, а по бокам появилось пустое пространство в 50 пикселей.

Автор - gorart
Дата добавления - 28.04.2022 в 13:44
RAN Дата: Четверг, 28.04.2022, 13:59 | Сообщение № 2
Группа: Друзья
Ранг: Экселист
Сообщений: 5630
Репутация: 1143 ±
Замечаний: 0% ±

2010
Работайте в фотошопе. Там это запросто.


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеРаботайте в фотошопе. Там это запросто.

Автор - RAN
Дата добавления - 28.04.2022 в 13:59
gorart Дата: Четверг, 28.04.2022, 14:32 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

RAN, отлично, а если у меня таких фото 1500, то я там жить буду.
 
Ответить
СообщениеRAN, отлично, а если у меня таких фото 1500, то я там жить буду.

Автор - gorart
Дата добавления - 28.04.2022 в 14:32
gorart Дата: Вторник, 17.05.2022, 16:47 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 0% ±

В итоге решение задачи составил самостоятельно, выкладываю может кому пригодится. Единственное, качество изображения теряется.
[vba]
Код
Sub ImgQuad()
    Dim h, w, maxSide As Long
    Dim imgName As String
    Dim myImg, myChart, myPicture, IP As Object
    Sheets.Add
    imgName = "сюда вставить путь и имя файла картинки"
    Set myImg = CreateObject("WIA.ImageFile")
    myImg.loadfile imgName
    h = myImg.Height
    w = myImg.Width
    If h > w Then maxSide = h Else maxSide = w
    ActiveSheet.Shapes.AddPicture imgName, False, True, 0, 0, maxSide, maxSide
    Set myPicture = ThisWorkbook.ActiveSheet.Shapes(1)
    myPicture.PictureFormat.Crop.PictureHeight = h
    myPicture.PictureFormat.Crop.PictureWidth = w
    Set myChart = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=maxSide, Height:=maxSide)
    myChart.ShapeRange.Line.Visible = msoFalse
    myPicture.Copy
    myChart.Activate
    ActiveChart.Paste
    myChart.Chart.Export imgName
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
    IP.Filters(1).Properties("MaximumWidth") = maxSide
    IP.Filters(1).Properties("MaximumHeight") = maxSide
    Set myImg = IP.Apply(myImg)
    Kill imgName
    myImg.SaveFile imgName
    myChart.Delete
    myPicture.Delete
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub
[/vba]


Сообщение отредактировал gorart - Вторник, 17.05.2022, 16:49
 
Ответить
СообщениеВ итоге решение задачи составил самостоятельно, выкладываю может кому пригодится. Единственное, качество изображения теряется.
[vba]
Код
Sub ImgQuad()
    Dim h, w, maxSide As Long
    Dim imgName As String
    Dim myImg, myChart, myPicture, IP As Object
    Sheets.Add
    imgName = "сюда вставить путь и имя файла картинки"
    Set myImg = CreateObject("WIA.ImageFile")
    myImg.loadfile imgName
    h = myImg.Height
    w = myImg.Width
    If h > w Then maxSide = h Else maxSide = w
    ActiveSheet.Shapes.AddPicture imgName, False, True, 0, 0, maxSide, maxSide
    Set myPicture = ThisWorkbook.ActiveSheet.Shapes(1)
    myPicture.PictureFormat.Crop.PictureHeight = h
    myPicture.PictureFormat.Crop.PictureWidth = w
    Set myChart = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=maxSide, Height:=maxSide)
    myChart.ShapeRange.Line.Visible = msoFalse
    myPicture.Copy
    myChart.Activate
    ActiveChart.Paste
    myChart.Chart.Export imgName
    Set IP = CreateObject("WIA.ImageProcess")
    IP.Filters.Add IP.FilterInfos("Scale").FilterID
    IP.Filters(1).Properties("MaximumWidth") = maxSide
    IP.Filters(1).Properties("MaximumHeight") = maxSide
    Set myImg = IP.Apply(myImg)
    Kill imgName
    myImg.SaveFile imgName
    myChart.Delete
    myPicture.Delete
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
End Sub
[/vba]

Автор - gorart
Дата добавления - 17.05.2022 в 16:47
Мир MS Excel » Вопросы и решения » Готовые решения » Изменение размеров графического файла (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!