mdmackillop
02-18-2011, 05:40 AM
I'm trying to reduce Word Document file size due to embedded pictures (Word 2003). Thanks to Cindy Meister for the method, I save the file as htm and reload the smaller images. This all works, reducing from 65MB to 1MB for my test doc containing 46 photos. I need to check all is in order before deleting the original.
Problem: The code should reduce and scroll "before and after" side by side, but even with the built in delay (at end of OpenTwo), the photos are not all visible. Is there a method to wait for the document to be "Ready" before the scroll starts?
Option Explicit
Sub DoHTM()
Dim Fname As String
Dim Pth As String
Dim HtmPth As String
Dim Doc As String
Dim MyDoc As Document
Dim F As String
Dim i As Long
Application.ScreenUpdating = False
'Get data
Pth = ActiveDocument.Path & "\"
Fname = ActiveDocument.Name
Doc = ActiveDocument.FullName
Fname = Left(Fname, Len(Fname) - 4)
'Save Documernt as HTM
ChangeFileOpenDirectory Pth
ActiveDocument.SaveAs Filename:=Fname & ".htm", FileFormat:= _
wdFormatHTML
HtmPth = Pth & Fname & "_files\"
'Ensure folder is created
Do
DoEvents
Loop Until Dir(HtmPth & "*.*") <> ""
'Delete non jpg files
F = Dir(HtmPth & "*.*")
Do Until F = ""
If Right(F, 3) <> "jpg" Then Kill HtmPth & F
F = Dir
Loop
'Reopen original document
Set MyDoc = Documents.Open(Doc)
'Iterate through and relace pictures
F = Dir(HtmPth & "*.*")
Do Until F = ""
i = i + 1
MyDoc.InlineShapes(i).Select
Selection.InlineShapes.AddPicture Filename:= _
HtmPth & F, LinkToFile:=False, SaveWithDocument:=True
F = Dir
Loop
ActiveDocument.SaveAs Fname & "-01.doc"
Documents(Fname & ".htm").Close
Kill Pth & Fname & ".htm"
Application.ScreenUpdating = True
OpenTwo
End Sub
Sub OpenTwo()
Dim tim As Single
'Set window 1 size
Application.WindowState = wdWindowStateNormal
Application.Move Left:=100, Top:=75
Application.ReSize Width:=451, Height:=581
ActiveWindow.ActivePane.View.Zoom.Percentage = 25
'Set window 2 size
Documents.Open Filename:="""Schedule Photographs.doc"""
Application.WindowState = wdWindowStateNormal
Application.Move Left:=600, Top:=75
Application.ReSize Width:=451, Height:=581
ActiveWindow.ActivePane.View.Zoom.Percentage = 25
'Wait for images
Application.OnTime Now + TimeValue("00:00:15"), "DoScroll"
End Sub
Sub DoScroll()
Dim x As Single
Dim tim As Single
'Scroll speed factor
x = 0.025
'Ensure start from top
Windows(1).Activate
ActiveWindow.ActivePane.VerticalPercentScrolled = 0
Windows(2).Activate
ActiveWindow.ActivePane.VerticalPercentScrolled = 0
'Scroll
Do
Windows(1).SmallScroll Down:=1
Windows(2).SmallScroll Down:=1
tim = Timer
Do
DoEvents
Loop Until Timer - tim > x
If Windows(2).ActivePane.VerticalPercentScrolled > 85 Then Exit Sub
Loop
End Sub
Problem: The code should reduce and scroll "before and after" side by side, but even with the built in delay (at end of OpenTwo), the photos are not all visible. Is there a method to wait for the document to be "Ready" before the scroll starts?
Option Explicit
Sub DoHTM()
Dim Fname As String
Dim Pth As String
Dim HtmPth As String
Dim Doc As String
Dim MyDoc As Document
Dim F As String
Dim i As Long
Application.ScreenUpdating = False
'Get data
Pth = ActiveDocument.Path & "\"
Fname = ActiveDocument.Name
Doc = ActiveDocument.FullName
Fname = Left(Fname, Len(Fname) - 4)
'Save Documernt as HTM
ChangeFileOpenDirectory Pth
ActiveDocument.SaveAs Filename:=Fname & ".htm", FileFormat:= _
wdFormatHTML
HtmPth = Pth & Fname & "_files\"
'Ensure folder is created
Do
DoEvents
Loop Until Dir(HtmPth & "*.*") <> ""
'Delete non jpg files
F = Dir(HtmPth & "*.*")
Do Until F = ""
If Right(F, 3) <> "jpg" Then Kill HtmPth & F
F = Dir
Loop
'Reopen original document
Set MyDoc = Documents.Open(Doc)
'Iterate through and relace pictures
F = Dir(HtmPth & "*.*")
Do Until F = ""
i = i + 1
MyDoc.InlineShapes(i).Select
Selection.InlineShapes.AddPicture Filename:= _
HtmPth & F, LinkToFile:=False, SaveWithDocument:=True
F = Dir
Loop
ActiveDocument.SaveAs Fname & "-01.doc"
Documents(Fname & ".htm").Close
Kill Pth & Fname & ".htm"
Application.ScreenUpdating = True
OpenTwo
End Sub
Sub OpenTwo()
Dim tim As Single
'Set window 1 size
Application.WindowState = wdWindowStateNormal
Application.Move Left:=100, Top:=75
Application.ReSize Width:=451, Height:=581
ActiveWindow.ActivePane.View.Zoom.Percentage = 25
'Set window 2 size
Documents.Open Filename:="""Schedule Photographs.doc"""
Application.WindowState = wdWindowStateNormal
Application.Move Left:=600, Top:=75
Application.ReSize Width:=451, Height:=581
ActiveWindow.ActivePane.View.Zoom.Percentage = 25
'Wait for images
Application.OnTime Now + TimeValue("00:00:15"), "DoScroll"
End Sub
Sub DoScroll()
Dim x As Single
Dim tim As Single
'Scroll speed factor
x = 0.025
'Ensure start from top
Windows(1).Activate
ActiveWindow.ActivePane.VerticalPercentScrolled = 0
Windows(2).Activate
ActiveWindow.ActivePane.VerticalPercentScrolled = 0
'Scroll
Do
Windows(1).SmallScroll Down:=1
Windows(2).SmallScroll Down:=1
tim = Timer
Do
DoEvents
Loop Until Timer - tim > x
If Windows(2).ActivePane.VerticalPercentScrolled > 85 Then Exit Sub
Loop
End Sub