vbs批量替换word中部分文本 vbs批量修改WORD文档
VBS \u5faa\u73af\u66ff\u6362\u591a\u4e2a\u6587\u672c\u4e2d\u7684\u5b57\u7b26\u652f\u6301\u62d6\u653e\u529f\u80fd \u4f60\u53ea\u8981\u628a\u6574\u4e2a\u6587\u4ef6\u5939\u62d6\u653e\u5230\u8fd9\u4e2avbs\u6587\u4ef6\u4e0a\u5c31\u53ef\u4ee5\u4e86 \u4ed6\u4f1a\u81ea\u52a8\u8bc6\u522btxt\u683c\u5f0f\u7684\u6587\u4ef6\u5e76\u4fee\u6539
For Each a In WScript.Arguments
w=w&a
Next
set ws=createobject("wscript.shell")
set fso=createobject("scripting.filesystemobject")
set folder=fso.getfolder(w)
set files=folder.files
for each file in files
d=File.name
s = Instr(1, d, "txt")
if s 0 then
scan(file)
end if
next
function scan(file)
set fso=createobject("scripting.filesystemobject")
set fil=fso.opentextfile(file)
s=fil.readall
fil.close
set fi=fso.opentextfile(file,2)
s=Replace(s,"\u4f60\u8981\u66ff\u6362\u7684\u5b57\u7b26","\u4f60\u8981\u66ff\u6362\u6210\u7684\u5b57\u7b26")
fi.write s
fi.close
end function
\u4f30\u8ba1\u53ea\u80fd\u8bd5\u8bd5\u8fd9\u6b3e\u4e86\uff01\u5982\u4e0b\u56fe\uff0c\u9009\u62e9\u6279\u66ff\u6362\u529f\u80fd\u5361\uff0c\u9009\u62e9\u9898doc\u7c7b\u578b\uff0c\u6dfb\u52a0\u4e00\u4e2a\u6a21\u677f\u6587\u4ef6\u5165\u5217\u8868\uff0c\u542f\u7528\u6279\u66ff\u6362\u8bbe\u7f6e\u3002
\u7136\u540e\u5982\u4e0b\u56fe\uff0c\u52fe\u9009\u66ff\u6362\u540e\u7edf\u4e00\u4fdd\u5b58\uff0c\u518d\u52fe\u9009\u6765\u81eaxls\u4e2d\u7684\u6bcf\u4e00\u884c\u3002\u6ce8\u610f\u4f60\u7684txt\u6587\u4ef6\u8981\u5148\u7528Excel\u6253\u5f00\uff0c\u7136\u540e\u518d\u53e6\u5b58\u4e3axls\u5373\u53ef\u3002\u7136\u540e\u5c06\u9700\u8981\u66ff\u6362\u7684\u6807\u8bb0\u5f55\u5165\u5217\u8868\u4e2d\uff0c\u5982\u4e0b\u56fe\u6240\u793a\u3002
方法如下：
把一批.doc文件拖拽到这个VBS文件上，松开手，再按提示运作就行了。
不打开doc文件就能够批量替换的vbs程序
On Error Resume next
Set objWord = CreateObject("Word.Application")
If Wscript.Arguments.Count <> 0 Then
Findstr=InputBox(chr(13)&" 输入要查找的字符串 ", "输入查找字符","vbs")
If Findstr = "" Then WScript.Quit
replstr=InputBox(chr(13)&" 输入要替换的字符串 ", "输入替换字符","word vba")
For i=0 To WScript.Arguments.Count-1
filepath=WScript.Arguments(i)
kkk(filepath)
Next
objWord.Documents.close
else
WScript.Quit
End Ifsub kkk(abcpath)
objWord.Visible = True
Set objDoc = objWord.Documents.Open(abcpath)
Set objSelection = objWord.Selection
objSelection.HomeKey 6
With objSelection.Find
.Text = Findstr
.Replacement.Text = replstr
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Execute ,,,,,,,,,,2
End With
objWord.Documents.Save
end sub
''''''''''''''''''''''''''''''''''''''''''''''''''''
'''递归遍历DOC文档,替换单词后生成新DOC文件(原文件名前加上:new_)
'''请把本VBS文件放入有DOC文档的目录中运行
'''关键点:打开DOC文档读取内容,创建DOC文档写入内容
'''处理结果报告文件:index.html
'''设计:daode1212,QQ:1501488900,2014-03-26
''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim c '''count files
indexFile = "index.html" '生成文件目录列表
Set WshShell = CreateObject("WSCRIPT.SHELL")
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the current directory :
'WScript.Echo WshShell.CurrentDirectory
way = WshShell.CurrentDirectory & "\"
Set lst = FSO.OpenTextFile(way & indexFile, 8, 1)
hdstr = "<body bgcolor='#ddeeff'><center><h2>递归遍历DOC文档,替换单词后生成新DOC文件</h2><table border='1' align='center' bgcolor='#f0f0f0'>"
hdstr = hdstr & "<th>文件列表</th><th>文件路径与新文件名</th>"
''''''''''''''''''''''''''''''''''
EveryFile way ''' 调用遍历与替换主过程
''''''''''''''''''''''''''''''''''
hdstr = hdstr & "</table>"
MsgBox c & " 个文件处理(目录: " & way & ") 已经完成 . ---------by daode1212 2014-03-26"
lst.Write hdstr
Set FSO = Nothing
WshShell.run "iexplore.exe " & way & indexFile
'''##################################################
'遍历文件夹与文件:
Function EveryFile(way)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f = FSO.GetFolder(way)
Set fc = f.SubFolders
Set fs = f.Files
'遍历子文件夹
For Each fd In fc
EveryFile (fd & "\")
Next
'遍历所有文件:
For Each Fi In fs
ef = Fi.Name
If InStr(ef, ".doc") > 0 Then ReplacText way, ef
Next
Set FSO = Nothing
End Function
'''##################################################
'内容替换:
Sub ReplacText(way, fname)
'for read word document =============================================:
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fi = FSO.OpenTextFile(way & fname, 1)
Ftxt = LCase(Fi.ReadAll)
Set wdObj = CreateObject("Word.Application")
Set wd = wdObj.Documents.Open(way & fname)
'''wd.Activate
allstr = wd.Content
'''从下行中修改自己想要的替换:
If InStr(allstr, "张三") = 0 Then
wd.Close
wdObj.Quit
Exit Sub
Else
allstr = Replace(allstr, "张三", "李四")
End If
wd.Close
wdObj.Quit
Set wd = Nothing
Set wdObj = Nothing
'for write word document =============================================:
Set Doc = CreateObject("Word.Application")
Set DocWord = Doc.Documents.Add()
Doc.Selection.TypeText allstr
'''修改下行以生成不同的新文件:
DocWord.saveas way & "new_" & fname
DocWord.Close
Doc.Quit
Set DocWord = Nothing
Set Doc = Nothing
'for table log =========================================:
c = c + 1
hdstr = hdstr & "<tr><td>" & c & "</td><td>:" & way & " new_" & fname & "</td></tr>"
End Sub
'''##################################################
'''==================================================
如针对word页眉页脚,参考一下以下代码:
怎样用VBA读取word页眉页脚？
'Sub Example()
'Dim myRange As Range
首页页眉 ' Set myRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Range
'Debug.Print myRange.Text
偶数页页眉 ' Set myRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterEvenPages).Range
'Debug.Print myRange.Text
基本页眉 ' Set myRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
' Debug.Print myRange.Text
'End Sub
其中，如果节中只使用一种页眉（基本页眉时），请使用以下代码返回
'Set myRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
'Debug.Print myRange.Text
#vba
自己录制一个宏：点开工具→宏→录制宏→开始录制→查找→张三→替换为→李四→全部替换→停止录制。
点开其他的文档，直接运行该宏即可。
试试？
绛旓細鏂规硶濡備笅锛氭妸涓鎵.doc鏂囦欢鎷栨嫿鍒拌繖涓猇BS鏂囦欢涓婏紝鏉惧紑鎵嬶紝鍐嶆寜鎻愮ず杩愪綔灏辫浜銆備笉鎵撳紑doc鏂囦欢灏辫兘澶熸壒閲忔浛鎹㈢殑vbs绋嬪簭 On Error Resume nextSet objWord = CreateObject("Word.Application") If Wscript.Arguments.Count <> 0 ThenFindstr=InputBox(chr(13)&" 杈撳叆瑕佹煡鎵剧殑瀛楃涓 ", "杈撳叆鏌ユ壘瀛楃",...
绛旓細浼拌鍙兘璇曡瘯杩欐浜嗭紒濡備笅鍥撅紝閫夋嫨鎵规浛鎹㈠姛鑳藉崱锛岄夋嫨棰榙oc绫诲瀷锛屾坊鍔犱竴涓ā鏉挎枃浠跺叆鍒楄〃锛屽惎鐢ㄦ壒鏇挎崲璁剧疆銆傜劧鍚庡涓嬪浘锛屽嬀閫夋浛鎹㈠悗缁熶竴淇濆瓨锛屽啀鍕鹃夋潵鑷獂ls涓殑姣忎竴琛屻傛敞鎰忎綘鐨則xt鏂囦欢瑕佸厛鐢‥xcel鎵撳紑锛岀劧鍚庡啀鍙﹀瓨涓簒ls鍗冲彲銆傜劧鍚庡皢闇瑕鏇挎崲鐨鏍囪褰曞叆鍒楄〃涓紝濡備笅鍥炬墍绀恒
绛旓細鎶娾滃弻澹佸崟褰扁濆拰鈥淪D鈥濅繚瀛樺湪鏂囨湰鏂囦欢閲岋紝涓棿鐢ㄨ烦鏍奸敭闅斿紑锛孷BA澧炲姞浠ヤ笅浠ｇ爜锛欴im Key As String, arrKey() As String, Key1 As String, Key2 As String If Dir(ActiveDocument.Path & "\keys.txt") = "" Then MsgBox "鏃犳硶鎵惧埌keys.txt锛"Open ActiveDocument.Path & "\keys.txt" For ...
绛旓細绗竴娆鏇挎崲锛氭煡鎵撅細锛([!^13锛塢@)锛([!^13]@)锛([!^13锛塢@)锛([!^13]@)锛([!^13锛塢@)锛([!^13]@)^13 鏇挎崲锛氾紙锛塡2锛堬級\4锛堬級\6銆愭纭瓟妗堛慭1|\3|\5^13 绗簩娆℃浛鎹細鏌ユ壘锛氾紙([!^13锛塢@)锛([!^13]@)锛([!^13锛塢@)锛([!^13]@)^13 鏇挎崲锛氾紙锛塡2锛堬級...
绛旓細set "word1=!word1:浣犲ソ=鏇挎崲鍚!" set "word2=!word1!" echo,!word2! >>"%%~ni.tmp" ) del "%%~i" "%%~i.ansi" /f /q set aCode=GB2312 set bCode=UTF-8 call :CreatConvertTool ConvertTool.vbs "%%~ni....
绛旓細杈句汉鏄粈涔堜笢瑗匡紝绠椾簡杩樻槸鍛婅瘔浣犲惂锛屽湪excel涓湪绗竴鍒楀彸鍑伙紝鎻掑叆锛屾暣鍒楋紝鐒跺悗灏嗙浜屽垪鐨勪笢瑗垮鍒剁矘璐村埌鏂扮殑绗竴鍒楋紝杩欐槸绗簩鍒楀彉绗竴鍒椼傛垜鎯崇涓鍒楀彉绗簩鍒椾綘涔熶細浜嗭紝椤电湁椤佃剼鍐嶇敤Word閲岀殑椤电湁璁剧疆鍘讳娇鐢ㄣ傗滅湡绌篧ORD鏂囨。鎵瑰鐞嗙▼搴忊濓紝杩欎釜绋嬪簭涓嶅ソ锛屼綘鍙互瀛︿竴浜涜繖绫昏绠楁満璇█锛岃繍琛屼竴涓嬪氨琛...
绛旓細鍙互鐢ㄨ剼鏈潵鍋氥1銆佺敤璁颁簨鏈柊寤轰竴涓枃鏈枃浠讹紝鎶婂畠淇濆瓨涓衡鎵归噺閲嶅懡鍚.vbs鈥濓紙娉ㄦ剰涓嶈寮勬垚浜嗏滄壒閲忛噸鍛藉悕.vbs.txt鈥濓紝涔熷氨鏄纭繚鍏舵墿灞曞悕涓衡.vbs鈥濓級锛2銆佹妸涓嬪垪浠ｇ爜绮樿创鍒拌繖涓VBS鏂囦欢涓細Option Explicit Const g_strRootPath = "c:\Temp\docs\Word\ToRename\" ' 鎸囧畾瀛樻斁鎵鏈夋枃浠剁殑鐩綍...
绛旓細浣犺繖涓棶棰樻弿杩板緱鏈夌偣鍋忓樊锛屽簲璇ユ槸鐢ㄤ簬鐢佃剳鎿嶄綔鑰冭瘯鐨鍚э紵鎴戝杩欎釜闂鐨勭悊瑙ｅ涓嬶細1銆佹墦寮vbs锛岀偣鍑伙紓鏂囦欢锛傦紝閫夋嫨锛傚彟瀛樹负锛傦紝鎶婂悕绉伴偅涓鏉℃敼涓篶锛巇oc锛岀劧鍚庣偣淇濆瓨锛宑锛巇oc灏卞缓濂戒簡锛堟鏃朵笉瑕佸叧闂繖涓枃妗ｏ級銆2銆佸垎鍒墦寮a銆乥鏂囨。锛堟鏃朵笅闈换鍔℃潯涓婂氨鍚屾椂鎵撳紑浜咰銆乤銆乥涓変釜鏂囨。锛夛紝鍒囨崲鍒癮鏂囨。...
绛旓細1.棣栧厛浠庣數鑴戜笂涓嬭浇2345濂藉帇锛屼笅杞藉悗瀹夎銆2.瀹夎瀹屾垚鍚庯紝鍙屽嚮濂藉帇蹇嵎鍥炬爣锛屽脊鍑哄ソ鍘嬩富鐣岄潰銆3.鐐瑰嚮涓棿涓婇潰鐨宸ュ叿绠憋紝鐪嬭娌★紝鎵归噺鏂囦欢鏀瑰悕銆4.浠庝笂鍒颁笅锛岀湅绠ご锛屾兂鏀瑰暐鍚嶅瓧鎬庢牱鏀广5.涓句釜渚嬪瓙銆
