White space in Export vs. Saveas

[wein3967]

Hello everyone. I am trying to figure out the particulars for exporting sets of shapes (without surrounding whitespace) on a slide. Essentially, my working code is as follows:

Public Sub CreateSlides()
Dim I As Integer
Dim ReferenceSlide As PowerPoint.Slide
Dim PowerPointSlide As PowerPoint.Slide
Dim PowerPointPicture As PowerPoint.Shape
Dim ContourLegend As PowerPoint.Shape
Dim ObjectLegend As PowerPoint.Shape
Dim LargestDimension As String
Dim NewFileName As String

Call GetPictureList 'Generates array of picture file paths

Set ReferenceSlide = ActivePresentation.Slides(1)

For I = 0 To UBound(PictureList)
Set PowerPointSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)

Set PowerPointPicture = PowerPointSlide.Shapes.AddPicture(FileName:=PictureList(I), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)

'Doing stuff
'this
'that
'etc.

'Export slide as picture
NewFileName = RemoveExtension(PictureList(I))

'Method 1
PowerPointSlide.Export NewFileName & ".png", "png"

'Method 2
ActiveWindow.Selection.SlideRange(PowerPointSlide.SlideIndex - 1).Select
ActiveWindow.Panes(2).Activate
ActiveWindow.Selection.SlideRange(PowerPointSlide.SlideIndex - 1).Shapes.SelectAll
ActivePresentation.SaveAs _
FileName:=NewFileName, _
FileFormat:=ppSaveAsPNG, _
EmbedTrueTypeFonts:=msoFalse
Next I
End Sub


In a nutshell, the code gets a set of user selected files and iteratively, adds them to a new blank slide, does some moving around, and then exports the slide. The code works great while using method 1, however there is a bunch of extra white space surrounding the shapes and picture (as you would see on the PowerPoint slide itself). Method 2 is my VBA recreation of selecting a slide, doing a select all, and using right-click "Save as Picture." Manually performing method 2 gives me an image without the extra white space (just the bounds of the shape group). The VBA version of method 2 ends up exporting the existing presention for each iteration (each picture with white space).

Does anyone know how I can perform a "Save as Picture" programmatically in the loop without getting the extra white space? :think: Thanks for any help or direction you can give me.

[wein3967]

So, I am checking back in on this issue. It is still a problem for me :banghead:. Does anyone know how to programmatically perform a Select All, Right-Click, then Save As Picture? Thanks.

[John Wilson]

You need to use the hidden method Shaperange.Export

In the vbe View>Object Brower and Right click to enable hidden members

You will now be able to use

With ActiveWindow.Selection.ShapeRange(1)
.Export filename&path.png, ppShapeFormatPNG
End With


Hello everyone. I am trying to figure out the particulars for exporting sets of shapes (without surrounding whitespace) on a slide. Essentially, my working code is as follows:

Public Sub CreateSlides()
Dim I As Integer
Dim ReferenceSlide As PowerPoint.Slide
Dim PowerPointSlide As PowerPoint.Slide
Dim PowerPointPicture As PowerPoint.Shape
Dim ContourLegend As PowerPoint.Shape
Dim ObjectLegend As PowerPoint.Shape
Dim LargestDimension As String
Dim NewFileName As String

Call GetPictureList 'Generates array of picture file paths

Set ReferenceSlide = ActivePresentation.Slides(1)

For I = 0 To UBound(PictureList)
Set PowerPointSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)

Set PowerPointPicture = PowerPointSlide.Shapes.AddPicture(FileName:=PictureList(I), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)

'Doing stuff
'this
'that
'etc.

'Export slide as picture
NewFileName = RemoveExtension(PictureList(I))

'Method 1
PowerPointSlide.Export NewFileName & ".png", "png"

'Method 2
ActiveWindow.Selection.SlideRange(PowerPointSlide.SlideIndex - 1).Select
ActiveWindow.Panes(2).Activate
ActiveWindow.Selection.SlideRange(PowerPointSlide.SlideIndex - 1).Shapes.SelectAll
ActivePresentation.SaveAs _
FileName:=NewFileName, _
FileFormat:=ppSaveAsPNG, _
EmbedTrueTypeFonts:=msoFalse
Next I
End Sub


In a nutshell, the code gets a set of user selected files and iteratively, adds them to a new blank slide, does some moving around, and then exports the slide. The code works great while using method 1, however there is a bunch of extra white space surrounding the shapes and picture (as you would see on the PowerPoint slide itself). Method 2 is my VBA recreation of selecting a slide, doing a select all, and using right-click "Save as Picture." Manually performing method 2 gives me an image without the extra white space (just the bounds of the shape group). The VBA version of method 2 ends up exporting the existing presention for each iteration (each picture with white space).

Does anyone know how I can perform a "Save as Picture" programmatically in the loop without getting the extra white space? :think: Thanks for any help or direction you can give me.

[wein3967]

John,

Thanks a bunch :thumb. That was definitely a big part of the trick that I was missing. I honestly was never aware that there were hidden members.

I have been messing around the code, and I just can't seem to get the slide reference just right. I moved the slide export code to a Sub. I was hoping I could just pass a reference to the slide I want to export. Then the Sub would select the objects on the slide and export them as a picture. The select all and exporting is working fine. It just keeps grabbing the wrong slide. I am sure it has to do some of my confusion with the PowerPoint object model.


Private Sub SaveAsPicture(ByVal CurrentSlide As Slide, ByVal FilePath As String)

ActivePresentation.Slides.Range(CurrentSlide.SlideIndex).Select
ActiveWindow.Selection.SlideRange(1).Select
ActiveWindow.Panes(2).Activate
ActiveWindow.Selection.SlideRange(1).Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

End Sub

I also tried using the following, but I get a runtime error saying there isn't a 2 in the range 1 to 1.


Private Sub SaveAsPicture(ByVal CurrentSlide As Slide, ByVal FilePath As String)

ActivePresentation.Slides.Range(CurrentSlide.SlideIndex).Select
ActiveWindow.Selection.SlideRange(CurrentSlide.SlideIndex).Select
ActiveWindow.Panes(2).Activate
ActiveWindow.Selection.SlideRange(CurrentSlide.SlideIndex).Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

End Sub

I'd appreciate any help you can offer.

[John Wilson]

Is this the current slide in edit view or in slideshow view?

[wein3967]

It is in Edit View. I loop through an array of pictures and create a slide, add some legends, and then export the slide. My first slide just holds all of the different legends that can be used.

[John Wilson]

Assuming that you have referenced the current slide something like

Dim currentslide As Slide
Set currentslide = ActiveWindow.View.Slide
Then try
Sub export_as_png(currentslide As Slide, filepath As String)
currentslide.Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export filepath, ppShapeFormatPNG
End Sub

[wein3967]

I reference the slide I am passing like this:

Dim PowerPointSlide As PowerPoint.Slide

Set PowerPointSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)
The runtime did not like the line:

CurrentSlide.Shapes.SelectAll
The error I get on the above line is "Shapes (unknown member): Invalid request. To select a shape, its view must be active"

My current trimmed down program looks like this:

Public Sub CreateSlides()

'Positions and height/width are in pixels
'1" = 72 pixels

Dim I As Integer
Dim ReferenceSlide As PowerPoint.Slide
Dim PowerPointSlide As PowerPoint.Slide
Dim PowerPointPicture As PowerPoint.Shape
Dim ContourLegend As PowerPoint.Shape
Dim ObjectLegend As PowerPoint.Shape
Dim FileName As String

Call GetPictureList

Set ReferenceSlide = ActivePresentation.Slides(1)

For I = 0 To UBound(PictureList)
Set PowerPointSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)

PowerPointSlide.Name = Format(I, "00")

Set PowerPointPicture = PowerPointSlide.Shapes.AddPicture(FileName:=PictureList(I), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)

'Omitted for brevity
'Scale and center picture
'
'
'Add legends by copying from ReferenceSlide and pasting to PowerPointSlide
'
'

FileName = RemovePathExtension(PictureList(I))

'Write file name to notes section
Call WriteNotes(PowerPointSlide, FileName)

'Export slide as picture
Call SaveAsPicture(PowerPointSlide, PictureList(I))

Next I

End Sub

Private Sub GetPictureList()

'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim I As Integer

'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = True
fd.Title = "Select Picture Files"
fd.Show

ReDim PictureList(fd.SelectedItems.Count - 1)

'Write picture paths to array
For I = 0 To UBound(PictureList)
PictureList(I) = fd.SelectedItems(I + 1)
Next I

End Sub

Private Sub WriteNotes(ByVal CurrentSlide As Slide, ByVal FileName As String)

Dim Shp As Shape
With CurrentSlide.NotesPage
For Each Shp In .Shapes
If Shp.Type = msoPlaceholder Then
If Shp.PlaceholderFormat.Type = ppPlaceholderBody Then
Shp.TextFrame.TextRange.Text = FileName
Exit For
End If
End If
Next
End With

End Sub


Private Sub SaveAsPicture(ByVal CurrentSlide As Slide, ByVal FilePath As String)

CurrentSlide.Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

' ActivePresentation.Slides.Range(CurrentSlide.SlideIndex).Select
' ActiveWindow.Selection.SlideRange(1).Select
' ActiveWindow.Panes(2).Activate
' ActiveWindow.Selection.SlideRange(1).Shapes.SelectAll
' ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

End Sub


Private Function RemovePathExtension(ByVal FilePath As String) As String

Dim TempArray() As String

TempArray = Split(FilePath, "\")
RemovePathExtension = Left(TempArray(UBound(TempArray)), Len(TempArray(UBound(TempArray))) - 4)

End Function

[wein3967]

Finally! I found the code snippet that makes it all work. See the working Sub below:

Private Sub SaveAsPicture(ByVal CurrentSlide As Slide, ByVal FilePath As String)

ActiveWindow.View.GotoSlide CurrentSlide.SlideIndex 'This is the trick :)
ActiveWindow.Selection.SlideRange(1).Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

End Sub
This thread is solved! :yes (I am not sure how to mark it as solved, though)

[twz2004]

Finally! I found the code snippet that makes it all work. See the working Sub below:

Private Sub SaveAsPicture(ByVal CurrentSlide As Slide, ByVal FilePath As String)

ActiveWindow.View.GotoSlide CurrentSlide.SlideIndex 'This is the trick :)
ActiveWindow.Selection.SlideRange(1).Shapes.SelectAll
ActiveWindow.Selection.ShapeRange.Export Left(FilePath, Len(FilePath) - 4) & ".png", ppShapeFormatPNG

End Sub
This thread is solved! :yes (I am not sure how to mark it as solved, though)

Can you past your full final, working, code, please? I need to export each object from each slide into separate files per object so i can import them into VISIO.

Thanks!

[wein3967]

Can you past your full final, working, code, please? I need to export each object from each slide into separate files per object so i can import them into VISIO.

Thanks!

Wow, this is an old thread. I don't think my "final working code" would help you in this case based on what you are trying to do; probably just generate a bunch of confusion. It sounds like your goal is to export each shape individually from each slide of an existing PowerPoint file to a png file. So, in this case, you want to grab the slide collection (Slides) and iterate through each slide, then for each slide iterate through each shape (Shapes), and then you can use the .Export method (as I did).

[SamT]

Thread Closed. Please start a new thread.