Compress pictures in multiple Word documents


I need to compress pictures in a great number of Word documents. Is there any way of doing this on multiple documents at once in Word 2007, or do I have to open every single document and do it manually?

Thank you in advance!
Who is Participating?
You could compress all images one by one though.
There is some code written here that works on Powerpoint...could take the same approach for Word

Could try to do it...
Sub AACompressImages() 
    Dim oSh As Shape 
    Dim lCurrSlide As Long 
    Dim SlideName 
    Dim intCurrSlide 
    Dim oSlide As Slide 
    On Error Goto errhandler 
    Set oSlide = ActivePresentation.Slides("chartmanage") 
    lCurrSlide = oSlide.SlideIndex 
    ActiveWindow.View.GotoSlide lCurrSlide 
    Set oSh = Module3.GetShapeTaggedWith("picture", "fake", oSlide) 
    If Not oSh Is Nothing Then ' we found it
        ActivePresentation.Application.DisplayAlerts = ppAlertsNone 
        SendKeys "%oi", False 
        SendKeys "%m", False 
        SendKeys "aw{ENTER}{ESC}{ESC}", True 
        MsgBox "Image Not found" 
    End If 
    Exit Sub 
    MsgBox "Error: " & Err.Number & " " & Err.Description 
End Sub

Open in new window

If you have a large number of documents that is enough to justify the effort, you can write an application to do it. Search for images in the doc, compress and save it. Otherwise you may have to do it manually one by one (perhaps with the help of macro).
Unfortunately the Compress functionality isn't implemented in the Word Object model, so programmatic manipulation would be very difficult. You may have to look for a third party application
Here is a sample to locate images (inlineshapes) in Word and extract them, you have to repeat the same for shapes:

   wrdApp = CreateObject("Word.Application")
        wrdDoc = wrdApp.Documents.Open(sourceFile, , True, , , , , , , Word.WdOpenFormat.wdOpenFormatAuto)
        For Each shape As Word.InlineShape In wrdDoc.InlineShapes
            Dim dataObject As System.Windows.Forms.IDataObject = Clipboard.GetDataObject()
            If dataObject.GetDataPresent("Bitmap") Then
                Dim bmp As Bitmap = dataObject.GetData("Bitmap")
            End If

Refer to here for sample of image compression using
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.