' &cls&@cscript -nologo -e:vbscript "%~f0" "%~dp0" & pause & exit /b
' 脚本功能:剪裁图片-Crop Image, 裁剪正方形,并覆盖源文件,处理脚本所在目录及所有子目录的图片.
' 用法:script.vbs file1 file2 ... folder1 folder2 ...
Option Explicit
On Error Resume Next
If WScript.Arguments.Count = 0 Then
  WScript.Echo "参数个数不能为0"
  WScript.Quit 1
End If

Const conIMAGETYPES = "|jpg|jpeg|png|bmp|tiff|gif|" ' 图片类型列表
Const conRECURSE = True ' 是否遍历子目录
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
With CreateObject("WScript.Shell")
  .CurrentDirectory = fso.GetParentFolderName(WScript.ScriptFullName)
End With 

Dim Img 'As ImageFile
Dim IP 'As ImageProcess
Set Img = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
IP.Filters.Add IP.FilterInfos("Crop").FilterID
ShowError

Dim i,strArgi
For i = 0 To WScript.Arguments.Count - 1
  strArgi = WScript.Arguments(i)
  If fso.FileExists(strArgi) Then
    GenFile fso.GetFile(strArgi)
  ElseIf fso.FolderExists(strArgi) Then
    GenFolder fso.GetFolder(strArgi)
  Else
    WScript.Echo "找不到文件或目录:" & strArgi 
  End If
Next
ShowError
Set fso = Nothing
Set Img = Nothing
Set IP = Nothing
WScript.Quit 0

' Sub functions
Sub GenFile(objFile)
  On Error Resume Next
  If InStr(1,conIMAGETYPES,"|" & fso.GetExtensionName(objFile.Name) & "|",vbTextCompare) Then
    WScript.Echo "处理图片:" & objFile.Path
    CropImage objFile.Path,objFile.Path
  Else
    WScript.Echo "未处理图片:" & objFile.Path
  End If
  ShowError
End Sub

Sub GenFolder(objFolder)
  On Error Resume Next
  Dim objFile,objSubFolder
  ' WScript.Echo "处理目录:" & objFolder.Path
  For Each objFile In objFolder.Files
    GenFile objFile
  Next
  If conRECURSE Then
    For Each objSubFolder In objFolder.SubFolders
      GenFolder objSubFolder
    Next
  End If
  ShowError
End Sub

Sub CropImage(strImageSrc,strImageDst)
  On Error Resume Next
  Dim iMin
  Img.LoadFile strImageSrc
  If Img.Width < Img.Height Then
    iMin = Img.Width
  Else
    iMin = Img.Height
  End If
  IP.Filters(1).Properties("Left") = 0
  IP.Filters(1).Properties("Top") = 0
  IP.Filters(1).Properties("Right") = Img.Width - iMin
  IP.Filters(1).Properties("Bottom") = Img.Height - iMin
  Set Img = IP.Apply(Img)
  If fso.FileExists(strImageDst) Then
    fso.DeleteFile strImageDst,True
  End If
  Img.SaveFile strImageDst
  ShowError
End Sub

Sub ShowError()
  If Err.Number <> 0 Then
    WScript.Echo "Err # " & Err.Number & vbNewLine & _
    "Description: " & Err.Description & vbnewline & _
    "Source: " & Err.Source
    Err.Clear
  End If
End Sub
复制代码