Powerpoint Macro - Cannot figure out how to Paste in Place (can only paste in middle)

[matt.wrobel]

Hi There,

I have written a code for work in VBA (I am a beginner) and would like to take content from each slide and paste the slide content as a PNG. Essentially the intent is to "Lock" the deck so that anyone who has access cannot modify the information.

Anyway, the code works great in that it will select all> cut all information>delete anything left on the slide>paste as PNG. However, I have not been able to figure out how to paste in the original position that everything was in. By default I set a paste in the middle. When I have a deck that is 170 slides, it can be annoying to have to review the position of each and every slide.

My guess is that I may need to set a reference point when I first highlight everything, but I have no idea how to do this and utilize this position as a spot to paste.

Here is my code:

Sub test()
Dim sld As Slide
Dim pre As Presentation

Set pre = ActivePresentation

For Each sld In pre.Slides
sld.Shapes.Range.Cut

If sld.Shapes.Count > 0 Then
sld.Shapes.Range.Delete
sld.Shapes.PasteSpecial ppPastePNG
' Need to figure out how to paste in place here
sld.Shapes.Range.Align msoAlignCenters, msoTrue
sld.Shapes.Range.Align msoAlignMiddles, msoTrue
End If

If sld.Shapes.Count = 0 Then
sld.Shapes.PasteSpecial ppPastePNG
' Need to figure out how to paste in place here
sld.Shapes.Range.Align msoAlignCenters, msoTrue
sld.Shapes.Range.Align msoAlignMiddles, msoTrue
End If

Next
End Sub

I appreciate the help!!

[TnTinMN]

Perhaps the effect will be more appealing if you copy the whole slide?
Something like this:

   Dim sld As Slide
   Dim pre As Presentation

   Set pre = ActivePresentation
   
   If pre.Slides(2).Shapes.Count > 0 Then pre.Slides(2).Shapes.Range.Delete
      
   pre.Slides(1).Copy
   pre.Slides(2).Shapes.PasteSpecial ppPasteJPG
   With pre.Slides(2).Shapes(1)
      .Left = 0
      .Top = 0
      .Width = pre.Slides(2).Master.Width
      .Height = pre.Slides(2).Master.Height
   End With

Note that I copied from slide1 to slide2.

[matt.wrobel]

Hmmm, I would copy the whole slide, but there are many instances where the slide has either comments OR hyperlinks. At this point it would be faster to go through each slide and readjust the pasted PNG rather than copying the entire slide.

[3com]

Since....
the PasteSpecial method returns a ShapeRange object representing the shape range that was pasted.
You can work with Left and Top properties.

[matt.wrobel]

^3com - that was what I was thinking about: when I initial select all the shapes, I can identify the farther left and top corner point as a position, and then reference this position when doing the pasting. However, I have no idea how to identify or code this position...

[3com]

I can identify the farther left and top corner point as a position

Then store those values into variables and pass them to left and top properties. Something like.....
iniLeft= ' The value you can get
iniTop= 'Idem

With Windows(1).Selection.ShapeRange(1)
.left=iniLeft
.top=iniTop
End With

[matt.wrobel]

Hmmmm ok, I understand. Once I do the select-all code, would I need to add a Dim feature right after, so that each slide has its own unique Dim feature?

Dim sld as Slide
Dim pre as Presentation

set pre = activepresentation

For each sld in pre.slides
sld.shapes.selectall
'Add code here to define what top position is (eg. Dim sld.shapes.select.shaperange.top as initop)
'Add code here to define what left position is (eg. Dim sld.shapes.select.shaperange.left as inileft)
sld.shapes.range.cut

If sle.shapes.count > 0 Then
sld.shapes.range.delete
sld.shapes.paste special ppPastePNG
sld.shapes.range.align inileft
sld.shapes.range.align initop
End If

If sld.shapes.count = 0 Then
sld.shapes.pastespecial ppPastePng
sld.shapes.range.align inileft
sld.shapes.range.align initop
End If
Next
End Sub

[3com]

this code does work for you? try it and let us know.
If you loop through all shapes, you can capture Left and Top, and stor those value into variables, after use those variables to set new Left and Top. Since I do no see slides, only can imagine scenario.

[matt.wrobel]

Unfortunately the code does not work for me - I keep getting a compiling error that highlights ".top" in the set initop portion. Not too sure if my code is defining the position of the slide....Here is my attend at the code to set the variables:

[vbfbryce]

your set statement should be more like:

iniTop = sld.Shapes(1).Top

[matt.wrobel]

^vbfbryce - Nope, still doesn't work. Still identifies a compile error at the ".top" portion.

[3com]

Bryce, you are right.

Well, try this one....

Sub test()
Dim i as integer
Dim sld As Slide
Dim pre As Presentation
Set pre = ActivePresentation

For i = 1 To pre.Slides.Count
    initop = pre.Slides(i).Shapes(1).Top
    inileft = pre.Slides(i).Shapes(1).Left
    pre.Slides(i).Select
    pre.Slides(i).Shapes.SelectAll
    pre.Slides(i).Shapes.Range.Cut
    pre.Slides(i).Shapes.PasteSpecial ppPastePNG
    pre.Slides(i).Shapes(1).Top = initop
    pre.Slides(i).Shapes(1).Left = inileft
Next i

End Sub

HTH

[matt.wrobel]

Hmmm, still doesn't work. It seems that it is reconizing "top" and "left" as the top-left of the actually slide-deck itself (see the attached picture), not the top-left of the shape selection.

[3com]

It works for me. The only difference is than I used 3 blank slides(disseny), to test it.
Did you tried my code without add anything?

[matt.wrobel]

^3Com - I' m not too sure what you mean by trying code without add anything and using blank slides? Are you testing with content in the deck?

Also, is there a reason why you are using slides(i).shapes(1) as opposed to slides(i).shapes???

[vbfbryce]

you can't use "shapes" because that is an arrary (collection?). you have to give it an index (x).

[vbfbryce]

try the attached example

[matt.wrobel]

Hmmm, ok, I may need a layman's explaination for what an array is, but in any case, would there be a reason why it is not recognizing the indicated position of the highlighted shapes? It seems that even when I delete "pre.Slides(i).Shapes(1).Top = initop" and "pre.Slides(i).Shapes(1).Left = inileft", the code goes through but pastes the image in the exact same position in the top left-hand corner. It is as if it is not recognizing the values of initop or inileft.

Am I missing something key here?

[vbfbryce]

if you run the code in "break mode," what are the values of "initop" and "inileft" at that point?

[matt.wrobel]

What is interesting is that when I choose .top = 100 or .left = 100, the image is pasted in this exact location, but when I choose initop or inileft, the value isn't recognized.

[vbfbryce]

again, what are the values of "initop" and "inileft" when you run in break mode?

[matt.wrobel]

Apologies, but I have no idea where/what break mode is. Does it refer to the "pause button" near the top of the toolbar?

When I press the run button, press Ctrl+Break does not indicate the values of initop or inileft either. How exactly would I find the values via Break Mode?

[vbfbryce]

put the word "stop" after your "For i..." line, then the code will pause when it hits that line. You can step through line by line by using the F8 key. When you hover over a variable, it will show its value at that time.

[matt.wrobel]

AH ok, gotcha.

In the first two lines with "initop" and "inileft", the values are 18 and 35.704.

In the last 2 lines with "pre.slides...... = initop" and "pre.slides...... = inileft", the values are 185.625 and 54.

[vbfbryce]

so it should be pasting there, then...

[TnTinMN]

Sheesh!! this got busy.

Hmmm, I would copy the whole slide, but there are many instances where the slide has either comments OR hyperlinks. At this point it would be faster to go through each slide and readjust the pasted PNG rather than copying the entire slide.

I have not observed that comments get copied into the image, but your statement about the hyperlinks was a curve ball. It took a bit of research, but I think I got that figured out (maybe ).

Here is my test code. It is limited to only processing the first slide, but nothing prevents you from putting it in a loop to process all slides.

Sub SlideToImages()
 
   Dim pre As Presentation
   Set pre = ActivePresentation
   Dim sld As Slide
   
   Dim shp As Shape
   Set sld = pre.Slides(1)
   
   Dim pasteshp As Shape
 
   Dim i As Integer
   For i = sld.Shapes.Count To 1 Step -1
   
      Set shp = sld.Shapes(i)
      shp.Copy
      Set pasteshp = sld.Shapes.PasteSpecial(ppPasteJPG).Item(1)
      With pasteshp
         .Top = shp.Top
         .Left = shp.Left
         .Width = shp.Width
         .Height = shp.Height
         Call CloneActionSettings(shp, pasteshp, ppMouseOver)
         Call CloneActionSettings(shp, pasteshp, ppMouseClick)
      End With
      shp.Delete
      
   Next i
   
   sld.Layout = ppLayoutBlank ' prevent automatic shapes from repopulating
   
End Sub
 
Private Sub CloneActionSettings(sourceShape As Shape, destinationShape As Shape, ppmouse As PpMouseActivation)
   Dim dest As ActionSetting
   Set dest = destinationShape.ActionSettings(ppMouseClick)
   Dim src As ActionSetting
   Set src = sourceShape.ActionSettings(ppMouseClick)
   dest.Action = src.Action
   dest.AnimateAction = src.AnimateAction
   If src.Action <> ppActionNone Then
      On Error Resume Next
    
      Select Case src.Action
         Case ppActionEndShow
         Case ppActionFirstSlide
         Case ppActionHyperlink
            dest.Hyperlink.Address = src.Hyperlink.Address
            dest.Hyperlink.EmailSubject = src.Hyperlink.EmailSubject
            dest.Hyperlink.ScreenTip = src.Hyperlink.ScreenTip
            dest.Hyperlink.ShowAndReturn = src.Hyperlink.ShowAndReturn
 
            dest.Hyperlink.SubAddress = src.Hyperlink.SubAddress
            dest.Hyperlink.TextToDisplay = src.Hyperlink.TextToDisplay
         Case ppActionLastSlide
         Case ppActionLastSlideViewed
         Case ppActionMixed
         Case ppActionNamedSlideShow
            dest.SlideShowName = src.SlideShowName
         Case ppActionNextSlide
         Case ppActionOLEVerb
            dest.ActionVerb = src.ActionVerb
         Case ppActionPlay
         Case ppActionPreviousSlide
         Case ppActionRunMacro, ppActionRunProgram
            dest.Run = src.Run
            dest.AnimateAction = src.AnimateAction
         
      End Select
      On Error GoTo 0
   End If
 
End Sub

[matt.wrobel]

Hmmmm, the code still doesn't work - it doesn't even seem to convert the first slide as a PNG. Also, after going through some of the slides of my presentation it looks like it keeps setting initop and inileft with different positions (ie. sometimes it pastes the PNG in the bottom of the screen, sometimes at the top left, sometimes closer to the right). It is quite varied.

I think there is a bug that is occurring when the position of initop and inileft is being defined. Eg. If there are 3 shapes (see above), which shape defines top and left? Is it the one of the middle left or it is the one on the top right. I think this is throwing things off.

I'll attached some slides tomorrow to show you what mean.

[3com]

I think there is a bug that is occurring when the position of initop and inileft is being defined. Eg. If there are 3 shapes (see above), which shape defines top and left? Is it the one of the middle left or it is the one on the top right. I think this is throwing things off.

You loop through each shape and capture their left+top properties storing them in two variables.
After that you copy & paste each one in the same position it was before, using for that the variables storing the old shape position.

Because there are 3 shapes, yo do...

for i = 1 to 3 ' If you ignore how many shapes are there, then you use: shapes.count
' now we store left and top in a variable
inileft=shapes(i).left
inTop=shapes(i).top

'Now that we've those values, we lets cut and paste shape
Shapes(i).Range.Cut
shapes(i).pastespecial ppPastePng

'Now we've the shapes pasted, but not the right position. We force it to old position.
shapes(i).left=inileft
shapes(i)top=iniTop

Notice till now we are working with shape 1. In the next iteration we'll work with the next shape, and so on...
In this way, we cut, paste and positioning one by one all the shapes.

Did you get the point now?

[matt.wrobel]

^3Com - I see what you mean, but the issue here is that I need to do a cut of all the shapes at once and then paste as a single PNG, not as separate small PNGs. That is why I am recognizing the error of utilizing which shapes as the reference point.

It seems that when I copy and paste an image from one powerpoint to a new powerpoint file, the original location is preserved, but when I copy and paste within the same powerpoint file, this is where the off-set occurs. I think if I can figure out the code that retains the position from one powerpoint to the other, I would be in great shape.

[3com]

but the issue here is that I need to do a cut of all the shapes at once and then paste as a single PNG, not as separate small PNGs

http://msdn.microsoft.com/en-us/libr...ice.14%29.aspx

Try this one...

Sub test1()

Dim sld As Slide
Dim pre As Presentation
Set pre = ActivePresentation

For i = 1 To pre.Slides.Count
    pre.Slides(i).Select
    pre.Slides(i).Shapes.SelectAll
    inileft = Windows(1).Selection.ShapeRange.Left
    initop = Windows(1).Selection.ShapeRange.Top
    Windows(1).Selection.ShapeRange.Cut
    pre.Slides(i).Shapes.PasteSpecial ppPastePNG
    pre.Slides(i).Shapes(1).Top = initop
    pre.Slides(i).Shapes(1).Left = inileft
Next i

End Sub

HTH

[matt.wrobel]

Nope, still doesn't work. After running it in break mode, the position of left and top (relative to the image below after doing a Select All) are both valued at "-2.147484E+09".

It gives me a Runtime error "-2.147024809 (80070057).... the specified value is out of range".

THis error seems to occur even when I delete particular slides.

[TnTinMN]

When you discounted my original solution and mentioned the hyperlinks, I thought you meant that you wanted to preserve that functionality. That actually made sense. However, it is apparent now that you want to convert each slide to a single image that destroys all transitions and other features.

The following is based on 3Com's suggestion, but computes the most top-left position occupied by the shapes on the slide. This is the coordinate that you want.

Dim sld As Slide
   Set sld = ActivePresentation.Slides(1)
   
   Dim sr As ShapeRange
   Set sr = sld.Shapes.Range
 
   If sr.Count > 0 Then
      ' determine the most Top-Left coordinate of all the shapes
      
      Dim x As Long
      Dim y As Long
      ' initialize comparison parameters to 1st shape
      x = sr.Item(1).Left
      y = sr.Item(1).Top
      
      ' compare to remaining shapes in collection
      Dim i As Integer
      For i = 2 To sr.Count
         If sr.Item(i).Top < y Then
            x = sr.Item(i).Left
            y = sr.Item(i).Top
         End If
      Next
      
      sr.Cut
      Set sr = sld.Shapes.PasteSpecial(ppPasteJPG)
      
      ' set position
      sr.Left = x
      sr.Top = y
      sld.Layout = ppLayoutBlank ' prevent automatic shapes from repopulating
   End If

However let's go back to your original stated goal.

Essentially the intent is to "Lock" the deck so that anyone who has access cannot modify the information.

Why not just make the presentation Read-Only? This way you preserve all the work that the presentation's creator put into defining transitions and such. If anyone did what this will do to one of my presentations, well lets say I would not be very pleased with them and they would very well know that fact.

Additionally, converting the slide to an image in no way prevents someone from altering that image. They can still save/edit/replace it. I know that a password lock on modifications is also not full-proof, but at least it does not muck with the presentation.

[matt.wrobel]

Yes, I'm some instances I would actually need to manually reinsert the hyperlinks (ie. paste the PNG image, then add on top a shape that is transparent and links to a part of the slide). However, yes, at the moment my main concern is simply pasting the information as a single PNG in it's original location.

To help understand where I am coming from with the request, I work in the healthcare industry and there are instances where we would need to present sensitive information to individuals that, if modified without us knowing, could lead to some huge issues. Eg. someone takes the information, modified it a bit, is perceived in the wrong way, we get in trouble because someone was negatively affected as a result. Locking as a PNG and having a read-only is a necessary risk-mitigation step.

Here is the reason why I can't do read-only: sometimes my colleagues need to create their own slideshows, but need information from particular decks. Now they do have access to read-only versions of the decks through our in-house system, but if for any reason they need to go ahead and move slides around or cut slides out or do something else so that they can tailor the information to whomever they are presentating the information to, we need to give them an option to this hence locking the PNG.

I'll play around with the code a bit, but from a first glance it works great other than shifting things just a bit to the right... (about 2 cm)