Board logo

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

作者: crownking1983    时间: 2020-3-11 02:45     标题: 求批处理尺寸均不相同的长方形图片,所有图片都截取靠上或靠左的正方形区域,内有例图

我这里有几万张图片要全部裁切成正方形。这几万张都是尺寸均不相同的长方形图片。跪求一个批处理命令能一次性将所有图片都截取成像下图这样靠上或靠左的正方形区域,如图。
作者: flashercs    时间: 2020-3-14 17:57

先测试.保存为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. Const conIMAGETYPES = "|jpg|jpeg|png|bmp|tiff|gif|" ' 图片类型列表
  11. Const conRECURSE = True ' 是否遍历子目录
  12. Dim fso
  13. Set fso = CreateObject("Scripting.FileSystemObject")
  14. With CreateObject("WScript.Shell")
  15.   .CurrentDirectory = fso.GetParentFolderName(WScript.ScriptFullName)
  16. End With
  17. Dim Img 'As ImageFile
  18. Dim IP 'As ImageProcess
  19. Set Img = CreateObject("WIA.ImageFile")
  20. Set IP = CreateObject("WIA.ImageProcess")
  21. IP.Filters.Add IP.FilterInfos("Crop").FilterID
  22. ShowError
  23. Dim i,strArgi
  24. For i = 0 To WScript.Arguments.Count - 1
  25.   strArgi = WScript.Arguments(i)
  26.   If fso.FileExists(strArgi) Then
  27.     GenFile fso.GetFile(strArgi)
  28.   ElseIf fso.FolderExists(strArgi) Then
  29.     GenFolder fso.GetFolder(strArgi)
  30.   Else
  31.     WScript.Echo "找不到文件或目录:" & strArgi
  32.   End If
  33. Next
  34. ShowError
  35. Set fso = Nothing
  36. Set Img = Nothing
  37. Set IP = Nothing
  38. WScript.Quit 0
  39. ' Sub functions
  40. Sub GenFile(objFile)
  41.   On Error Resume Next
  42.   If InStr(1,conIMAGETYPES,"|" & fso.GetExtensionName(objFile.Name) & "|",vbTextCompare) Then
  43.     WScript.Echo "处理图片:" & objFile.Path
  44.     CropImage objFile.Path,objFile.Path
  45.   Else
  46.     WScript.Echo "未处理图片:" & objFile.Path
  47.   End If
  48.   ShowError
  49. End Sub
  50. Sub GenFolder(objFolder)
  51.   On Error Resume Next
  52.   Dim objFile,objSubFolder
  53.   ' WScript.Echo "处理目录:" & objFolder.Path
  54.   For Each objFile In objFolder.Files
  55.     GenFile objFile
  56.   Next
  57.   If conRECURSE Then
  58.     For Each objSubFolder In objFolder.SubFolders
  59.       GenFolder objSubFolder
  60.     Next
  61.   End If
  62.   ShowError
  63. End Sub
  64. Sub CropImage(strImageSrc,strImageDst)
  65.   On Error Resume Next
  66.   Dim iMin
  67.   Img.LoadFile strImageSrc
  68.   If Img.Width < Img.Height Then
  69.     iMin = Img.Width
  70.   Else
  71.     iMin = Img.Height
  72.   End If
  73.   IP.Filters(1).Properties("Left") = 0
  74.   IP.Filters(1).Properties("Top") = 0
  75.   IP.Filters(1).Properties("Right") = Img.Width - iMin
  76.   IP.Filters(1).Properties("Bottom") = Img.Height - iMin
  77.   Set Img = IP.Apply(Img)
  78.   If fso.FileExists(strImageDst) Then
  79.     fso.DeleteFile strImageDst,True
  80.   End If
  81.   Img.SaveFile strImageDst
  82.   ShowError
  83. End Sub
  84. Sub ShowError()
  85.   If Err.Number <> 0 Then
  86.     WScript.Echo "Err # " & Err.Number & vbNewLine & _
  87.     "Description: " & Err.Description & vbnewline & _
  88.     "Source: " & Err.Source
  89.     Err.Clear
  90.   End If
  91. End Sub
复制代码

作者: 8532200    时间: 2022-2-24 23:38

回复 2# flashercs


    老大,我修改了里面很多数值都没有任何改变,怎样可以按照自己的需要进行裁切,我试了这个裁切只保留了左边的,比如我想裁切批量的只保留上或者下的该怎么改?主要是想知道怎么可以按自己需要修改数值
作者: Batcher    时间: 2022-2-25 09:08

回复 3# 8532200


    试试修改第79到82行那几个值
作者: 8532200    时间: 2022-2-25 12:46

回复 4# Batcher


   感谢回复,发帖前就试了,很多数值都改过,自然改过79到82这个,甚至改过里面的英文
作者: 8532200    时间: 2022-2-25 12:54

回复 4# Batcher


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




欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2