compress pictures in word use macro and vbs

[ç‹’ç‹’]

1.macro
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub compressPic()

SendKeys "w", False
' Sleep 500
SendKeys "{ENTER}", False
Word.CommandBars("Picture").FindControl(id:=6382).Execute


' compressPic Macro
' ºêÔÚ 2011-2-17 ÓÉ stan ¼ÖÆ
End Sub

2.vbs
'sources
dr1="d:\docpress"
'¶¨ÒåÊÇ·ñ»»Ä¿Â¼±£´æ£¬Ä¬ÈÏ1¸²¸Ç±£´æ
cover=1
'target
dr2="d:\docpress\done"

'ÅжÏĿ¼ÊÇ·ñ´æÔÚ
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(dr1) = False) Then
WScript.Echo "Ŀ¼"+dr1+"²»´æÔÚ"
WScript.Quit
End If
if (cover=0) then
if (fso.FolderExists(dr2) = False)Then
WScript.Echo "Ŀ¼"+dr2+"²»´æÔÚ"
WScript.Quit
End If
end if


Dim WordApp
Dim doc
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Activate

For Each objFile In fso.GetFolder(dr1).Files
filepath=objfile.path

if (Mid(filepath, InStrRev(filepath, ".") + 1) = "doc") Then
compress(objfile)
'WScript.Echo Mid(filepath, InStrRev(filepath, ".") + 1)
end if

Next



function compress(file)
Set doc = WordApp.Documents.Open(file.path)
'doc.Content = content
''¸ù¾ÝÐèÒªµ÷ÕûÑÓʱ
Wscript.Sleep 1000
WordApp.Run "CompressPic"
if cover then
doc.save
else
doc.saveas(dr2+"\"+file.name)
end if
doc.close
end function

set doc=Nothing
WordApp.Quit
set WordApp=Nothing

3.double click the vbs file.

 

[áôáô]

auto compress pics of docs in d:\docpress