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

 

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

  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин, DrMini  
Изменение размеров графического файла
gorart Дата: Четверг, 28.04.2022, 13:44 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 1 ±
Замечаний: 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
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

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


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

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

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

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

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

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



Сообщение отредактировал 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; Тrue; 0; 0; maxSide; maxSide    Set myPicture = ТhisWorkbook.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 = ТrueEnd Sub
[/vba]

Автор - gorart
Дата добавления - 17.05.2022 в 16:47
  • Страница 1 из 1
  • 1
Поиск:

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