[转贴] VBS脚本批量更改文件后缀名

VBScript

Dim ar
Set ar = WScript.Arguments
If ar.Count = 0 Then
 MsgBox "请把包含要按顺序Rename的文件的文件夹拖放到本程序的图标上！", 4160, "提示"
 Set ar = Nothing
 WScript.Quit
End If

Public szExt, szExtNew, l, mf, r, fso, a

szExt = InputBox("请输入要Rename的文件后缀名：", "确定文件类型", "bin")
szExt = Trim(szExt)
While Left(szExt, 1) = "."
 szExt = Mid(szExt, 2)
Wend
szExt = "." & szExt
l = Len(szExt)
If l < 1 Then
 MsgBox "后缀名太短！", 4112, "错误"
 Set ar = Nothing
 WScript.Quit
End If

szExtNew = InputBox("请输入要Rename后文件的后缀名：", "确定改后的后缀名", "bmp")
szExtNew = Trim(szExtNew)
While Left(szExtNew, 1) = "."
 szExtNew = Mid(szExtNew, 2)
Wend
szExtNew = "." & szExtNew
If Len(szExtNew) < 1 Then
 MsgBox "后缀名太短！", 4112, "错误"
 Set ar = Nothing
 WScript.Quit
End If

mf = InputBox("请输入存放Rename后文件的文件夹：", "确定存放文件夹", ar(0))
mf = Trim(mf)
While Right(mf, 1) = "\"
 mf = Left(mf, Len(mf) - 1)
Wend

r = MsgBox("处理后是否删除原文件？", 4131, "确定移动还是复制")
If r = 2 Then WScript.Quit
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(mf) Then
 MsgBox "用来存放Rename后的文件的文件夹不存在！", 4112, "错误"
 Set ar = Nothing
 Set fso = Nothing
 WScript.Quit
End If
For Each a In ar
 If fso.FolderExists(a) Then Call Rename(a)
Next
Set ar = Nothing
Set fso = Nothing
MsgBox "整个世界清净了！", 4160, "搞定！"

Private Sub Rename(ByVal fd)
 Dim rfd, fs, f, p

 Set rfd = fso.GetFolder(fd)
 Set fs = rfd.Files

 For Each f In fs
  If StrComp(Right(f.Name, l), szExt, 1) = 0 Then
   p = mf & "\" & Left(f.Name, Len(f.Name) - l) & szExtNew
'   MsgBox p
   If Not fso.FileExists(p) Then
    If r = 6 Then
     f.Move p
    Else
     f.Copy p
    End If
   End If
  End If
 Next

 Set fds = rfd.SubFolders
 For Each fd In fds
  Rename fd.Path
 Next
End Sub
复制代码

http://foxhack.blog.51cto.com/96963/32854