[转载]使用vbs借助mspaint.exe实现图片无损压缩

baacloud免费翻墙vpn注册使用

[转载]使用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

赞(0) 打赏
分享到: 更多 (0)

觉得文章有用就打赏一下文章作者

支付宝扫一扫打赏

微信扫一扫打赏