Solved

VB6 Open word doc and set compression options

Posted on 2008-10-13
7
808 Views
Last Modified: 2012-05-05
Hi everyone. Is the below possible in VB6? I have hundreds of word documents that I need to compress to save space on our file server and I thought about doing the following to make things easier...

Ta - Dave

I need to search a folder and sub folders for all word documents
open each one individually
active the file save as command
activate the tools - compress pictures option
Set all pictures in document, web/screen, compress pictures, delete cropped areas option
Save the document with the same filename
0
Comment
Question by:wildarmsdave
  • 5
  • 2
7 Comments
 
LVL 14

Expert Comment

by:Farzad Akbarnejad
Comment Utility
Hello,
An easy solution: Open Word and start recording macro and do the above batch. After stop recording macro and view the VB code of macro. Use it in your VB6 application.

-FA
0
 

Author Comment

by:wildarmsdave
Comment Utility
Yeah ,I tried that first but the Macro didn't appear to list the code to carry out the conversion.
0
 
LVL 14

Expert Comment

by:Farzad Akbarnejad
Comment Utility
I think that it is a option in Word and default it is set to compress.

-FA
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 

Author Comment

by:wildarmsdave
Comment Utility
FarzadA it does, however, the images in the documents in question are at a higher DPI resolution than what is needed. By setting the web/screen option, I reduce the file size even more.
0
 

Author Comment

by:wildarmsdave
Comment Utility
Well the following line of VBA code will open up the compression menu. I just need to find a way to get the send keys function to interact with the menu

Application.CommandBars.FindControl(ID:=6382).Execute
0
 

Author Comment

by:wildarmsdave
Comment Utility
With a slight revision of  the code, I can now get the sendkeys command to work. So I can now open up the picture toolbar, set my options, Okay my choices and save the compressed file. All I need to do now is to search for all word docs, open them and activate the code below!!!! I may have to dso this from VBA which is not a problem. One snag I am finding is that if I open a new word doc and insert and run the code, it works. However, if I SAVE the word doc and then run the code. Nothing happens! Something to look at later I think!

Dim octl As CommandBarControl
   
    Set octl = Application.CommandBars.FindControl(ID:=6382)
    SendKeys "%w"
    SendKeys "{TAB}"
    SendKeys "{TAB}"
    SendKeys "{TAB}"
    SendKeys "~"
    SendKeys "%f"
   ' Save file here.....
    octl.Execute
0
 

Accepted Solution

by:
wildarmsdave earned 0 total points
Comment Utility
OK. I've manage to sort this myself with the help of a previous post. What the code will do is to search through a dir/sub dir for any Word files it encounters. I then opens the document, applies the compression to all pictures in the document (at 96dpi) and saves, before doing the same to the next document.

To use the code, create a blank Word document in the top level folder where the Word documents you wish to compress are located. Open the VBA editor (alt+F11) and paste in the enclosed code. Then go to Tools / Macros and run Macro1 to start the process.

The code is very rough and I'm sure someone with better coding skills than me can sort out the little glitches (i.e being prompted to save the document before closing). The code will also error at the end when the Macro tries to open and compress itself. Other than that(!) it did exactly what I wanted it to do (as rough as it is!)

Regards,

Dave.
Sub CompressImage(ByVal strSourcePath As String)
 

    Dim fso As Object

    Dim fld As Object

    Dim sbf As Object

    Dim fil As Object

    Dim doc As Document

 

    Dim blnFixed As Boolean
 

    Set fso = CreateObject("Scripting.FileSystemObject")

    Set fld = fso.GetFolder(strSourcePath)

    For Each fil In fld.Files

       

        If (Right$(fil.Path, 3) = "doc") And (fil.Name <> ActiveDocument.Name) Then

            Set doc = Documents.Open(fil.Path)

            blnFixed = False

            

          Dim octl As CommandBarControl

    

    Set octl = Application.CommandBars.FindControl(ID:=6382)

    SendKeys "%w"

    SendKeys "{TAB}"

    SendKeys "{TAB}"

    SendKeys "{TAB}"

    SendKeys "~"
 

    octl.Execute

            

           If blnFixed Then doc.Save

            doc.Close

        End If

    Next fil

    For Each sbf In fld.SubFolders

        FixLinks sbf.Path

    Next sbf

End Sub
 

Sub Macro1()

    CompressImage Word.ActiveDocument.Path

End Sub

Open in new window

0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

A few years ago I was very much a beginner at VBA, and that very much remains the case today.  I'll do my best to explain things as I go in the hope that other beginners can follow.  If you just want to check out a tool that creates a Select Case fu…
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
This video shows and describes the main difference between both orientations in Microsoft Word. Viewers will understand when to use each orientation and how to get the most out of them.
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

7 Experts available now in Live!

Get 1:1 Help Now