VBA to select shapes/images and save as image

[dsimeoni]

Hi,

I'm working on a macro to automate the resizing of a large number of images. I need to resize the images so they are a square of fixed dimensions. The manual way I have done this in the past is to create a white square in powerpoint, resize the image so it fits within the square then select both the square and the image and 'save as picture' via right click. I've managed to get as far as importing each image into a PowerPoint file on a separate slide, resizing the image and creating a square of the correct size behind the image. I'm struggling to run through the slides one by one, select both the square and the image and save it as a picture. The code I've written so far is below. I'd be extremely grateful for any help anyone can offer.

Thanks in advance,

Simon


Sub BPlogos()

Dim File_Cnt, Sld_Cnt, Sld_Pos As Long
Dim Source_Dir, File_Name, Path_Complete, Ext_3, Ext_4 As String
Dim sldNewSlide As Slide
Dim logo As Shape
Dim tmpWidth, tmpHeight, W_H_pic, W_H_sld, lngSldHeight, lngSldWidth As Double
Dim Pre As Presentation
Dim sld As Slide
Dim shp As Shape
Dim box As Shape
Dim boxSz As Integer

File_Cnt = 0
Sld_Cnt = 0
boxSz = 80.5

Source_Dir = InputBox("Location of images, End with / (: for Macintosh)", "Image Directory")

If Len(Source_Dir) = 0 Or IsNull(Source_Dir) Then GoTo No_Input_Exit
On Error GoTo No_Input_Exit
File_Name = Dir(Source_Dir, vbNormal)
While Len(File_Name) <> 0
File_Cnt = File_Cnt + 1
Ext_3 = UCase(Right(File_Name, 3))

If Ext_3 = "JPG" Then
Sld_Cnt = Sld_Cnt + 1
Path_Complete = Source_Dir & File_Name
Sld_Pos = ActivePresentation.Slides.count
Set sldNewSlide = ActivePresentation.Slides.Add(Index:=Sld_Pos + 1, Layout:=ppLayoutBlank)
Set logo = sldNewSlide.Shapes.AddPicture(FileName:=Path_Complete, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=100, Height:=100)
logo.Name = "logo" & Sld_Pos

Set box = ActivePresentation.Slides(Sld_Cnt + 1).Shapes.AddShape(msoShapeRectangle, 10, 10, boxSz, boxSz)
box.Fill.ForeColor.RGB = RGB(255, 255, 255)
box.Line.BackColor.RGB = RGB(255, 255, 255)
box.ZOrder msoSendToBack
box.Name = "box" & Sld_Pos

logo.LockAspectRatio = True
logo.ScaleHeight 1#, msoCTrue
logo.ScaleWidth 1#, msoCTrue
lngSldWidth = ActivePresentation.PageSetup.SlideWidth
lngSldHeight = ActivePresentation.PageSetup.SlideHeight

tmpWidth = logo.Width
tmpHeight = logo.Height
W_H_pic = tmpWidth / tmpHeight
W_H_sld = lngSldWidth / lngSldHeight
If W_H_pic >= W_H_sld Then
logo.Width = boxSz
Else
logo.Height = boxSz
End If
tmpWidth = logo.Width
tmpHeight = logo.Height
logo.Top = (lngSldHeight - tmpHeight) / 2
logo.Left = (lngSldWidth - tmpWidth) / 2
box.Top = (lngSldHeight - box.Height) / 2
box.Left = (lngSldWidth - box.Width) / 2

' sld.Shapes.Range(Array(box.Name, logo.Name)).Group

End If


File_Name = Dir()

Wend

No_Input_Exit:
MsgBox "Input Directory=" & Source_Dir & Chr(13) & Chr(10) & _
"Total Files=" & File_Cnt & "Slides Added=" & Sld_Cnt, vbOKOnly, "Results"
End Sub

[John Wilson]

See if this is start for you

Sub BPLogos()
Dim strSource_Dir As String
Dim strFileSpec As String
Dim strFileName As String
Dim opres As Presentation
Dim obox As Shape
Dim oLogo As Shape
Dim osld As Slide
Dim oshp As Shape
Dim BxSize As Single
Dim savename As String
BxSize = 80.5

Set opres = ActivePresentation
strFileSpec = "*.jpg"
strSource_Dir = InputBox("Location of images, End with / (: for Macintosh)", "Image Directory")
strFileName = Dir$(strSource_Dir & strFileSpec)

While strFileName <> ""
Set osld = opres.Slides.Add(opres.Slides.Count + 1, ppLayoutBlank)
Set obox = osld.Shapes.AddShape(msoShapeRectangle, 10, 10, BxSize, BxSize)
With obox
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.Visible = False
End With
Set oLogo = osld.Shapes.AddPicture(FileName:=strSource_Dir & strFileName, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, Top:=0, Width:=True, Height:=True)
oLogo.Name = "Logo" & osld.SlideIndex
If oLogo.Height / oLogo.Width > 1 Then
oLogo.Height = obox.Height
Else: oLogo.Width = obox.Width
End If
ActiveWindow.View.GotoSlide (osld.SlideIndex)
oLogo.Select True
obox.Select False
With ActiveWindow.Selection.ShapeRange
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.Group.Select
End With
ActiveWindow.Selection.ShapeRange.Name = "Togo" & osld.SlideIndex
osld.Shapes("Togo" & CStr(osld.SlideIndex)).Export Environ("USERPROFILE") & "\Desktop\" & "Togo" & osld.SlideIndex & ".JPG", ppShapeFormatJPG, 100, 100
strFileName = Dir()
Wend
End Sub

[dsimeoni]

Thank you very much John! This is really great.

I do have two questions though. What do the image dimensions you have set to 100 x 100 equate to? When I view the images the macro generates they are tiny so I increased the measurements to 1000 x 1000 however the exported image is not square, it comes how taller than it is wide. Ideally I'd like to be able to export the images to they are the same size they've been resized to on the PowerPoint page.

The other question I have is how can I export them to a specific location. I wasn't successful in substituting some of the text after the .export or environ() with the path. Ideally it would be a sub-folder in the same folder the original logos were taken from - the path to the original folder should be held in the strSource_Dir variable. (e.g. //slonq100f/Data/logos/Resized/).

Thanks again!

Simon