xRename代码(完成中)

　　Option Explicit 'xRename replace -dir "c:\movie a\" -pattern "wma$" -replacewith "rmvb" -type file:".*\.wma" -ignorecase yes -log yes -output "c:\list.txt" '直接从命令行参数获得的数据 Dim strCmdSub As String '二级命令 Dim strDirectory As String '工作目录 Dim strPattern As String '要替换的字符(正则表达式) Dim strReplacewith As String '替换后的字符 Dim strType As String '要替换的对象限定范围的参数，包含对象类型(文件、文件夹、全部)和过滤名称的正则表达式 Dim isIgnoreCase As Boolean '是否忽略字母大小写 Dim isPutLog As Boolean '是否输出处理的log Dim strOutputFile As String '输出文件列表的路径(仅用于xRename listfile命令) Dim strTypePre As String '从上面的strType分离出来的，用正则表达式来过滤文件或文件夹的名称 Dim strTypePattern As String '从上面的strType分离出来的，用正则表达式来过滤文件或文件夹的名称 Dim strCmd As String '程序完整命令行参数 Dim reg As Object Dim matchs As Object, match As Object Sub Main() Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.ignorecase = True strCmd = Trim(Command) If strCmd = "" Then MsgBox "参数不能为空！", vbExclamation Exit Sub End If Call SetParameter Call DoCommand End Sub '设置参数到各个变量 Private Sub SetParameter() Dim strCmdTmp As String strCmdTmp = strCmd & " " strCmdSub = regGetStrSub1(strCmdTmp, "^(.+?)\s+?") strDirectory = regGetStrSub2(strCmdTmp, "-dir\s+?(""?)(.+?)\1\s+?") strPattern = regGetStrSub2(strCmdTmp, "-pattern\s+?(""?)(.+?)\1\s+?") strReplacewith = regGetStrSub2(strCmdTmp, "-replacewith\s+?(""?)(.*?)\1\s+?") strType = regGetStrSub2(strCmdTmp, "-type\s*?(""?)(.+?)\1\s+?") isIgnoreCase = IIf(LCase(regGetStrSub2(strCmdTmp, "-ignorecase\s+?(""?)(.+?)\1\s+?")) = "yes", True, False) isPutLog = IIf(LCase(regGetStrSub2(strCmdTmp, "-log\s+?(""?)(.+?)\1\s+?")) = "yes", True, False) strOutputFile = regGetStrSub2(strCmdTmp, "-output\s+?(""?)(.+?)\1\s+?") End Sub '开始处理 Private Sub DoCommand() If Not isMatch(strCmdSub, "^(replace|delete|listfile|delfile)$") Then MsgBox "二级命令错误，找不到""" & strCmdSub & """，只能为(replace,delete,listfile,delfile)中的一种。" & vbCrLf & vbCrLf & "请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation Else If strDirectory = "" Then MsgBox "缺少必选参数dir。设置方法:-dir 你的目录。请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation ElseIf strPattern = "" Then MsgBox "缺少必选参数pattern。设置方法:-pattern 要替换的字符(正则表达式)。" & vbCrLf & vbCrLf & "请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation Else Dim strFileNameAll$, vFileName, i& Dim strFileName$, strFileNameEx$ Dim strFileNameNew$, strFileNameNewEx$ Dim strRenameStatus$ Dim isDone As Boolean If Right(strDirectory, 1) "\" Then strDirectory = strDirectory & "\" If strType "" Then '用户设置了-type参数 Dim v v = regGetStrSubs(strType & " ", "(file|dir|all)(?:\:(""?)(.+?)\2)?\s+?") 'strType加个空格是为了方便处理 If v(0) " " Then strTypePre = LCase(v(0)) '要处理的对象的类型 strTypePattern = v(2) '要处理的对象过滤名称的正则表达式 Else strTypePre = "file" End If Else strTypePre = "file" End If '得到文件或文件夹的集合 strFileName = Dir(strDirectory, vbDirectory) Do While strFileName "" If strTypePre = "file" Then If GetAttr(strDirectory & strFileName) And vbNormal = vbNormal Then strFileNameAll = strFileNameAll & strFileName & vbCrLf ElseIf strTypePre = "dir" Then If GetAttr(strDirectory & strFileName) And vbDirectory = vbDirectory Then strFileNameAll = strFileNameAll & strFileName & vbCrLf ElseIf strTypePre = "all" Then strFileNameAll = strFileNameAll & strFileName & vbCrLf End If strFileName = Dir '再次调用dir函数,此时可以不带参数 Loop If strFileNameAll "" Then '至少有一个文件才开始处理 strFileNameAll = Left(strFileNameAll, Len(strFileNameAll) - 2) vFileName = Split(strFileNameAll, vbCrLf) reg.Pattern = strPattern reg.ignorecase = isIgnoreCase Select Case LCase(strCmdSub) Case "replace" 'xRename replace -dir "c:\movie a\" -pattern "wma$" -replacewith "rmvb" -type file:".*\.wma" -ignorecase yes -log yes For i = 0 To UBound(vFileName) If strTypePattern = "" Then '如果正则表达式是空那么默认处理所有文件 isDone = True Else '如果正则表达式存在那么去判断是否匹配来进行过滤 isDone = isMatch(vFileName(i), strTypePattern) End If If isDone Then strFileNameEx = strDirectory & vFileName(i) '当前文件的全路径 strFileNameNew = reg.Replace(vFileName(i), strReplacewith) '短文件名进行替换 strFileNameNewEx = strDirectory & strFileNameNew '即将替换成的文件的全路径 If strFileNameEx strFileNameNewEx Then strRenameStatus = DoRename(strFileNameEx, strFileNameNewEx) If isPutLog Then writeToFile strDirectory & "xRename.log", strRenameStatus, False If InStr(strRenameStatus, "状态:失败") > 0 Then writeToFile strDirectory & "err.log", strRenameStatus, False End If End If Next Case "delete" Case "listfile" Case "delfile" End Select End If End If End If End Sub '重命名文件名 Private Function DoRename(ByVal strFileName$, ByVal strFileNew$) As String Dim i% On Error Resume Next i = GetAttr(strFileNew) '判断文件或文件夹是否存在。如果是一个已存在的对象那么用GetAttr去获得属性时不会报错 If Err.Number = 0 Then DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:失败。错误信息:要替换的文件或文件夹已经存在！" & vbCrLf Exit Function End If On Error GoTo Err1 Name strFileName As strFileNew DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:成功。" & vbCrLf Exit Function Err1: DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:失败。错误信息:" & Err.Description & " 错误号:" & Err.Number & vbCrLf End Function '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''' '功能：根据所给文件名和内容直接写文件 '函数名：writeToFile '入口参数(如下)： ' strFileName 所给的文件名； ' strContent 要输入到上述文件的字符串 ' isCover 是否覆盖该文件，默认为覆盖 '返回值：True或False，成功则返回前者，否则返回后者 '备注：sysdzw 于 2007-5-2 提供 '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''' Private Function writeToFile(ByVal strFileName$, ByVal strContent$, Optional isCover As Boolean = True) As Boolean On Error GoTo Err1 Dim fileHandl% fileHandl = FreeFile If isCover Then Open strFileName For Output As #fileHandl Else Open strFileName For Append As #fileHandl End If Print #fileHandl, strContent Close #fileHandl writeToFile = True Exit Function Err1: writeToFile = False End Function '得到正则括号的第1个匹配项 Private Function regGetStrSub1(strData$, strPattern$) As String reg.Pattern = strPattern Set matchs = reg.Execute(strData$) If matchs.Count >= 1 Then regGetStrSub1 = matchs(0).SubMatches(0) End If End Function '得到正则括号的第2个匹配项 Private Function regGetStrSub2(strData$, strPattern$) As String reg.Pattern = strPattern Set matchs = reg.Execute(strData$) If matchs.Count >= 1 Then regGetStrSub2 = matchs(0).SubMatches(1) End If End Function '得到正则字匹配的所用内容，存放到一个数组中 Private Function regGetStrSubs(strData$, strPattern$) Dim s$, v, i% reg.Pattern = strPattern Set matchs = reg.Execute(strData$) If matchs.Count >= 1 Then For i = 0 To matchs(0).SubMatches.Count - 1 s = s & matchs(0).SubMatches(i) & vbCrLf Next If s "" Then s = Left(s, Len(s) - 2) Else s = " " End If regGetStrSubs = Split(s, vbCrLf) End If End Function '测试正则表达式是否匹配 Private Function isMatch(ByVal strData$, ByVal strPattern$) As Boolean reg.Pattern = strPattern isMatch = reg.test(strData$) End Function