各位高手，小弟献丑了。
还有许多不足之处请多多指教。
[ Last edited by sonicandy on 2007-10-8 at 06:54 PM ]
还有许多不足之处请多多指教。
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 ]
本帖最近评分记录
（共 3 条）
点击查看详情
