Mikel
[转载]使用vbs借助mspaint.exe实现图片无损压缩_勇敢的心_百度空间.
有的时候四处寻觅的好东西可能就在眼前！由于想要换一个网站的Banner，为了能把图片压缩到极致，于是四处寻找好用的图片压缩工具，试用了一些软件后 才发现，原来最好的图片压缩工具其实就是微软winXP系统下自带的MSpaint.exe（画图程序）。
美中不足的是Mspaint无批量处理功能，只能逐个压缩，这给我们需要处理大量图片的朋友带来了不小困难。笔者就此问题，在网上也找了若干的解决方案，发现借助vbs可以很好地解决此问题；参照其他网友的实现，笔者又做了少许加工，完成了如下vbs脚本：
‘**********************************************
‘*使用说明，选择源文件夹和目标文件夹
‘*不支持中文路径和文件名
‘**********************************************
Dim FileName,fs,srcFolder,disFolder
Const PICTURE_TYPE = “.jpg.gif.jpeg”
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Set objShell = CreateObject(“Shell.Application”)
Set objFolder = objShell.Namespace(My_Computer)
Set objFolderItem = objFolder.Self
srcFolder = objFolderItem.Path
‘**********************************************
‘*选择源文件夹
‘**********************************************
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, “选择源文件夹:”, OPTIONS, “”)
If objFolder Is Nothing Then
msgbox “您没有选择任何有效目录!”
wscript.quit
End If
Set objFolderItem = objFolder.Self
srcFolder = objFolderItem.Path
If HasChinese(srcFolder) Then
msgbox “不支持中文路径，请重新选择！”
wscript.quit
End If
‘**********************************************
‘*选择输出文件夹
‘**********************************************
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, “选择输出文件夹:”, OPTIONS, “”)
If objFolder Is Nothing Then
msgbox “您没有选择任何有效目录!”
wscript.quit
End If
Set objFolderItem = objFolder.Self
disFolder = objFolderItem.Path
If HasChinese(disFolder) Then
msgbox “不支持中文路径，请重新选择！”
wscript.quit
End If
Call main
Sub main
On Error Resume Next
set WshShell = WScript.CreateObject(“WScript.Shell”)
WshShell.Run “C:\WINDOWS\system32\mspaint.exe”
WScript.Sleep 1000
WshShell.AppActivate “paint”
WScript.Sleep 1000
Dim objfso,objfolder1
Set objfso = CreateObject(“scripting.filesystemobject”)
Set objfolder1 = objfso.getfolder(srcFolder)
For Each objfile In objfolder1.files
If AllowExtension(LCase(objfso.GetExtensionName(objfile))) =true Then
WshShell.Sendkeys “^o”
WScript.Sleep 100
path=TrimLast(srcFolder,”\”) +”\”+ objfile.name
WshShell.SendKeys path
WScript.Sleep 100
WshShell.SendKeys “~”
WScript.Sleep 200
‘另存为
WshShell.Sendkeys “%f”
WshShell.Sendkeys “a”
WScript.Sleep 100
WshShell.Sendkeys “{BS}”
path=TrimLast(disFolder,”\”) +”\”+ objfile.name
WshShell.SendKeys path
WScript.Sleep 100
WshShell.Sendkeys “~”
WScript.Sleep 200
End If
Next
End Sub
‘**********************************************
‘*检查是否含有中文
‘**********************************************
Function HasChinese(sFileName)
Set regEx = New RegExp
regEx.Pattern = “^[\x00-\xff]*$”
regEx.IgnoreCase = True
HasChinese = Not regEx.test(sFileName)
End Function
‘**********************************************
‘*检查是否允许的扩展名
‘**********************************************
Function AllowExtension(sFileName)
If IsNull(sFileName) Or sFileName = “” Then
AllowExtension = False
else
AllowExtension = InStr(PICTURE_TYPE,sFileName)>0
End If
End Function
‘****
‘* Remove “chr” (if it exists) from end of “str”.
‘****
Function TrimLast(str,chr)
TrimLast = str
If Right(str,1) = chr Then
TrimLast = Left(str,Len(str)-1)
End If
End Function
直接下载：批量压缩图片.vbs
