• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 838
  • Last Modified:

VB6 Open word doc and set compression options

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
wildarmsdave
Asked:
wildarmsdave
  • 5
  • 2
1 Solution
 
Farzad AkbarnejadDeveloperCommented:
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
 
wildarmsdaveAuthor Commented:
Yeah ,I tried that first but the Macro didn't appear to list the code to carry out the conversion.
0
 
Farzad AkbarnejadDeveloperCommented:
I think that it is a option in Word and default it is set to compress.

-FA
0
Cloud Class® Course: SQL Server Core 2016

This course will introduce you to SQL Server Core 2016, as well as teach you about SSMS, data tools, installation, server configuration, using Management Studio, and writing and executing queries.

 
wildarmsdaveAuthor Commented:
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
 
wildarmsdaveAuthor Commented:
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
 
wildarmsdaveAuthor Commented:
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
 
wildarmsdaveAuthor Commented:
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
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.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 5
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now