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

crownking1983

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

flashercs

先测试.保存为bat

1. ' &cls&@cscript -nologo -e:vbscript "%~f0" "%~dp0" & pause & exit /b
   
2. ' 脚本功能:剪裁图片-Crop Image, 裁剪正方形,并覆盖源文件,处理脚本所在目录及所有子目录的图片.
   
3. ' 用法:script.vbs file1 file2 ... folder1 folder2 ...
   
4. Option Explicit
   
5. On Error Resume Next
   
6. If WScript.Arguments.Count = 0 Then
   
7.   WScript.Echo "参数个数不能为0"
   
8.   WScript.Quit 1
   
9. End If
   
10. 
    
11. Const conIMAGETYPES = "|jpg|jpeg|png|bmp|tiff|gif|" ' 图片类型列表
    
12. Const conRECURSE = True ' 是否遍历子目录
    
13. Dim fso
    
14. Set fso = CreateObject("Scripting.FileSystemObject")
    
15. With CreateObject("WScript.Shell")
    
16.   .CurrentDirectory = fso.GetParentFolderName(WScript.ScriptFullName)
    
17. End With
    
18. 
    
19. Dim Img 'As ImageFile
    
20. Dim IP 'As ImageProcess
    
21. Set Img = CreateObject("WIA.ImageFile")
    
22. Set IP = CreateObject("WIA.ImageProcess")
    
23. IP.Filters.Add IP.FilterInfos("Crop").FilterID
    
24. ShowError
    
25. 
    
26. Dim i,strArgi
    
27. For i = 0 To WScript.Arguments.Count - 1
    
28.   strArgi = WScript.Arguments(i)
    
29.   If fso.FileExists(strArgi) Then
    
30.     GenFile fso.GetFile(strArgi)
    
31.   ElseIf fso.FolderExists(strArgi) Then
    
32.     GenFolder fso.GetFolder(strArgi)
    
33.   Else
    
34.     WScript.Echo "找不到文件或目录:" & strArgi
    
35.   End If
    
36. Next
    
37. ShowError
    
38. Set fso = Nothing
    
39. Set Img = Nothing
    
40. Set IP = Nothing
    
41. WScript.Quit 0
    
42. 
    
43. ' Sub functions
    
44. Sub GenFile(objFile)
    
45.   On Error Resume Next
    
46.   If InStr(1,conIMAGETYPES,"|" & fso.GetExtensionName(objFile.Name) & "|",vbTextCompare) Then
    
47.     WScript.Echo "处理图片:" & objFile.Path
    
48.     CropImage objFile.Path,objFile.Path
    
49.   Else
    
50.     WScript.Echo "未处理图片:" & objFile.Path
    
51.   End If
    
52.   ShowError
    
53. End Sub
    
54. 
    
55. Sub GenFolder(objFolder)
    
56.   On Error Resume Next
    
57.   Dim objFile,objSubFolder
    
58.   ' WScript.Echo "处理目录:" & objFolder.Path
    
59.   For Each objFile In objFolder.Files
    
60.     GenFile objFile
    
61.   Next
    
62.   If conRECURSE Then
    
63.     For Each objSubFolder In objFolder.SubFolders
    
64.       GenFolder objSubFolder
    
65.     Next
    
66.   End If
    
67.   ShowError
    
68. End Sub
    
69. 
    
70. Sub CropImage(strImageSrc,strImageDst)
    
71.   On Error Resume Next
    
72.   Dim iMin
    
73.   Img.LoadFile strImageSrc
    
74.   If Img.Width < Img.Height Then
    
75.     iMin = Img.Width
    
76.   Else
    
77.     iMin = Img.Height
    
78.   End If
    
79.   IP.Filters(1).Properties("Left") = 0
    
80.   IP.Filters(1).Properties("Top") = 0
    
81.   IP.Filters(1).Properties("Right") = Img.Width - iMin
    
82.   IP.Filters(1).Properties("Bottom") = Img.Height - iMin
    
83.   Set Img = IP.Apply(Img)
    
84.   If fso.FileExists(strImageDst) Then
    
85.     fso.DeleteFile strImageDst,True
    
86.   End If
    
87.   Img.SaveFile strImageDst
    
88.   ShowError
    
89. End Sub
    
90. 
    
91. Sub ShowError()
    
92.   If Err.Number <> 0 Then
    
93.     WScript.Echo "Err # " & Err.Number & vbNewLine & _
    
94.     "Description: " & Err.Description & vbnewline & _
    
95.     "Source: " & Err.Source
    
96.     Err.Clear
    
97.   End If
    
98. End Sub

复制代码

8532200

回复 2# flashercs


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

Batcher

回复 3# 8532200


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

8532200

回复 4# Batcher


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

8532200

回复 4# Batcher


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