|
7#
楼主 |
发表于 2008-8-26 09:50:08
|
只看该作者
''拿出来给大家看看 昨天搞了好长时间才搞出来 大家看了要顶啊 ''
''读取列表,把试卷处理成如:"中 zhong1"
''Date: 2008-8-25
''
Function DealPinYin(strPinYin, ByRef arrayPinYin())
Dim index
Dim i
index = 0
'几个字的拼音
For i = 0 To Len(strPinYin) - 1
If Mid(strPinYin, i + 1, 1) = "|" Then '每个字的拼音用'|'分隔
index = index + 1
End If
Next
ReDim arrayPinYin(index) '动态数组大小, 日哦,难用极了
index = 0
For i = 0 To Len(strPinYin) - 1
If Mid(strPinYin, i + 1, 1) <> "|" Then '每个字的拼音用'|'分隔
arrayPinYin(index) = arrayPinYin(index) + Mid(strPinYin, i + 1, 1)
Else
'---------------------------------------------------------
arrayPinYin(index) = Left(arrayPinYin(index),1) + chr(9) + Mid(arrayPinYin(index),2,Len(arrayPinYin(index))-2) + chr(9) + Right(arrayPinYin(index),1)
'---------------------------------------------------------
index = index + 1
End If
Next
'---------------------------------------------------------
arrayPinYin(index) = Left(arrayPinYin(index),1) + chr(9) + Mid(arrayPinYin(index),2,Len(arrayPinYin(index))-2) + chr(9) + Right(arrayPinYin(index),1)
'---------------------------------------------------------
End Function
Function DealHanZi(strHanZi, ByRef arrayHanZi())
Dim index
Dim i
On Error Resume Next '出错后跳到下一句
ReDim arrayHanZi(Len(strHanZi) / 2) '汉字占2个字节
index = 0
For i = 0 To Len(strHanZi) - 1
arrayHanZi(index) = Mid(strHanZi, i + 1, 1)
index = index + 1
Next
End Function
Function DoProcess(path, OutFileName)
Dim iCount
Dim strOneLine
Dim PinYin()
Dim HanZi()
Dim doPinYin
Dim doHanZi
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set fileObj = fsObj.OpenTextFile(path)
Set fsOutObj = CreateObject("Scripting.FileSystemObject")
Set fileOutObj = fsOutObj.CreateTextFile(OutFileName, True)
iCount = 0
'到行,处理:汉字、拼音、空行
While Not fileObj.atEndOfStream
strOneLine = fileObj.readline
strOneLine = Replace(strOneLine, " ", "") '去空格
strOneLine = Replace(strOneLine, Chr(9), "") '删除Tab
'---------------------------------------------------------
strOneLine = Replace(strOneLine, "~", "") '
strOneLine = Replace(strOneLine, "#", "") '
'---------------------------------------------------------
If Len(strOneLine) > 0 Then '不是空行
If Asc(strOneLine) > Asc("a") And Asc(strOneLine) < Asc("z") Then '拼音行
'---------------------------------------------------------
strOneLine = Replace(strOneLine, "zh", "!") '
strOneLine = Replace(strOneLine, "ch", "@") '
strOneLine = Replace(strOneLine, "sh", "#") '
'---------------------------------------------------------
DealPinYin strOneLine, PinYin
doPinYin = True
Else
DealHanZi strOneLine, HanZi
doHanZi = True
End If
'输出结果
If doPinYin And doHanZi Then
For i = 0 To UBound(PinYin)
strOneLine = HanZi(i) + Chr(9) + PinYin(i)
'---------------------------------------------------------
strOneLine = Replace(strOneLine, "!", "zh") '
strOneLine = Replace(strOneLine, "@", "ch") '
strOneLine = Replace(strOneLine, "#", "sh") '
'---------------------------------------------------------
fileOutObj.WriteLine (strOneLine)
Next
doPinYin = False
doHanZi = False
End If
End If
iCount = iCount + 1
Wend
fileOutObj.Close
End Function
'''''''''''main()'''''''''''
On Error Resume Next '出错后跳到下一句
Set fsList = CreateObject("Scripting.FileSystemObject")
Set objList = fsList.OpenTextFile("list.txt")
If Err.Number <> 0 Then
MsgBox ("list.txt文件不存在")
End If
Dim i
Dim iPos
Dim strOneLine
Dim strFileName
While Not objList.atEndOfStream
strOneLine = objList.readline
strOneLine = Replace(strOneLine, " ", "") '去空格
strOneLine = Replace(strOneLine, Chr(9), "") '删除Tab
If Len(strOneLine) > 0 Then '不是空行
'找出文件名开始的位置
iPos = InStrRev(strOneLine, "\", -1, 1)
If iPos > 0 Then strFileName = Right(strOneLine, Len(strOneLine) - iPos)
DoProcess strOneLine, strFileName
End If
Wend
[ 本帖最后由 lingxin5013 于 2008-8-26 10:16 编辑 ] |
|