批量全角转半角 - 中国DOS联盟论坛 - 中国DOS联盟之联合DOS论坛

以前收藏一个全角转半角的VBS脚本，但是不能批量操作，发上来，请高手修改下，使之能对整个目录下的文本文档进行操作。谢谢！要是同时能在Emeditor中调用就更好了。

-------------------------------------------------------------------------------------------------
Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile("原文件.txt",1)
Set objOut = objFSO.CreateTextFile("目的文件OK.TXT",True)

Do Until objFile.AtEndOfStream
text = objFile.Read(1)
if text <> "" then
CALL convertstr(text)
end if
objOut.Write(strCharacters)
Loop

function convertstr(content)
Dim SBC,halfSBC,DBC,halfDBC,QJnum,BJnum

SBC = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ＇"
halfSBC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ'"
DBC = "ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ"
halfDBC = "abcdefghijklmnopqrstuvwxyz"
QJnum="０１２３４５６７８９"
BJnum="0123456789"

Dim S(27),hS(27),D(26),hD(26),Qnum(27),Bnum(27)

for i = 1 to 27
S(i-1) = mid(SBC,i,1)
hS(i-1) = mid(halfSBC,i,1)

content = replace(content,S(i-1),hS(i-1))

D(i-1) = mid(DBC,i,1)
hD(i-1) = mid(halfDBC,i,1)

content = replace(content,D(i-1),hD(i-1))

Qnum(i-1) = mid(QJnum,i,1)
Bnum(i-1) = mid(BJnum,i,1)

content = replace(content,Qnum(i-1),Bnum(i-1))

next

content = replace(content,chr(13)&chr(10),"<br>")
content = replace(content,"　"," ")
contentstr = content

objOut.write ("")
objOut.write(contentstr)
end function
-------------------------------------------------------------------------------------------------

[ Last edited by bjsh on 2007-7-31 at 11:16 AM ]

'只对当前目录有效


QJ=Split("Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ Ｋ Ｌ Ｍ Ｎ Ｏ Ｐ Ｑ Ｒ Ｓ Ｔ Ｕ Ｖ Ｗ Ｘ Ｙ Ｚ ａ ｂ ｃ ｄ ｅ ｆ ｇ ｈ ｉ ｊ ｋ ｌ ｍ ｎ ｏ ｐ ｑ ｒ ｓ ｔ ｕ ｖ ｗ ｘ ｙ ｚ ０ １ ２ ３ ４ ５ ６ ７ ８ ９ ＇")
BJ=Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 '")
set fso=createobject("scripting.filesystemobject")
if not fso.folderexists("替换后的文件") then fso.createfolder ("替换后的文件")
set folder=fso.getfolder(".")
for each file in folder.files
  if ucase(right(file,3))="TXT" then Myreplace(file)
next
msgbox "替换成功！请查看替换后的文件！",4096,"提示"

sub Myreplace(w)
set file=fso.opentextfile(w)
n=file.readall
file.close

l=ubound(qj)
for i=0 to l
  n=Replace(n,QJ(i),Bj(i))
next

set file=fso.createtextfile("替换后的文件\" & fso.getfilename(w))
file.write n
file.close
end sub

（）《》好象还少符号了……

￥还有省略号什么的……

也来一个，只做演示用，利用相同的思路可以写出比较完善的脚本。
同样只针对根目录，对子目录无效，不过稍做修改就可以支持子目录，以前有过多次讨论，为了简化脚本，这里就略过了。

    sFolder = "C:\Documents and Settings\xxx\桌面\c"

'**************************************************************************
'Main
Set oShell = CreateObject("Shell.Application")
Set oDir = oShell.NameSpace(sFolder)
    
    For Each itemFile In oDir.Items
        If itemFile.Size > 0 And itemFile.Type = "文本文档" Then 
            Convert itemFile.Path,itemFile.Path & ".new"  '可自行修改第二个参数
            strList = strList & itemFile.Path & vbCrLf
        End If
    Next
    
    WScript.Echo "转换完毕，被转换的文件列表如下:" & strList
Set oDir = Nothing
Set oShell = Nothing
'**************************************************************************

'转换过程
Sub Convert(strFile,strNewFile)

	Dim objFSo,objSrcFile,objDstFile
	Dim strTmp,intAsc
        Dim boolFlag
    
    '若原文件名与新文件名相同，则标志置位
    If LCase(strFile) = LCase(strNewFile) Then
        boolFlag = True
        strNewFile = strNewFile & ".tmp"
    Else
        boolFlag = False
    End If
    
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	Set objSrcFile = objFSO.OpenTextFile(strFile,1)
        Set objDstFile = objFSO.OpenTextFile(strNewFile,2,True)
'************************************************************************
	'核心算法:
	'ASCII中可对应显示的字符从33-125分别对应的全角字符编码差值为-23680
	
	'注意:$(36)对应的全角,
	'在中文字符集中编码为￥(-23644),而在英文字符集中为＄(-24089)
	
	'另外对于^符号在全角中文字符集中会被两个...(半个省略号，编辑器
	'不支持,故用3个点代替),并没有做处理
	
	'由于中文字符集和英文字符集的差别，可能存在其他Bug，可以根据需要修改
'************************************************************************	
	    Do 
	        strTmp = objSrcFile.Read(1)
	        intAsc = Asc(strTmp)
	        If intAsc < -23554 And intAsc > -23648 Then
	            objDstFile.Write Chr(23680 + intAsc)
	        ElseIf intAsc = -24159 Then
	            objDstFile.Write " "
	        ElseIf intAsc = -24089 Then
	            objDstFile.Write "$"
	        Else
	            objDstFile.Write strTmp
	        End If
	    Loop Until objSrcFile.AtEndOfStream
	
	    objDstFile.Close
	    objSrcFile.Close
	    
	    '删除原文件，改新文件名为原文件名
	    If boolFlag Then
	        objFSo.DeleteFile strFile
	        objFSO.MoveFile strNewFile,strFile
	    End If
	    
	Set objSrcFile = Nothing
	Set objDstFile = Nothing
	Set objFSO = Nothing

End Sub

第1楼　flyboy612	发表于 2007-06-24 21:23
新手上路　发帖 6　积分 15
[求助]批量全角转半角以前收藏一个全角转半角的VBS脚本，但是不能批量操作，发上来，请高手修改下，使之能对整个目录下的文本文档进行操作。谢谢！要是同时能在Emeditor中调用就更好了。 ------------------------------------------------------------------------------------------------- Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFile = objFSO.OpenTextFile("原文件.txt",1) Set objOut = objFSO.CreateTextFile("目的文件OK.TXT",True) Do Until objFile.AtEndOfStream text = objFile.Read(1) if text <> "" then CALL convertstr(text) end if objOut.Write(strCharacters) Loop function convertstr(content) Dim SBC,halfSBC,DBC,halfDBC,QJnum,BJnum SBC = "ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ＇" halfSBC = "ABCDEFGHIJKLMNOPQRSTUVWXYZ'" DBC = "ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ" halfDBC = "abcdefghijklmnopqrstuvwxyz" QJnum="０１２３４５６７８９" BJnum="0123456789" Dim S(27),hS(27),D(26),hD(26),Qnum(27),Bnum(27) for i = 1 to 27 S(i-1) = mid(SBC,i,1) hS(i-1) = mid(halfSBC,i,1) content = replace(content,S(i-1),hS(i-1)) D(i-1) = mid(DBC,i,1) hD(i-1) = mid(halfDBC,i,1) content = replace(content,D(i-1),hD(i-1)) Qnum(i-1) = mid(QJnum,i,1) Bnum(i-1) = mid(BJnum,i,1) content = replace(content,Qnum(i-1),Bnum(i-1)) next content = replace(content,chr(13)&chr(10),"<br>") content = replace(content,"　"," ") contentstr = content objOut.write ("") objOut.write(contentstr) end function ------------------------------------------------------------------------------------------------- [ Last edited by bjsh on 2007-7-31 at 11:16 AM ]

第2楼　jmz573515	发表于 2007-06-26 08:44
银牌会员　发帖 464　积分 1,212
'只对当前目录有效 QJ=Split("ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ０１２３４５６７８９＇") BJ=Split("A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 '") set fso=createobject("scripting.filesystemobject") if not fso.folderexists("替换后的文件") then fso.createfolder ("替换后的文件") set folder=fso.getfolder(".") for each file in folder.files if ucase(right(file,3))="TXT" then Myreplace(file) next msgbox "替换成功！请查看替换后的文件！",4096,"提示" sub Myreplace(w) set file=fso.opentextfile(w) n=file.readall file.close l=ubound(qj) for i=0 to l n=Replace(n,QJ(i),Bj(i)) next set file=fso.createtextfile("替换后的文件\" & fso.getfilename(w)) file.write n file.close end sub

第3楼　slore	发表于 2007-06-26 12:16
铂金会员　发帖 2,478　积分 5,212
（）《》好象还少符号了…… ￥还有省略号什么的……

第4楼　3742668	发表于 2007-06-26 13:25
荣誉版主　发帖 718　积分 2,013
也来一个，只做演示用，利用相同的思路可以写出比较完善的脚本。同样只针对根目录，对子目录无效，不过稍做修改就可以支持子目录，以前有过多次讨论，为了简化脚本，这里就略过了。 sFolder = "C:\Documents and Settings\xxx\桌面\c" '************************************************************************ 'Main Set oShell = CreateObject("Shell.Application") Set oDir = oShell.NameSpace(sFolder) For Each itemFile In oDir.Items If itemFile.Size > 0 And itemFile.Type = "文本文档" Then Convert itemFile.Path,itemFile.Path & ".new" '可自行修改第二个参数 strList = strList & itemFile.Path & vbCrLf End If Next WScript.Echo "转换完毕，被转换的文件列表如下:" & strList Set oDir = Nothing Set oShell = Nothing '********************************************************************** '转换过程 Sub Convert(strFile,strNewFile) Dim objFSo,objSrcFile,objDstFile Dim strTmp,intAsc Dim boolFlag '若原文件名与新文件名相同，则标志置位 If LCase(strFile) = LCase(strNewFile) Then boolFlag = True strNewFile = strNewFile & ".tmp" Else boolFlag = False End If Set objFSO = CreateObject("Scripting.FileSystemObject") Set objSrcFile = objFSO.OpenTextFile(strFile,1) Set objDstFile = objFSO.OpenTextFile(strNewFile,2,True) '******************************************************************** '核心算法: 'ASCII中可对应显示的字符从33-125分别对应的全角字符编码差值为-23680 '注意:$(36)对应的全角, '在中文字符集中编码为￥(-23644),而在英文字符集中为＄(-24089) '另外对于^符号在全角中文字符集中会被两个...(半个省略号，编辑器 '不支持,故用3个点代替),并没有做处理 '由于中文字符集和英文字符集的差别，可能存在其他Bug，可以根据需要修改 '********************************************************************** Do strTmp = objSrcFile.Read(1) intAsc = Asc(strTmp) If intAsc < -23554 And intAsc > -23648 Then objDstFile.Write Chr(23680 + intAsc) ElseIf intAsc = -24159 Then objDstFile.Write " " ElseIf intAsc = -24089 Then objDstFile.Write "$" Else objDstFile.Write strTmp End If Loop Until objSrcFile.AtEndOfStream objDstFile.Close objSrcFile.Close '删除原文件，改新文件名为原文件名 If boolFlag Then objFSo.DeleteFile strFile objFSO.MoveFile strNewFile,strFile End If Set objSrcFile = Nothing Set objDstFile = Nothing Set objFSO = Nothing End Sub