中国DOS联盟

各位高手，小弟献丑了。
还有许多不足之处请多多指教。
Option Explicit '声明全局变量/对象 Dim ie,wnd,id,curpath,fso,dlg,ext,reg,filelist Dim matchcase,fcount,shell,shellapp,delims Const ForReading = 1, ForWriting = 2 Set shell = CreateObject("wscript.shell") Set fso = CreateObject("scripting.FileSystemObject") Set dlg = CreateObject("UserAccounts.CommonDialog") Set shellapp = CreateObject("shell.application") Set reg = new regexp reg.global = True curpath = fso.GetFolder(shell.currentdirectory).shortpath configure While True wscript.sleep 1000 Wend '配置脚本任务 Sub Configure Set ie = wscript.CreateObject("InternetExplorer.Application","ie_") '设置ie对象 ie.Navigate curpath & "\replace.htm" ie.ToolBar = 0 ie.StatusBar = 0 ie.Width = 684 ie.Height = 259 ie.left=fix((ie.document.parentwindow.screen.availwidth-ie.width)/2) '水平居中' ie.top=fix((ie.document.parentwindow.screen.availheight-ie.height)/2) '垂直居中' ie.Resizable = False ie.Visible = True Set wnd = ie.document.parentwindow Set id = ie.document.all '设置ie窗口事件处理函数 id.addfolder.onclick = getref("addfolder") id.addfile.onclick = getref("addfile") id.savelist.onclick = getref("savelist") id.loadlist.onclick = getref("loadlist") id.reg1.onchange = getref("reg1_change") id.reg2.onchange = getref("reg2_change") id.startsearch.onclick = getref("startsearch") id.startreplace.onclick = getref("startreplace") id.help.onclick = getref("help") id.about.onclick = getref("about") End Sub '遍历所有选择的文件 Sub traverse(process) Dim files,file,i,ret,str,old If id.from.value="" Then Call MsgBox("请输入搜索内容！",VbCritical) Exit Sub End If If id.matchcase.checked Then matchcase = 0 Else matchcase = 1 End If reg.ignorecase = Not id.matchcase.checked reg.pattern = id.from.value fcount = 0 files = Split(id.filelist.value,vbcrlf) For i=0 To UBound(files) If files(i)<>"" Then Set file = fso.opentextfile(files(i),forreading) '跳过空文件 If Not file.atendofstream Then 'str在调用process函数时可能会被修改 str = file.readall old = str '用于分析完后的比较 '调用参数中指定的回调函数，并根据情况决定是否结束 ret = process(fso.getabsolutepathname(files(i)),str) file.close If str<>old Then If ret=True Then Set file = fso.opentextfile(files(i),forwriting) file.write str file.close ElseIf MsgBox("是否保存当前文件？",vbyesno)=vbyes Then Set file = fso.opentextfile(files(i),forwriting) file.write str file.close End If End If If ret=False Then Exit Sub End If End If End If Next If fcount=0 Then Call MsgBox("抱歉，无法找到字符串“"& id.from.value & "”！",VbExclamation) Else Call MsgBox("共找到 " & fcount & " 处结果，搜索完毕！",VbInformation) End If End Sub '根据字符串和偏移量得到行值和坐标 Sub getposition(str,offset,length,x,y,line) Dim linestart,lineend,delta '得到行首位置 linestart = InstrRev(str,vbcrlf,offset) delta = 2 If linestart=0 Then linestart = InstrRev(str,vblf,offset) delta = 1 End If If linestart=0 Then linestart = InstrRev(str,vbcr,offset) delta = 1 End If If linestart=0 And delta=-2 Then linestart = 1 Else linestart = linestart + delta End If '得到行尾位置 lineend = InStr(offset+length,str,vbcrlf) If lineend=0 Then lineend = InStr(offset,str,vblf) End If If lineend=0 Then lineend = InStr(offset,str,vbcr) End If If lineend=0 Then lineend=Len(str) Else lineend = lineend End If If lineend-linestart<=0 Then lineend = linestart + 1 End If '得到行值和坐标 line = Mid(str,linestart,lineend-linestart) x = offset - linestart + 1 y = UBound(Split(Left(str,linestart),vblf)) + 1 End Sub '单击按钮 Sub startsearch() If id.regular.checked Then Call traverse(getref("regularsearch")) Else Call traverse(getref("normalsearch")) End If End Sub '正则搜索回调函数 Function regularsearch(file,str) Dim matches,match,ret,x,y,line If reg.test(str) Then Set matches = reg.execute(str) For Each match In matches Call getposition(str,match.firstindex+1,match.length,x,y,line) fcount = fcount + 1 ret = MsgBox("文件：" & file & vbcrlf & "位置：" & y & "行，" & x & "列" & vbcrlf _ & "匹配：“" & match.value & "”" & vbcrlf & "行值：" & line,vbokcancel,"搜索") If ret=vbcancel Then regularsearch = False Exit Function End If Next End If regularsearch = True End Function '一般搜索回调函数 Function normalsearch(file,str) Dim offset,ret,line,x,y offset = 1 While offset<>0 offset = InStr(offset,str,id.from.value,matchcase) If offset<>0 Then Call getposition(str,offset,Len(id.from.value),x,y,line) If Not id.fullword.checked Or isfullword(str,offset) Then fcount = fcount + 1 ret = MsgBox("文件：" & file & vbcrlf & "位置：" & y & "行，" & x & "列" & vbcrlf _ & "匹配：“" & id.from.value & "”" & vbcrlf & "内容：" & line,vbokcancel,"搜索") If ret=vbcancel Then normalsearch = False Exit Function End If End If offset = offset + 1 End If Wend normalsearch = True End Function '单击按钮 Sub startreplace() If id.regular.checked Then Call traverse(getref("regularreplace")) Else Call traverse(getref("normalreplace")) End If End Sub '正则替换回调函数 Function regularreplace(file,str) Dim matches,match,ret,x,y,line,dest,i,submatch,delta delta = 0 '改动后的偏移量 If reg.test(str) Then Set matches = reg.execute(str) For Each match In matches Call getposition(str,match.firstindex+1+delta,match.length,x,y,line) fcount = fcount + 1 '得到替换后的字符串 dest = id.To.value dest = Replace(dest,"\t",vbtab) dest = Replace(dest,"\n",vbcrlf) dest = Replace(dest,"\0",match.value) i = 1 For Each submatch In match.submatches dest = Replace(dest,"\" & i,submatch) i = i + 1 Next '是否提示 If id.prompt.checked Then ret = MsgBox("文件：" & file & vbcrlf & "位置：" & y & "行，" & x & "列" & delta & "," & match.firstindex & vbcrlf _ & "行值：" & line & vbcrlf & "匹配：“" & match.value & "”" & vbcrlf _ & "替换：“" & dest & "”",vbyesnocancel,"替换") Else ret = vbyes End If '更改字符串 If ret=vbyes Then str = Left(str,match.firstindex+delta) & dest & Mid(str,match.firstindex+1+match.length+delta) delta = delta + Len(dest) - match.length End If If ret=vbcancel Then regularreplace = False Exit Function End If Next End If regularreplace = True End Function '判断是否为整词 Function isfullword(str,offset) reg.pattern = "" '不是汉字字母数字 '不是文件中的第一个字符，并且前一个字符不是汉字，字母，数字 If offset>1 Then If Not reg.test(Mid(str,offset-1,1)) Then isfullword = False Exit Function End If End If '不是文件中的最后一个字符，并且后一个字符不是汉字，字母，数字 If offset+Len(id.from.value)<=Len(str) Then If Not reg.test(Mid(str,offset+Len(id.from.value),1)) Then isfullword = False Exit Function End If End If isfullword = True End Function '一般替换回调函数 Function normalreplace(file,str) Dim offset,ret,line,x,y offset = 1 While offset<>0 offset = InStr(offset,str,id.from.value,matchcase) If offset<>0 Then Call getposition(str,offset,Len(id.from.value),x,y,line) If Not id.fullword.checked Or isfullword(str,offset) Then fcount = fcount + 1 '是否提示 If id.prompt.checked Then ret = MsgBox("文件：" & file & vbcrlf & "位置：" & y & "行，" & x & "列" & vbcrlf _ & "行值：" & line & vbcrlf & "匹配：“" & id.from.value & "”" & vbcrlf _ & "替换：“" & id.To.value & "”",vbyesnocancel,"替换") Else ret = vbyes End If '更改字符串 If ret=vbyes Then str = Left(str,offset-1) & id.To.value & Mid(str,offset+Len(id.from.value)) End If If ret=vbcancel Then normalreplace = False Exit Function End If End If offset = offset + Len(id.To.value) End If Wend normalreplace = True End Function '选择搜索的字符串中的内容 Sub reg1_change() id.from.value = id.from.value & id.reg1.value Call id.from.focus() id.reg1.value = "正则表达式" id.regular.checked = True End Sub '选择替换为字符串中的内容 Sub reg2_change() id.to.value = id.To.value & id.reg2.value Call id.to.focus() id.reg2.value = "正则表达式" id.regular.checked = True End Sub '单击 Sub addfolder() If InStr(id.ext.value,";")=0 Then MsgBox "请至少输入一个分号！",vbcritical Exit Sub End If If Right(id.ext.value,1)<>";" Then MsgBox "请在扩展名末尾添加分号！",vbcritical Exit Sub End If Dim temp,folder temp = showSelFolderDlg If temp="" Then Exit Sub Set folder = fso.getfolder(temp) ext = Split(id.ext.value,";") Call getfilesinfolder(folder) End Sub '获得指定目录下的文件，并根据决定是否递归 Sub getfilesinfolder(folder) Dim i,file,subfolder For Each file In folder.files For i=0 To UBound(ext)-1 If ext(0)="*" Or fso.getextensionname(file.path)=ext(i) Then id.filelist.value = id.filelist.value & file.shortpath & vbcrlf Exit For End If Next Next If id.subfolder.checked Then For Each subfolder In folder.subfolders Call getfilesinfolder(subfolder) Next End If End Sub '单击 Sub addfile() id.filelist.value = id.filelist.value & showSelFilesDlg End Sub '显示选择目录对话框 Function showSelFolderDlg() Dim folder,folderitem Set folder = shellapp.browseforfolder(0,"选择目标文件夹",0) If Not folder Is Nothing Then Set folderitem = folder.items.item showSelFolderDlg = folderitem.path End If End Function '显示选择多文件对话框 Function showSelFilesDlg() Dim intResult,i,temp dlg.Filter = "所有文件|*.*" dlg.Flags = &H0200 intResult = dlg.ShowOpen If intResult <> 0 Then temp = Split(dlg.FileName," ") If UBound(temp) = 0 Then showSelFilesDlg = temp(0) & vbcrlf Else showSelFilesDlg = "" For i=1 To UBound(temp) showSelFilesDlg = showSelFilesDlg & temp(0) & temp(i) & vbcrlf Next End If End If End Function '单击 Sub savelist() Dim name,file name = showSelFileDlg() If name = "" Then Exit Sub Set file = fso.opentextfile(name,forwriting,true) file.write id.filelist.value file.close End Sub '单击 Sub loadlist() Dim name,file name = showSelFileDlg() If name = "" Then Exit Sub Set file = fso.opentextfile(name,forreading,false) id.filelist.value = file.readall file.close End Sub '显示选择单个文件对话框 Function showSelFileDlg() dlg.Filter = "所有文件|*.*" dlg.Flags = &H0000 If dlg.ShowOpen() <> 0 Then showSelFileDlg = dlg.FileName Else showSelFileDlg = "" End If End Function '处理ie进程的退出事件 Sub ie_onquit Set dlg = Nothing Set shell = Nothing Set fso = Nothing Set shellapp = Nothing Set reg = Nothing wscript.disconnectobject ie Set ie = Nothing Call wscript.quit() End Sub '单击 Sub help() Call shell.run(curpath & "\help.chm") End Sub '单击 Sub about() Call MsgBox("感谢您使用《字符串替换脚本v0.1》" & vbcrlf _ & "如果您有什么建议或者问题可以联系" & vbcrlf _ & "sonic_andy ",vbinformation,"关于") End Sub

[ Last edited by sonicandy on 2007-10-8 at 06:54 PM ]

创意
真是有创意呀

好长的代码！写的不错，收藏了。

不能运行中,第九行的UserAccounts.CommonDialog不能创建~~

方便又实在呵呵...

运行出错。

需要下载附件.

第九行的UserAccounts.CommonDialog不能创建~~

附件也不能运行

如果您使用的是 Windows 2000，我们不知道实现此操作的方法，至少操作系统中没有内置这样的方法。但如果您使用的是 Windows XP，情况就不同了。在 Windows XP 上，您可以使用“UserAccounts.CommonDialog”对象向用户显示一个标准的“文件打开”对话框。

摘自
嗨，Scripting Guy！ 我如何向用户显示一个用来选择文件的对话框？
http://www.microsoft.com/china/technet/community/scriptcenter/resources/hey0128.mspx

[ Last edited by sonicandy on 2007-9-8 at 09:43 AM ]

375行:
showSelFilesDlg = temp(0) & ";"
如果单个文件就会因为文件名后面多了个；而导致打开文件错误。
另外读取文件后再打开单个文件由于没有清空内容，会导致打开文件失败。
还有增加目录也会失败。

mountvol朋友,多谢你热心的提出这个脚本的缺陷:

375行:
showSelFilesDlg = temp(0) & ";"
如果单个文件就会因为文件名后面多了个；而导致打开文件错误。

这个问题已经修改,修改方式:把";"替换为vbcrlf

另外读取文件后再打开单个文件由于没有清空内容，会导致打开文件失败。
还有增加目录也会失败。

这个问题我按你说的操作了一下,没有发现错误:
1 选择包含子目录
2 点击添加目录,选择我的文档
3 将读出的所有txt文件列表保存为一个文件list
4 清空文件列表中的内容
5 读入刚才保存的文件列表
6 打开文件
7 增加目录
8 进行搜索操作
请说明一下以上的操作步骤是否有偏差.

[ Last edited by sonicandy on 2007-9-8 at 09:28 PM ]

收藏了，最近在学习vbscript

OK了。。。

[ Last edited by xiaoyao1987 on 2007-10-22 at 10:07 AM ]

根本不行～～～～～～～～～～