博客园  :: 首页  :: 新随笔  :: 联系 :: 订阅 订阅  :: 管理

XRename代码(完成中)

Posted on 2011-02-28 17:54  随风飘零0  阅读(289)  评论(0编辑  收藏  举报

以下是“文件重命名工具”的源码,关于它的介绍以及使用方法请参考文章:https://blog.csdn.net/sysdzw/article/details/6198257d

打包下载:https://gitee.com/sysdzw/XRename

 

 

  1 Option Explicit
  2 'xrename replace -dir "c:\movie a\" -string /wma$/ig -newstring "rmvb" -type file:/.*\.wma/ -ignorecase yes -log yes -output "c:\list.txt"
  3 'xrename replace -dir "C:\Documents and Settings\sysdzw\桌面\XRename\inetfilename" -string "[1]" -newstring "" -log yes
  4 'xrename delete -dir "C:\Documents and Settings\sysdzw\桌面\XRename\inetfilename" -string "[1]"
  5 '-ignoreExt 忽略处理后缀名
  6 '直接从命令行参数获得的数据
  7 Dim strCmdSub           As String   '二级命令
  8 Dim strDirectory        As String   '工作目录
  9 Dim strString           As String   '要替换的字符(可能为正则表达式全体)
 10 Dim strNewString        As String   '替换后的字符
 11 Dim strType             As String   '要替换的对象限定范围的参数,包含对象类型(file|dir|all)和过滤名称的正则表达式
 12 Dim isDealSubDir        As Boolean  '是否递归子目录 默认值:false
 13 Dim isIgnoreCase        As Boolean  '是否忽略字母大小写 默认值:true
 14 Dim isIgnoreExt        As Boolean  '是否忽略处理后缀名 默认值:true
 15 Dim isPutLog            As Boolean  '是否输出处理的log  默认值:false
 16 Dim strOutputFile       As String   '输出文件列表的路径(仅用于XRename listfile命令)
 17 
 18 Dim strStringPattern    As String   '从strString分离出来,要替换的内容的正则表达式,不包含//等
 19 Dim strStringPatternP   As String   '从strString分离出来,要替换的内容的正则表达式的属性,为(i|g|ig),默认为ig,普通字符串处理会转换成正则表达式处理,所以i会受isIgnoreCase影响
 20 
 21 Dim strGrepTypePre          As String   '从strType分离出来,是操作对象的类型(file|dir|all)
 22 Dim strTypePattern      As String   '从strType分离出来,是用于根据操作对象的名称进行过滤的正则表达式,不包含//等
 23 Dim strTypePatternP     As String   '从strType分离出来,是用于根据操作对象的名称进行过滤的正则表达式的属性,为(i|g|ig),一般为ig
 24 
 25 Dim strCmd              As String   '程序完整命令行参数
 26 Dim reg As Object
 27 Dim matchs As Object, match As Object
 28 
 29 Dim regForReplace As Object '专门用来替换用的
 30 Dim regForTestType As Object '专门用来测试范围是否匹配用的
 31 Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
 32      
 33 Sub Main()
 34     Set reg = CreateObject("vbscript.regexp")
 35     reg.Global = True
 36     reg.IgnoreCase = True
 37     
 38     Set regForReplace = CreateObject("vbscript.regexp")
 39     Set regForTestType = CreateObject("vbscript.regexp")
 40     
 41     strCmd = Trim(Command)
 42     regForReplace.Pattern = "^""(.+)""$" '删除掉最外围的双引号
 43     strCmd = regForReplace.Replace(strCmd, "$1")
 44     strCmd = Trim(strCmd)
 45     
 46     If strCmd = "" Then
 47         MsgBox "参数不能为空!" & vbCrLf & vbCrLf & _
 48                 "语法如下:" & vbCrLf & _
 49                 "(1) replace -dir directory -string string1 -new string2 [-type (file|dir|all)[:string3]] [-ignorecase {yes|no}] [-ignoreExt {yes|no}] [-log {yes|no}]" & vbCrLf & _
 50                 "(2) delete -dir directory -string string1 [-type (file|dir|all)[:string3]] [-ignorecase {yes|no}] [-log {yes|no}]" & vbCrLf & _
 51                 "(3) listfile -dir directory -string string1 [-type (file|dir|all)[:string3]] [-ignorecase {yes|no}] [-output path]" & vbCrLf & _
 52                 "(4) delfile -dir directory -string string1 [-type (file|dir|all)[:string3]] [-ignorecase {yes|no}] [-log {yes|no}]" & vbCrLf & _
 53                 "(5) utf8rename -dir directory [-type (file|dir|all)[:string3]] [-ignorecase {yes|no}] [-log {yes|no}]", vbExclamation
 54         Exit Sub
 55     End If
 56     
 57     Call SetParameter
 58     Call DoCommand
 59 End Sub
 60 '设置参数到各个变量
 61 Private Sub SetParameter()
 62     Dim strCmdTmp As String
 63     strCmdTmp = strCmd & " "
 64     strCmdSub = regGetStrSub1(strCmdTmp, "^(.+?)\s+?")
 65     strDirectory = regGetStrSub2(strCmdTmp, "-(?:dir|path)\s+?(""?)(.+?)\1\s+?")
 66     
 67     strString = regGetStrSub1(strCmdTmp, "-string\s+?(/.*?/[^\s]*)") '先尝试//正则方式获取
 68     If strString = "" Then strString = regGetStrSub2(strCmdTmp, "-string\s+?(""?)(.+?)\1\s+?")
 69     
 70     strNewString = regGetStrSub2(strCmdTmp, "-(?:new|newstring|replacewith)\s+?(""?)(.*?)\1\s+?")
 71     
 72     strType = regGetStrSub2(strCmdTmp, "-type\s+?(""?)(.+?)\1\s+?")
 73     
 74     isIgnoreCase = IIf(LCase(regGetStrSub2(strCmdTmp, "-ignorecase\s+?(""?)(.+?)\1\s+?")) = "yes", True, False)
 75     isIgnoreExt = IIf(LCase(regGetStrSub2(strCmdTmp, "-ignoreext\s+?(""?)(.+?)\1\s+?")) = "yes", True, False)
 76     isPutLog = IIf(LCase(regGetStrSub2(strCmdTmp, "-log\s+?(""?)(.+?)\1\s+?")) = "yes", True, False)
 77     strOutputFile = regGetStrSub2(strCmdTmp, "-output\s+?(""?)(.+?)\1\s+?")
 78     
 79     strDirectory = Replace(strDirectory, "/", "\")
 80     If strDirectory = "" Then strDirectory = "."
 81     If Right(strDirectory, 1) <> "\" Then strDirectory = strDirectory & "\"
 82     
 83     If strOutputFile = "" Then strOutputFile = strDirectory & "XRename_list.txt"
 84     
 85     Dim v
 86     If strString <> "" Then '用户设置了-string参数
 87         If Left(strString, 1) = "/" Then '表示正则模式
 88             v = regGetStrSubs(strString, "/(.+?)/(.*)") '分离出正则表达式的值和类型。处理数据例如“/.*\.wma/ig
 89             strStringPattern = v(0) '要处理的对象过滤名称的正则表达式
 90             strStringPatternP = LCase(v(1)) '要处理的对象过滤名称的正则表达式的类型
 91         End If
 92     End If
 93     
 94     If strType <> "" Then '用户设置了-type参数
 95         Dim strTypeEx$
 96         v = regGetStrSubs(strType & " ", "(file|dir|all)(?:\:(""?)(.+?)\2)?\s+?") 'strType加个空格是为了方便处理,结尾\s区分。处理数据例如“file:*.wma”
 97         If v(0) <> "*NULL*" Then '表示这个参数有数据
 98             strGrepTypePre = LCase(v(0)) '要处理的对象的类型(file|dir|all)
 99             strTypeEx = v(2)
100             If strTypeEx <> "" Then '这里可能是普通也可能是正则表达式
101                 v = regGetStrSubs(strTypeEx, "/(.+?)/(.*)") '分离出正则表达式的值和类型。处理数据例如“/.*\.wma/ig”
102                 If v(0) <> "*NULL*" Then
103                     strTypePattern = v(0) '要处理的对象过滤名称的正则表达式
104                     strTypePatternP = LCase(v(1)) '要处理的对象过滤名称的正则表达式的类型
105                 Else '匹配为空说明是普通字符串,下面执行转换为正则表达式,需要遵循两个规则:1.遇到?替换成. 2.遇到*替换成.*?  但是如果有*或者问号需要用正则处理。 *.txt -> .*\.txt 再例如: a?b 变成a.b
106                     reg.Pattern = "(\[\]\(\)\{\}\.\+\-\/\|\^\$\=\,)"
107                     reg.Global = True
108                     strTypePattern = reg.Replace(strTypeEx, "\$1")
109                     strTypePattern = Replace(strTypePattern, "?", ".")
110                     If Left(strTypePattern, 1) <> "*" And InStr(strTypePattern, "*") > 0 Then strTypePattern = "^" & strTypePattern
111                     If Right(strTypePattern, 1) <> "*" And InStr(strTypePattern, "*") Then strTypePattern = strTypePattern & "$"
112                     strTypePattern = Replace(strTypePattern, "*", ".*?")
113 
114                     strTypePatternP = "ig"
115                 End If
116             End If
117         Else
118             strGrepTypePre = "file"
119         End If
120     Else
121         strGrepTypePre = "file"
122         If strCmdSub = "deldir" Or strCmdSub = "deletedir" Then '如果是要删除目录的那么就是设置属性为目录了。
123             strGrepTypePre = "dir"
124         End If
125     End If
126 End Sub
127 '开始处理
128 Private Sub DoCommand()
129     If Not isNameMatch(strCmdSub, "^(replace|rep|del|delete|listfile|delfile|deletefile|deldir|deletedir|utf8decode)$") Then
130         MsgBox "二级命令错误,找不到""" & strCmdSub & """,只能为(replace,delete,listfile,delfile,deldir,utf8decode)中的一种。" & vbCrLf & vbCrLf & "请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation
131         Exit Sub
132     End If
133     
134     If strDirectory = "" Then '如果这个参数为空那么表示默认处理当前所在目录,在cmd中直接敲入命令的话不妥,建议在批处理bat中使用
135         strDirectory = ".\"
136     End If
137     
138     If Dir(strDirectory, vbDirectory) = "" Then
139         MsgBox "指定要处理的文件夹""" & strDirectory & """不存在!" & vbCrLf & vbCrLf & "请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation
140         End
141     End If
142     
143     If strString = "" And LCase(strCmdSub) <> "utf8decode" And LCase(strCmdSub) <> "deldir" And LCase(strCmdSub) <> "deletedir" Then
144         MsgBox "缺少必选参数string。设置方法:-string 要替换的字符(可以为正则表达式)。" & vbCrLf & vbCrLf & "请仔细检查传入的参数:" & vbCrLf & strCmd, vbExclamation
145         Exit Sub
146     End If
147     
148 
149     Dim strFileNameAll$, vFileName, i&
150     Dim strFileName$, strFileNameFull$, strFileNamePre$, strFileNameExt$, v
151     Dim strFileNameNew$, strFileNameNewFull$
152     Dim strRenameStatus$
153     Dim strDeleteFileStatus$
154     Dim isDone As Boolean
155 
156     '得到文件或文件夹的集合
157     strFileName = Dir(strDirectory, vbDirectory)
158     Do While strFileName <> ""
159         If strFileName <> "." And strFileName <> ".." Then
160             If strGrepTypePre = "dir" Then
161                 If (GetAttr(strDirectory & strFileName) And vbDirectory) = vbDirectory Then strFileNameAll = strFileNameAll & strFileName & vbCrLf
162             ElseIf strGrepTypePre = "file" Then
163                 If (GetAttr(strDirectory & strFileName) And vbDirectory) <> vbDirectory Then strFileNameAll = strFileNameAll & strFileName & vbCrLf
164             ElseIf strGrepTypePre = "all" Then
165                 strFileNameAll = strFileNameAll & strFileName & vbCrLf
166             End If
167          End If
168          
169         strFileName = Dir '再次调用dir函数,此时可以不带参数
170     Loop
171     
172     If strFileNameAll <> "" Then  '至少有一个文件才开始处理
173         strFileNameAll = Left(strFileNameAll, Len(strFileNameAll) - 2)
174         vFileName = Split(strFileNameAll, vbCrLf)
175         
176         regForReplace.Pattern = strStringPattern
177         regForReplace.IgnoreCase = (InStr(strStringPatternP, "i") > 0)
178         regForReplace.MultiLine = (InStr(strStringPatternP, "m") > 0)
179         regForReplace.Global = (InStr(strStringPatternP, "g") > 0)
180         
181         regForTestType.Pattern = strTypePattern
182         regForTestType.IgnoreCase = (InStr(strTypePatternP, "i") > 0)
183         regForTestType.MultiLine = (InStr(strTypePatternP, "m") > 0)
184         regForTestType.Global = (InStr(strTypePatternP, "g") > 0)
185         
186         Select Case LCase(strCmdSub)
187             Case "rep", "replace" 'XRename replace -dir "c:\movie a\" -string "wma$" -replacewith "rmvb" -type file:".*\.wma" -ignorecase yes -log yes
188                 For i = 0 To UBound(vFileName)
189                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
190                         isDone = True
191                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
192                         isDone = isNameMatch(vFileName(i), strTypePattern)
193                     End If
194                     
195                     If isDone Then
196                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
197 
198                         If isIgnoreExt And InStr(vFileName(i), ".") > 0 Then   '忽略后缀名。也就是不处理后缀名,当然如果没有后缀名的话直接走下面的分支替换
199                             v = Split(vFileName(i), ".")
200                             strFileNamePre = Left(vFileName(i), InStrRev(vFileName(i), ".") - 1) '后缀之前的内容
201                             strFileNameExt = v(UBound(v)) '后缀
202                             
203                             If Left(strString, 1) = "/" Then '表示正则模式
204                                 strFileNameNew = regForReplace.Replace(strFileNamePre, strNewString) & "." & strFileNameExt '用正则替换
205                             Else
206                                 strFileNameNew = Replace(strFileNamePre, strString, strNewString) & "." & strFileNameExt
207                             End If
208                         Else
209                             If Left(strString, 1) = "/" Then '表示正则模式
210                                 strFileNameNew = regForReplace.Replace(vFileName(i), strNewString) '用正则替换
211                             Else
212                                 strFileNameNew = Replace(vFileName(i), strString, strNewString) '正常替换
213                             End If
214                         End If
215                         
216                         strFileNameNewFull = strDirectory & strFileNameNew '即将替换成的文件的全路径
217                         
218                         If strFileNameFull <> strFileNameNewFull Then
219                             strRenameStatus = DoRename(strFileNameFull, strFileNameNewFull)
220                             If isPutLog Then writeToFile strDirectory & "XRename.log", strRenameStatus, False
221                             If InStr(strRenameStatus, "状态:失败") > 0 Then writeToFile strDirectory & "err.log", strRenameStatus, False
222                         End If
223                     End If
224                 Next
225             Case "del", "delete"
226                 For i = 0 To UBound(vFileName)
227                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
228                         isDone = True
229                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
230                         isDone = isNameMatch(vFileName(i), strTypePattern)
231                     End If
232                     
233                     If isDone Then
234                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
235                         
236                         If isIgnoreExt And InStr(vFileName(i), ".") > 0 Then   '忽略后缀名。也就是不处理后缀名,当然如果没有后缀名的话直接走下面的分支替换
237                             v = Split(vFileName(i), ".")
238                             strFileNamePre = Left(vFileName(i), InStrRev(vFileName(i), ".") - 1) '后缀之前的内容
239                             strFileNameExt = v(UBound(v)) '后缀
240                             
241                             If Left(strString, 1) = "/" Then '表示正则模式
242                                 strFileNameNew = regForReplace.Replace(strFileNamePre, "") & "." & strFileNameExt '用正则替换
243                             Else
244                                 strFileNameNew = Replace(strFileNamePre, strString, "") & "." & strFileNameExt
245                             End If
246                         Else
247                             If Left(strString, 1) = "/" Then '表示正则模式
248                                 strFileNameNew = regForReplace.Replace(vFileName(i), "") '用正则替换
249                             Else
250                                 strFileNameNew = Replace(vFileName(i), strString, "") '正常替换
251                             End If
252                         End If
253                         
254                         strFileNameNewFull = strDirectory & strFileNameNew '即将替换成的文件的全路径
255                         
256                         If strFileNameFull <> strFileNameNewFull Then
257                             strRenameStatus = DoRename(strFileNameFull, strFileNameNewFull)
258                             If isPutLog Then writeToFile strDirectory & "XRename.log", strRenameStatus, False
259                             If InStr(strRenameStatus, "状态:重命名失败") > 0 Then writeToFile strDirectory & "err.log", strRenameStatus, False
260                         End If
261                     End If
262                 Next
263             Case "listfile"
264                  For i = 0 To UBound(vFileName)
265                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
266                         isDone = True
267                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
268                         isDone = isNameMatch(vFileName(i), strTypePattern)
269                     End If
270                     
271                     If isDone Then
272                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
273                     
274                         If regForReplace.test(vFileName(i)) Then
275                             writeToFile strOutputFile, strDeleteFileStatus, False
276                         End If
277                     End If
278                 Next
279             Case "delfile", "deletefile"
280                  For i = 0 To UBound(vFileName)
281                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
282                         isDone = True
283                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
284                         isDone = isNameMatch(vFileName(i), strTypePattern)
285                     End If
286                     
287                     If isDone Then
288                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
289                     
290                         If regForReplace.test(vFileName(i)) Then
291                             strDeleteFileStatus = DoDelete(strFileNameFull)
292                             If isPutLog Then writeToFile strDirectory & "XRename.log", strDeleteFileStatus, False
293                             If InStr(strRenameStatus, "状态:删除名失败") > 0 Then writeToFile strDirectory & "err.log", strDeleteFileStatus, False
294                         End If
295                     End If
296                 Next
297             Case "deldir", "deletedir" '未处理好20200924 deleteFonder
298                  For i = 0 To UBound(vFileName)
299                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
300                         isDone = True
301                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
302                         isDone = isNameMatch(vFileName(i), strTypePattern)
303                     End If
304                     
305                     If isDone Then
306                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
307                     
308                         If regForReplace.test(vFileName(i)) Then
309                             strDeleteFileStatus = DoDelete(strFileNameFull)
310                             If isPutLog Then writeToFile strDirectory & "XRename.log", strDeleteFileStatus, False
311                             If InStr(strRenameStatus, "状态:删除名失败") > 0 Then writeToFile strDirectory & "err.log", strDeleteFileStatus, False
312                         End If
313                     End If
314                 Next
315             Case "utf8decode"
316                 For i = 0 To UBound(vFileName)
317                     If strTypePattern = "" Then '如果处理范围的参数是空那么处理所有文件
318                         isDone = True
319                     Else '如果正则表达式存在那么去判断是否匹配来进行过滤
320                         isDone = isNameMatch(vFileName(i), strTypePattern)
321                     End If
322                     
323                     If isDone Then
324                         strFileNameFull = strDirectory & vFileName(i) '当前文件的全路径
325                 
326                         strFileNameNew = UTF8Decode(vFileName(i)) '短文件名进行UTF8编码转换
327                         strFileNameNewFull = strDirectory & strFileNameNew '即将替换成的文件的全路径
328                         
329                         If strFileNameFull <> strFileNameNewFull Then
330                             strRenameStatus = DoRename(strFileNameFull, strFileNameNewFull)
331                             If isPutLog Then writeToFile strDirectory & "XRename.log", strRenameStatus, False
332                             If InStr(strRenameStatus, "状态:失败") > 0 Then writeToFile strDirectory & "err.log", strRenameStatus, False
333                         End If
334                     End If
335                 Next
336         End Select
337     End If
338 End Sub
339 '重命名文件名
340 Private Function DoRename(ByVal strFileName$, ByVal strFileNew$) As String
341     Dim i%
342     
343     If LCase(strFileName) <> LCase(strFileNew) Then '如果是大小写造成的文件已经存在是允许修改的
344         On Error Resume Next
345         i = GetAttr(strFileNew) '判断文件或文件夹是否存在。如果是一个已存在的对象那么用GetAttr去获得属性时不会报错
346         If Err.Number = 0 Then
347             DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:重命名失败。错误信息:已经存在相同名称的文件或者文件夹!" & vbCrLf
348             Exit Function
349         End If
350     End If
351     
352     On Error GoTo Err1
353     Name strFileName As strFileNew
354     DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:重命名成功。" & vbCrLf
355     
356     Exit Function
357 Err1:
358     DoRename = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & " ==> " & strFileNew$ & vbCrLf & "状态:重命名失败。错误信息:" & Err.Description & " 错误号:" & Err.Number & vbCrLf
359 End Function
360 '删除指定文件或者文件夹
361 Private Function DoDelete(ByVal strFileName$) As String
362     Dim i%
363     
364     On Error Resume Next
365     i = GetAttr(strFileName) '判断文件或文件夹是否存在。如果是一个已存在的对象那么用GetAttr去获得属性时不会报错
366 
367     On Error GoTo Err1
368     If i = 16 Then '删除文件
369         Kill strFileName
370     Else '删除文件夹
371         deleteFonder strFileName
372     End If
373     DoDelete = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName & vbCrLf & "状态:删除成功。" & vbCrLf
374     
375     Exit Function
376 Err1:
377     DoDelete = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strFileName$ & vbCrLf & "状态:删除失败。错误信息:" & Err.Description & " 错误号:" & Err.Number & vbCrLf
378 End Function
379 '删除指定文件夹  20200924做删除区分
380 Private Function DoDeleteDir(ByVal strPath$) As String
381     Dim i%
382     
383     On Error Resume Next
384     i = GetAttr(strPath) '判断文件或文件夹是否存在。如果是一个已存在的对象那么用GetAttr去获得属性时不会报错
385 
386     On Error GoTo Err1
387     If i = 16 Then '是文件夹才删除,跳过文件
388         deleteFonder strPath
389         DoDeleteDir = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strPath & vbCrLf & "状态:删除文件夹成功。" & vbCrLf
390     End If
391     
392     Exit Function
393 Err1:
394     DoDeleteDir = Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf & strPath & vbCrLf & "状态:删除文件夹失败。错误信息:" & Err.Description & " 错误号:" & Err.Number & vbCrLf
395 End Function
396 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
397 '功能:根据所给文件名和内容直接写文件
398 '函数名:writeToFile
399 '入口参数(如下):
400 '  strFileName 所给的文件名;
401 '  strContent 要输入到上述文件的字符串
402 '  isCover 是否覆盖该文件,默认为覆盖
403 '返回值:True或False,成功则返回前者,否则返回后者
404 '备注:sysdzw 于 2007-5-2 提供
405 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
406 Private Function writeToFile(ByVal strFileName$, ByVal strContent$, Optional isCover As Boolean = True) As Boolean
407     On Error GoTo Err1
408     Dim fileHandl%
409     fileHandl = FreeFile
410     If isCover Then
411         Open strFileName For Output As #fileHandl
412     Else
413         Open strFileName For Append As #fileHandl
414     End If
415     Print #fileHandl, strContent
416     Close #fileHandl
417     writeToFile = True
418     Exit Function
419 Err1:
420     writeToFile = False
421 End Function
422 '得到正则括号的第1个匹配项
423 Private Function regGetStrSub1(strData$, strPattern$) As String
424     reg.Pattern = strPattern
425     Set matchs = reg.Execute(strData$)
426     If matchs.Count >= 1 Then
427         regGetStrSub1 = matchs(0).SubMatches(0)
428     End If
429 End Function
430 '得到正则括号的第2个匹配项
431 Private Function regGetStrSub2(strData$, strPattern$) As String
432     reg.Pattern = strPattern
433     Set matchs = reg.Execute(strData$)
434     If matchs.Count >= 1 Then
435         regGetStrSub2 = matchs(0).SubMatches(1)
436     End If
437 End Function
438 
439 '得到正则字匹配的所用内容,存放到一个数组中
440 Private Function regGetStrSubs(strData$, strPattern$)
441     Dim s$, v, i%
442     reg.Pattern = strPattern
443     Set matchs = reg.Execute(strData$)
444     If matchs.Count >= 1 Then
445         For i = 0 To matchs(0).SubMatches.Count - 1
446             s = s & matchs(0).SubMatches(i) & vbCrLf
447         Next
448     End If
449     If s <> "" Then
450         s = Left(s, Len(s) - 2)
451     Else
452         s = "*NULL*"
453     End If
454     
455     regGetStrSubs = Split(s, vbCrLf)
456 End Function
457 
458 '主要是用来测试文件或文件夹名是否匹配
459 Private Function isNameMatch(ByVal strData$, ByVal strPattern$) As Boolean
460     regForTestType.Pattern = strPattern
461     isNameMatch = regForTestType.test(strData$)
462 End Function
463 
464 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
465 '                         UTF8 decode model                             '
466 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
467 Public Function UTF8Decode(ByVal code As String) As String
468     If code = "" Then
469         UTF8Decode = ""
470         Exit Function
471     End If
472     
473     Dim tmp As String
474     Dim decodeStr As String
475     Dim codelen As Long
476     Dim result As String
477     Dim leftStr As String
478      
479     leftStr = Left(code, 1)
480      
481     While (code <> "")
482         codelen = Len(code)
483         leftStr = Left(code, 1)
484         If leftStr = "%" Then
485                 If (Mid(code, 2, 1) = "C" Or Mid(code, 2, 1) = "B") Then
486                     decodeStr = Replace(Mid(code, 1, 6), "%", "")
487                     tmp = c10ton(Val("&H" & Hex(Val("&H" & decodeStr) And &H1F3F)))
488                     tmp = String(16 - Len(tmp), "0") & tmp
489                     UTF8Decode = UTF8Decode & UTF8Decode & ChrW(Val("&H" & c2to16(Mid(tmp, 3, 4)) & c2to16(Mid(tmp, 7, 2) & Mid(tmp, 11, 2)) & Right(decodeStr, 1)))
490                     code = Right(code, codelen - 6)
491                 ElseIf (Mid(code, 2, 1) = "E") Then
492                     decodeStr = Replace(Mid(code, 1, 9), "%", "")
493                     tmp = c10ton((Val("&H" & Mid(Hex(Val("&H" & decodeStr) And &HF3F3F), 2, 3))))
494                     tmp = String(10 - Len(tmp), "0") & tmp
495                     UTF8Decode = UTF8Decode & ChrW(Val("&H" & (Mid(decodeStr, 2, 1) & c2to16(Mid(tmp, 1, 4)) & c2to16(Mid(tmp, 5, 2) & Right(tmp, 2)) & Right(decodeStr, 1))))
496                     code = Right(code, codelen - 9)
497                 End If
498         Else
499             UTF8Decode = UTF8Decode & leftStr
500             code = Right(code, codelen - 1)
501         End If
502     Wend
503 End Function
504 '10进制转n进制(默认2)
505 Public Function c10ton(ByVal x As Integer, Optional ByVal n As Integer = 2) As String
506     Dim i As Integer
507     i = x \ n
508     If i > 0 Then
509         If x Mod n > 10 Then
510             c10ton = c10ton(i, n) + Chr(x Mod n + 55)
511         Else
512             c10ton = c10ton(i, n) + CStr(x Mod n)
513         End If
514     Else
515         If x > 10 Then
516             c10ton = Chr(x + 55)
517         Else
518             c10ton = CStr(x)
519         End If
520     End If
521 End Function
522 '二进制代码转换为十六进制代码
523 Public Function c2to16(ByVal x As String) As String
524    Dim i As Long
525    i = 1
526    For i = 1 To Len(x) Step 4
527       c2to16 = c2to16 & Hex(c2to10(Mid(x, i, 4)))
528    Next
529 End Function
530 '二进制代码转换为十进制代码
531 Public Function c2to10(ByVal x As String) As String
532    c2to10 = 0
533    If x = "0" Then Exit Function
534    Dim i As Long
535    i = 0
536    For i = 0 To Len(x) - 1
537       If Mid(x, Len(x) - i, 1) = "1" Then c2to10 = c2to10 + 2 ^ (i)
538    Next
539 End Function
540 Private Sub deleteFonder(ByVal strPath$)
541     Dim FSO As Object
542     Set FSO = CreateObject("Scripting.FileSystemObject")
543     FSO.DeleteFolder strPath
544     Set FSO = Nothing
545 End Sub