Добрый день. Работая с фильтрами imageprocess, я могу изменять размер изображения сохраняя пропорции, а чем можно воспользоваться, если я хочу добавить в фото пустого пространства? Например, есть фото 300×400, а я хочу сделать его 400×400 так, чтобы само изображение было в центре, а по бокам появилось пустое пространство в 50 пикселей.
Добрый день. Работая с фильтрами imageprocess, я могу изменять размер изображения сохраняя пропорции, а чем можно воспользоваться, если я хочу добавить в фото пустого пространства? Например, есть фото 300×400, а я хочу сделать его 400×400 так, чтобы само изображение было в центре, а по бокам появилось пустое пространство в 50 пикселей.gorart
В итоге решение задачи составил самостоятельно, выкладываю может кому пригодится. Единственное, качество изображения теряется.
Sub ImgQuad() Dim h, w, maxSide AsLong Dim imgName AsString Dim myImg, myChart, myPicture, IP AsObject
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 EndSub
В итоге решение задачи составил самостоятельно, выкладываю может кому пригодится. Единственное, качество изображения теряется.
Sub ImgQuad() Dim h, w, maxSide AsLong Dim imgName AsString Dim myImg, myChart, myPicture, IP AsObject
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 EndSub