[文件操作] 求批处理尺寸均不相同的长方形图片，所有图片都截取靠上或靠左的正方形区域，内有例图

crownking1983

我这里有几万张图片要全部裁切成正方形。这几万张都是尺寸均不相同的长方形图片。跪求一个批处理命令能一次性将所有图片都截取成像下图这样靠上或靠左的正方形区域，如图。

flashercs

先测试.保存为bat

' &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
复制代码

8532200

回复 2# flashercs


    老大，我修改了里面很多数值都没有任何改变，怎样可以按照自己的需要进行裁切，我试了这个裁切只保留了左边的，比如我想裁切批量的只保留上或者下的该怎么改？主要是想知道怎么可以按自己需要修改数值

Batcher

回复 3# 8532200


    试试修改第79到82行那几个值

8532200

回复 4# Batcher


   感谢回复，发帖前就试了，很多数值都改过，自然改过79到82这个，甚至改过里面的英文

8532200

回复 4# Batcher


    解决了，。。。。。原来需要同时改动两个英文才可以。。。。。。。。。。。。。。。。。。。。。。。。。。我之前只改动一个