Troubleshooting Cut & Paste VBA code

Question

Hi,

I'm trying to create a macro to replace all pictures by JPEG images, in order to help correcting files whose authors pasted pictures as uncompressed images.

The way I do it manually is to cut and paste special as a JPEG image (which has better results than using "Compress Pictures" from the ribbon), so, for my macro, I came up with the following:

Sub ReplacePics()

Dim MyData As Object

Dim i, InlineShapeCount As Integer

Set MyData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

MyData.SetText ""

ShapeCount = Application.ActiveDocument.Shapes.Count

MyData.PutInClipboard

If InlineShapeCount > 0 Then

For i = 1 To InlineShapeCount

Application.ActiveDocument.InlineShapes.Item(i).Select

Selection.Cut

Selection.PasteSpecial Link:=False, DataType:=15

MyData.PutInClipboard

Next i

End If

MyData.PutInClipboard

Set MyData = Nothing

End Sub

Now, here's my problem. There a two errors that occur sometimes, but not systematically:

• "This method or property is not available because the Clipboard is empty or not valid": I was hoping that clearing the clipboard by putting in it an empty object, as described here, would help, but it doesn't. This seems more likely to happen if I execute the macro a second time.
• "The requested member of the collection does not exist": this happens for some files, but not others.

Does anyone have any suggestion?

Thanks!

Answer 1

Floating graphics are not in the text area of the document and cannot be handled in the same way. I'll have to think about that one.

I had a play.  This is the best I can come up with:

Sub ConvertFloatingShapesToJpg()

' Add a reference to Microsoft PowerPoint xx.0 Object Library' via VBE > Tools > References...'

    Dim pptAp As PowerPoint.Application

    Dim pptPres As PowerPoint.Presentation

    Dim pptSld As PowerPoint.Slide

    Dim pptShp As PowerPoint.Shape

    Dim bWeStartedPpt As Boolean

    Dim shp As Shape

    Dim anc As Range

    Dim dbL As Double, dbT As Double

    Dim i As Long

    Dim strPath As String

    strPath = Environ("TEMP") & "\temp.jpg"

     'Get PowerPoint object:

    On Error Resume Next

    Set pptAp = GetObject(, "PowerPoint.Application")

    On Error GoTo 0

    If pptAp Is Nothing Then

        Set pptAp = CreateObject("PowerPoint.Application")

        If pptAp Is Nothing Then

            MsgBox "Unable to start PowerPoint"

            Exit Sub

        Else

            bWeStartedPpt = True

        End If

    End If

'Create a blank presentation, add a blank slide:

    Set pptPres = pptAp.Presentations.Add

    Application.Activate 'switch back to Word, just so we can see what's going on...

    Set pptSld = pptPres.Slides.Add(1, 12) '12=ppLayoutBlank

    pptPres.Windows(1).View.Zoom = 100

'Loop backwards through each shape:    For i = ActiveDocument.Shapes.Count To 1 Step -1

        Set shp = ActiveDocument.Shapes(i)

'Record anchor-range and position of shape:        Set anc = shp.Anchor

        dbL = shp.Left

        dbT = shp.Top

'Cut the shape:        shp.Select

        Selection.Cut

'Paste shp into Ppt then export to file:        pptAp.ActiveWindow.View.PasteSpecial 5 '5=ppPasteJPG

        Set pptShp = pptSld.Shapes(1)

        pptShp.Export PathName:=strPath, Filter:=1 '1=ppShapeFormatJPG

        pptSld.Shapes.Range.Delete

'Insert the file into Word at the original anchor point:        anc.InlineShapes.AddPicture FileName:=strPath, _

            LinkToFile:=False, _

            SaveWithDocument:=True

'Convert the inline shape to floating:        ActiveDocument.InlineShapes(ActiveDocument.InlineShapes.Count).ConvertToShape

'Set size and position to originals:        With ActiveDocument.Shapes(ActiveDocument.Shapes.Count)

            .Left = dbL

            .Top = dbT

        End With

    Next i

'Tidy up:    Set pptShp = Nothing

    Set pptSld = Nothing

    pptPres.Close

    Set pptPres = Nothing

    If bWeStartedPpt Then pptAp.Quit

    Set pptAp = Nothing

End Sub

Hope that helps.

Cheers

Rich

Answer 2

For inline shapes at least the following should work

Sub ReplaceInlinePics()

Dim oRng As Range

Dim i As Long

    For i = 1 To ActiveDocument.InlineShapes.Count

        Set oRng = ActiveDocument.InlineShapes(i).Range

        ActiveDocument.InlineShapes(i).Range.Cut

        oRng.PasteSpecial Link:=False, DataType:=15

    Next i

End Sub

Floating graphics are not in the text area of the document and cannot be handled in the same way. I'll have to think about that one.

Answer 3

Making the image a JPEG picture has much better results than using this functionality.

Answer 4

Just want to check, have you tried clicking on a picture > Picture Tools Format tab > Compress Pictures > ...

and check the options for Delete cropped areas of pictures

and uncheck the option for Apply Only to this picture

??

Cheers

Rich

Answer 5

PS: to keep the text concise, I only showed a loop in the InlineShapes collection, but I also run the exact same code through the Shapes collection.