'*******************************************************************
'作用:transfer转换文件编码格式
'参数含义:incode为传入的文件编码 outcode转换后的文件编码
'进行判断文件类型是否是ansi类型,如果不是,提供选择是否需要自动更新文件
'*******************************************************************
Function read(path)
'将Byte()数组转成String字符串
Dim ado, a(), i, n
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1 : ado.Open
ado.LoadFromFile path
n = ado.Size - 1
ReDim a(n)
For i = 0 To n
a(i) = ChrW(AscB(ado.Read(1)))
Next
read = Join(a, "")
End Function
Function is_valid_utf8(ByRef input) 'ByRef以提高效率
Dim s, re
Set re = New Regexp
s = "[\xC0-\xDF]([^\x80-\xBF]|$)"
s = s & "|[\xE0-\xEF].{0,1}([^\x80-\xBF]|$)"
s = s & "|[\xF0-\xF7].{0,2}([^\x80-\xBF]|$)"
s = s & "|[\xF8-\xFB].{0,3}([^\x80-\xBF]|$)"
s = s & "|[\xFC-\xFD].{0,4}([^\x80-\xBF]|$)"
s = s & "|[\xFE-\xFE].{0,5}([^\x80-\xBF]|$)"
s = s & "|[\x00-\x7F][\x80-\xBF]"
s = s & "|[\xC0-\xDF].[\x80-\xBF]"
s = s & "|[\xE0-\xEF]..[\x80-\xBF]"
s = s & "|[\xF0-\xF7]...[\x80-\xBF]"
s = s & "|[\xF8-\xFB]....[\x80-\xBF]"
s = s & "|[\xFC-\xFD].....[\x80-\xBF]"
s = s & "|[\xFE-\xFE]......[\x80-\xBF]"
s = s & "|^[\x80-\xBF]"
re.Pattern = s
is_valid_utf8 = (Not re.Test(input))
End Function
Function CheckCode(Sourcefile)
'WScript.echo "Checking: " & Sourcefile
Dim stream
set stream = CreateObject("Adodb.Stream")
stream.Type = 1 'adTypeBinary
stream.Mode = 3 'adModeReadWrite
stream.Open
stream.Position = 0
stream.LoadFromFile Sourcefile
Bin = stream.read(2)
s = read(Sourcefile) '读取文件
if is_valid_utf8(s)=-1 then'判断是否UTF-8
Codes = "utf-8"
msgbox Sourcefile&"文件为"&Codes&"非ansi请注意修改"
'&HEF 239 &HBB 187 &HFF 255 &HFE 254
elseif AscB(MidB(Bin, 1, 1)) = &HEF and _
AscB(MidB(Bin, 2, 1)) = &HBB Then
Codes = "utf-8"
msgbox Sourcefile&"文件为"&Codes&"非ansi请注意修改"
elseif AscB(MidB(Bin, 1, 1)) = &HFF and _
AscB(MidB(Bin, 2, 1)) = &HFE Then
Codes = "unicode"
msgbox Sourcefile&"文件为"&Codes&"非ansi请注意修改"
elseif AscB(MidB(Bin, 1, 1)) = &HFE and _
AscB(MidB(Bin, 2, 1)) = &HFF Then
Codes = "unicode big endian"
msgbox Sourcefile&"文件为"&Codes&"非ansi请注意修改"
Codes = "unicode"
else
Codes = "gb2312"
end if
stream.Close
set stream = Nothing
CheckCode = Codes
end Function
'*******************************************************************
'作用:transfer转换文件编码格式
'参数含义:incode为传入的文件编码 outcode转换后的文件编码
'*******************************************************************
Function transfer(inFile,incode,outcode,outfile)
Set instream = CreateObject("Adodb.Stream")
Set outstream = CreateObject("Adodb.Stream")
'Open input file
instream.Type = 2 'adTypeText
instream.Mode = 3 'adModeReadWrite
instream.Charset = inCode
instream.Open
instream.LoadFromFile inFile
'Read input file
content = instream.ReadText
'Close input file
instream.Close
Set instream = Nothing
'Open output file
outstream.Type = 2 'adTypeText
outstream.Mode = 3 'adModeReadWrite
outstream.Charset = outCode
outstream.Open
'Write to output file
outstream.WriteText content
outstream.SaveToFile outFile, 2 'adSaveCreateOverWrite
outstream.flush
'Close output file
outstream.Close
Set outstream = Nothing
end Function
'*******************************************************************
'作用:GetDirectory获取当前目录
'参数含义:
'*******************************************************************
Function GetDirectory()
Dim WshShell
Set WshShell=CreateObject("WScript.Shell")
GetDirectory = WshShell.CurrentDirectory
Set WshShell = nothing
End Function
'*******************************************************************
'*******************************************************************
'作用:rrubstr取字符串istr中的sign字符串后面的子字符串;从字符串尾部搜索的位置
'参数含义:
'*******************************************************************
Function rsubstr (istr, sign)
Dim fnum,substr
fnum = instrRev (istr,sign) + Len(sign) - 1
substr = Right (istr,Len(istr)-fnum)
rsubstr = substr
End Function
'*******************************************************************
'作用:
'参数含义:
'*******************************************************************
Function Main()
'创建新文件
Set nfso = CreateObject("Scripting.FileSystemObject")
'遍历一个文件夹下的所有文件
Set oFso = CreateObject("Scripting.FileSystemObject")
fold = GetDirectory()&"\"
Set oFolder = oFso.GetFolder(fold)
Dim inFile
isExist = 0
isTransfer = 0
isCount = 0
Set oFiles = oFolder.Files
'对每个文件进行处理
For Each oFile In oFiles
inFile = oFile.path
if rsubstr(inFile,".") <> "vbs" then
isCount = isCount +1
incode = CheckCode (infile)
outcode ="gb2312"
if incode <> outcode then
choice = Msgbox(inFile & " is not ansi,请注意!" & vbCrlf & _
" Do you want to transfer it?", vbQuestion + vbYesNo, _
"Output file has been existed")
if choice = vbYES then
transfer inFile,incode,outcode,inFile
'msgbox inFile &"格式转换成功!"
isTransfer = isTransfer +1
end if
isExist = isExist+1
end if
end if
Next
set nfso = nothing
set ntf = nothing
set oFolder = nothing
set oFiles = nothing
msgbox "共检查文件:"&isCount&",发现格式不对文件:"&isExist&",共转换成功文件:"&isTransfer
End Function
Main