''This macro is a online translations macro program for strings
''in Passolo translation list.
''It has the following features:
''- Use the online translation engine automatically translate strings
'' in the Passolo translation list
''- Integrated some of the well-known online translation engines, and
'' you can customize other online translation engines
''- You can choose the string type, skiping some of string, and processing
'' the strings before and after translation
''- Integrated shortcuts, terminators, Accelerator check macro, and you can
'' check and correct errors in translations after the strings has be translated
''Idea and implemented by wanfu 2010.05.12 (modified on 2011.12.08)
Public UIFileList() As String,UIDataList() As String,UILangList() As String,LangFile As String
Public acckeySrc As String,EndStringSrc As String,ShortcutSrc As String,EndSpaceSrc As String
Public acckeyTrn As String,EndStringTrn As String,ShortcutTrn As String,EndSpaceTrn As String
Public SpaceTrn As String,PreStringTrn As String,ExpStringTrn As String,MoveAcckey As String
Public PreSpaceSrc As String,PreSpaceTrn As String,srcAccKeyNum As Long,trnAccKeyNum As Long
Public AllCont As Long,AccKey As Long,EndChar As Long,Acceler As Long
Public DefaultCheckList() As String,AppRepStr As String,PreRepStr As String
Public CheckDataList() As String,CheckDataListBak() As String
Public DefaultProjectList() As String,ProjectDataList() As String
Public DefaultEngineList() As String,EngineDataList() As String,tSelected() As String,WaitTimes As Long
Private Const Version = "2011.11.28"
Private Const ToUpdateEngineVersion = "2011.05.29"
Private Const ToUpdateCheckVersion = "2011.11.14"
Private Const EngineRegKey = "HKCU\Software\VB and VBA Program Settings\WebTranslate"
Private Const EngineFilePath = MacroDir & "\Data\PSLWebTrans.dat"
Private Const CheckRegKey = "HKCU\Software\VB and VBA Program Settings\AccessKey"
Private Const CheckFilePath = MacroDir & "\Data\PSLCheckAccessKeys.dat"
Private Const JoinStr = vbFormFeed 'vbBack
Private Const SubJoinStr = vbVerticalTab 'Chr$(1)
Private Const LngJoinStr = "|"
Private Const SubLngJoinStr = Chr$(1)
Private Const NullValue = "Null"
Private Const DefaultObject = "Microsoft.XMLHTTP"
Private Const updateAppName = "PSLWebTrans"
'翻译引擎默认设置
Function EngineSettings(DataName As String) As String
Dim StesArray(19) As String
If DataName = DefaultEngineList(0) Then
StesArray(0) = DefaultObject
StesArray(1) = "fefed727-bbc1-4421-828d-fc828b24d59b"
StesArray(2) = "http://api.microsofttranslator.com/V2/Http.svc/Translate?"
StesArray(3) = "{Url}&appId={appId}&text={text}&from={from}&to={to}"
StesArray(4) = "GET"
StesArray(5) = "False"
StesArray(6) = ""
StesArray(7) = ""
StesArray(8) = ""
StesArray(9) = "Content-Type,application/xml; charset=utf-8"
StesArray(10) = "responseText"
StesArray(11) = "Serialization/"">"
StesArray(12) = "</string>"
StesArray(13) = "Serialization/"">"
StesArray(14) = "</string>"
StesArray(15) = "Serialization/"">"
StesArray(16) = "</string>"
StesArray(17) = "string"
StesArray(18) = "string"
StesArray(19) = "1"
ElseIf DataName = DefaultEngineList(1) Then
StesArray(0) = DefaultObject
StesArray(1) = ""
StesArray(2) = "http://translate.google.com/translate_t?"
StesArray(3) = "{Url}&text={text}&langpair={from}|{to}"
StesArray(4) = "POST"
StesArray(5) = "False"
StesArray(6) = ""
StesArray(7) = ""
StesArray(8) = ""
StesArray(9) = "Content-Type,text/html; charset=utf-8"
StesArray(10) = "responseText"
StesArray(11) = "onmouseout=""this.style.backgroundColor='#fff'"">"
StesArray(12) = "</span>"
StesArray(13) = "onmouseout=""this.style.backgroundColor='#fff'"">"
StesArray(14) = "</span>"
StesArray(15) = "onmouseout=""this.style.backgroundColor='#fff'"">"
StesArray(16) = "</span>"
StesArray(17) = ""
StesArray(18) = ""
StesArray(19) = "1"
ElseIf DataName = DefaultEngineList(2) Then
StesArray(0) = DefaultObject
StesArray(1) = ""
StesArray(2) = "http://fanyi.yahoo.com.cn/translate_txt?"
StesArray(3) = "{Url}&ei=UTF-8&fr=&lp={from}_{to}&trtext={Text}"
StesArray(4) = "POST"
StesArray(5) = "False"
StesArray(6) = ""
StesArray(7) = ""
StesArray(8) = ""
StesArray(9) = "Content-Type,text/html; charset=utf-8"
StesArray(10) = "responseText"
StesArray(11) = "<div id=""pd"" class=""pd"">"
StesArray(12) = "</div>"
StesArray(13) = "<div id=""pd"" class=""pd"">"
StesArray(14) = "</div>"
StesArray(15) = "<div id=""pd"" class=""pd"">"
StesArray(16) = "</div>"
StesArray(17) = ""
StesArray(18) = ""
StesArray(19) = "0"
End If
EngineSettings = Join(StesArray,SubJoinStr)
End Function
'字串处理默认设置
Function CheckSettings(DataName As String,DataType As Long) As String
Dim i As Long,n As Long,j As Long,Max As Long,CheckName As String
Dim TempList() As String,readByte() As Byte,DefaultCheckDataList() As String
If DataType = 0 Then ReDim TempList(17) As String
If DataType = 1 Then ReDim TempList(20) As String
If DataName <> "" And DataType = 0 Then
If DataName = DefaultCheckList(0) Then CheckName = "en2zh"
If DataName = DefaultCheckList(1) Then CheckName = "zh2en"
ElseIf DataName <> "" And DataType = 1 Then
If DataName = DefaultProjectList(0) Then CheckName = "CheckOnly"
If DataName = DefaultProjectList(1) Then CheckName = "CheckAndCorrect"
If DataName = DefaultProjectList(2) Then CheckName = "DelAccessKey"
If DataName = DefaultProjectList(3) Then CheckName = "DelAccelerator"
If DataName = DefaultProjectList(4) Then CheckName = "DelAccessKeyAndAccelerator"
End If
If CheckName = "" Then GoTo ExitFunction
ConfigFile = MacroDir & "\Data\PSLCheckAccessKeys.ini"
On Error GoTo ErrMassage
If Dir(ConfigFile) = "" Then Err.Raise(1,"NotExitFile",LangFile)
On Error GoTo NotReadFile
i = FileLen(ConfigFile)
ReDim readByte(i) As Byte
FN = FreeFile
Open ConfigFile For Binary As #FN
Get #FN,,readByte
Close #FN
DefaultCheckDataList = Split(readByte,vbCrLf)
Erase readByte
If Join(DefaultCheckDataList,"") = "" Then GoTo ExitFunction
On Error GoTo ErrMassage
n = 0
Max = UBound(DefaultCheckDataList)
For i = 0 To Max
L$ = DefaultCheckDataList(i)
If L$ <> "" Then
If Left(Trim(L$),1) = "[" And Right(Trim(L$),1) = "]" Then
Header$ = Mid(Trim(L$),2,Len(Trim(L$))-2)
End If
If Header$ <> "" And HeaderBak$ = "" Then HeaderBak$ = Header$
If Header$ <> "" And Header$ = HeaderBak$ Then
setPreStr$ = ""
setAppStr$ = ""
j = InStr(L$,"=")
If j <> 0 Then
setPreStr$ = Trim(Left(L$,j - 1))
setAppStr$ = LTrim(Mid(L$,j + 1))
End If
If Header$ = "Option" And setPreStr$ <> "" Then
If setPreStr$ = "Version" Then
UpdateVersion = setAppStr$
If UpdateVersion < ToUpdateCheckVersion Or UpdateVersion > Version Then
CheckName = ""
Err.Raise(1,"NotVersion",ConfigFile & JoinStr & UpdateVersion & _
JoinStr & ToUpdateCheckVersion)
Exit For
End If
End If
End If
If DataType = 0 And Header$ = CheckName And setPreStr$ <> "" Then
If setPreStr$ = "ExcludeChar" Then TempList(0) = setAppStr$
If setPreStr$ = "LineSplitChar" Then TempList(1) = setAppStr$
If setPreStr$ = "CheckBracket" Then TempList(2) = setAppStr$
If setPreStr$ = "KeepCharPair" Then TempList(3) = setAppStr$
If setPreStr$ = "ShowAsiaKey" Then TempList(4) = setAppStr$
If setPreStr$ = "CheckEndChar" Then TempList(5) = setAppStr$
If setPreStr$ = "NoTrnEndChar" Then TempList(6) = setAppStr$
If setPreStr$ = "AutoTrnEndChar" Then TempList(7) = setAppStr$
If setPreStr$ = "CheckShortChar" Then TempList(8) = setAppStr$
If setPreStr$ = "CheckShortKey" Then TempList(9) = setAppStr$
If setPreStr$ = "KeepShortKey" Then TempList(10) = setAppStr$
If setPreStr$ = "PreRepString" Then TempList(11) = setAppStr$
If setPreStr$ = "AutoRepString" Then TempList(12) = setAppStr$
If setPreStr$ = "AccessKeyChar" Then TempList(13) = setAppStr$
If setPreStr$ = "AddAccessKeyWithFirstChar" Then TempList(14) = setAppStr$
If setPreStr$ = "LineSplitMode" Then TempList(15) = setAppStr$
If setPreStr$ = "AppInsertSplitChar" Then TempList(16) = setAppStr$
If setPreStr$ = "ReplaceSplitChar" Then TempList(17) = setAppStr$
ElseIf DataType = 1 And Header$ = "Projects" And setPreStr$ <> "" Then
If setPreStr$ = CheckName Then TempList = Split(setAppStr$,LngJoinStr)
End If
End If
End If
If Header$ <> "" And (i = Max Or Header$ <> HeaderBak$) Then
If Join(TempList,"") <> "" Then
If DataType = 0 And HeaderBak$ = CheckName Then
CheckSettings = Join(TempList,SubJoinStr)
ElseIf DataType = 1 And HeaderBak$ = "Projects" Then
CheckSettings = Join(TempList,LngJoinStr)
End If
n = n + 1
Exit For
End If
HeaderBak$ = Header$
End If
Next i
If n = 0 And CheckName <> "" Then
If DataType = 0 Then Temp = "NotSection"
If DataType = 1 Then Temp = "NotValue"
Err.Raise(1,Temp,ConfigFile & JoinStr & CheckName)
End If
Exit Function
NotReadFile:
Err.Source = "NotReadFile"
Err.Description = Err.Description & JoinStr & ConfigFile
ErrMassage:
Call sysErrorMassage(Err,1)
ExitFunction:
If n = 0 Then
If DataType = 0 Then CheckSettings = Join(TempList,SubJoinStr)
If DataType = 1 Then CheckSettings = Join(TempList,LngJoinStr)
End If
End Function
' 主程序
Public Sub PSL_OnAutoTranslate(Translations As PslTranslations,ByVal MinMatch As Long,ByVal MaxCount As Long)
Dim TransString As PslTransString,CheckID As Long,EngineID As Long
Dim i As Long,j As Long,n As Long,srcString As String,trnString As String,TranLang As String
Dim LangPairList() As String,xmlHttp As Object,objStream As Object
Dim LangPair As String,Temp As String,TempList() As String,TempArray() As String
Dim srcLng As String,trnLng As String,srcLngFind As String,trnLngFind As String
Dim strKeyPath As String,WshShell As Object,MsgList() As String,Stemp As Boolean
Dim mCheckSrc As Long,iVoSrc As Long,mCheckTrn As Long,iVoTrn As Long
Dim ShowOriginalTran As Long,ApplyCheckResult As Long,k As Long
'字串初始化并获取翻译列表的现有来源和翻译字串
srcString = Translations.SourceString
'跳过为空或全为空格的字串
If Trim(srcString) = "" Then GoTo Skip
'检测系统语言
On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
If WshShell Is Nothing Then
PSL.Output(Err.Description & " - " & "WScript.Shell")
Exit Sub
End If
strKeyPath = "HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language\Default"
OSLanguage = WshShell.RegRead(strKeyPath)
If OSLanguage = "" Then
strKeyPath = "HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language\InstallLanguage"
OSLanguage = WshShell.RegRead(strKeyPath)
If Err.Source = "WshShell.RegRead" Then
PSL.Output(Err.Description)
Exit Sub
End If
End If
Set WshShell = Nothing
'检测 Microsoft.XMLHTTP 是否存在
Set xmlHttp = CreateObject(DefaultObject)
If xmlHttp Is Nothing Then Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
If xmlHttp Is Nothing Then
PSL.Output(Err.Description & " - " & DefaultObject)
Exit Sub
End If
'检测 Adodb.Stream 是否存在
Set objStream = CreateObject("Adodb.Stream")
If objStream Is Nothing Then
PSL.Output(Err.Description & " - " & "Adodb.Stream")
Exit Sub
End If
Set objStream = Nothing
On Error GoTo SysErrorMsg
'初始化数组
ReDim UIFileList(0),UIDataList(0),UILangList(0)
ReDim DefaultEngineList(2),EngineDataList(0),tSelected(27),TempArray(0)
ReDim DefaultCheckList(1),CheckDataList(0)
ReDim DefaultProjectList(4),ProjectDataList(0)
UIFileList(0) = "Auto"
UIDataList(0) = "Auto" & JoinStr & "0" & JoinStr
'读取翻译引擎设置
DefaultEngineList(0) = "Microsoft"
DefaultEngineList(1) = "Google"
DefaultEngineList(2) = "Yahoo"
If EngineGet("",TempArray,EngineDataList,"") <> 4 Then
For i = LBound(DefaultEngineList) To UBound(DefaultEngineList)
EngineName = DefaultEngineList(i)
Stemp = False
For j = LBound(TempArray) To UBound(TempArray)
If TempArray(j) = EngineName Then
Stemp = True
Exit For
End If
Next j
If Stemp = False Then
LangPairs = Join(LangCodeList(EngineName,0,108),SubLngJoinStr)
Temp = EngineName & JoinStr & EngineSettings(EngineName) & JoinStr & LangPairs
CreateArray(EngineName,Temp,TempArray,EngineDataList)
End If
Next i
End If
'转换引擎设置
If Join(tSelected,"") <> "" Then
'EngineName = tSelected(0)
CheckName = tSelected(1)
'mAllType = StrToLong(tSelected(2))
'mMenu = StrToLong(tSelected(3))
'mDialog = StrToLong(tSelected(4))
'mString = StrToLong(tSelected(5))
'mAccTable = StrToLong(tSelected(6))
'mVer = StrToLong(tSelected(7))
'mOther = StrToLong(tSelected(8))
mSelOnly = StrToLong(tSelected(9))
'mForReview = StrToLong(tSelected(10))
'mValidated = StrToLong(tSelected(11))
'mNotTran = StrToLong(tSelected(12))
mNumAndSymbol = StrToLong(tSelected(13))
mAllUCase = StrToLong(tSelected(14))
mAllLCase = StrToLong(tSelected(15))
mAutoSele = StrToLong(tSelected(16))
iVoSrc = StrToLong(tSelected(17))
mCheckSrc = StrToLong(tSelected(18))
mPreStrRep = StrToLong(tSelected(19))
mSplitTrn = StrToLong(tSelected(20))
iVoTrn = StrToLong(tSelected(21))
mCheckTrn = StrToLong(tSelected(22))
mAppStrRep = StrToLong(tSelected(23))
'KeepSet = StrToLong(tSelected(24))
'mShowMsg = StrToLong(tSelected(25))
mTranComm = StrToLong(tSelected(26))
End If
'获取字串类型组合
'If mMenu = 1 Then StrTypes = "|Menu|"
'If mDialog = 1 Then StrTypes = StrTypes & "|Dialog|"
'If mString = 1 Then StrTypes = StrTypes & "|StringTable|"
'If mAccTable = 1 Then StrTypes = StrTypes & "|AcceleratorTable|"
'If mVer = 1 Then StrTypes = StrTypes & "|Version|"
'字串类型处理
'If mAllType = 0 And mSelOnly = 0 Then
' If InStr("Menu|Dialog|StringTable|AcceleratorTable|Version",TransString.ResType) Then
' If InStr(StrTypes,TransString.ResType) = 0 Then GoTo Skip
' Else
' If mOther = 0 Then GoTo Skip
' End If
'End If
'跳过全为数字和符号的字串
If mNumAndSymbol = 1 Then
If LCase(srcString) = UCase(srcString) Then
If CheckStr(srcString,"0-64,91-96,123-191",1) = True Then GoTo Skip
End If
End If
'跳过全为大写英文的字串
If mAllUCase = 1 Then
If UCase(srcString) = srcString Then
If CheckStr(srcString,"0-96,123-191",1) = True Then GoTo Skip
End If
End If
'跳过全为小写英文的字串
If mAllLCase = 1 Then
If LCase(srcString) = srcString Then
If CheckStr(srcString,"0-64,91-191",1) = True Then GoTo Skip
End If
End If
'读取界面语言字串
If GetUIList(UIFileList,UIDataList) = True Then
If Join(tSelected,"") <> "" Then UILangID = LCase(tSelected(27))
If UILangID = "" Or UILangID = "0" Then UILangID = LCase(OSLanguage)
TempList = Split(UILangID,";")
For i = 1 To UBound(UIDataList)
TempArray = Split(UIDataList(i),JoinStr)
Temp = LCase(TempArray(1))
File = TempArray(2)
If Temp = UILangID Then
LangFile = MacroDir & "\Data" & File
Exit For
End If
TempArray = Split(Temp,";")
For j = 0 To UBound(TempList)
For n = 0 To UBound(TempArray)
If TempList(j) = TempArray(n) Then
LangFile = MacroDir & "\Data" & File
Exit For
End If
Next n
If LangFile <> "" Then Exit For
Next j
If LangFile <> "" Then Exit For
Next i
End If
If LangFile = "" Then LangFile = MacroDir & "\Data" & updateAppName & "_" & OSLanguage & ".lng"
If Dir(LangFile) = "" Then
Temp = MacroDir & "\Data" & updateAppName & "_" & OSLanguage & ".lng"
If Temp <> LangFile Then LangFile = Temp
If Dir(LangFile) = "" Then
LangFile = ""
For i = 0 To 2
If i = 0 Then Temp = MacroDir & "\Data" & updateAppName & "_0804.lng"
If i = 1 Then Temp = MacroDir & "\Data" & updateAppName & "_0404.lng"
If i = 2 And UBound(UIDataList) > 0 Then
TempArray = Split(UIDataList(1),JoinStr)
LangFile = MacroDir & "\Data" & TempArray(2)
End If
If Dir(Temp) <> "" Then
LangFile = Temp
Exit For
End If
Next i
If LangFile = "" Then Err.Raise(1,"NotExitFile",MacroDir & "\Data" & updateAppName & "_*.lng")
End If
End If
If getUILangList(LangFile,UILangList) = False Then Exit Sub
If getMsgList(UILangList,MsgList,"Main",0) = False Then Exit Sub
'检测 PSL 版本
If PSL.Version < 600 Then
PSL.Output(MsgList(41) & ":" & MsgList(43))
Exit Sub
End If
'获取PSL的来源语言代码
srcLng = PSL.GetLangCode(Translations.SourceLangID,pslCode639_1)
If srcLng = "" Then srcLng = PSL.GetLangCode(Translations.SourceLangID,pslCodeLangRgn)
If srcLng = "zh" Then
srcLng = PSL.GetLangCode(Translations.SourceLangID,pslCodeLangRgn)
If srcLng = "zh-CHS" Or srcLng = "zh-SG" Then srcLng = "zh-CN"
If srcLng = "zh-CHT" Or srcLng = "zh-HK" Or srcLng = "zh-MO" Then srcLng = "zh-TW"
End If
'获取PSL的目标语言代码
trnLng = PSL.GetLangCode(Translations.TargetLangID,pslCode639_1)
If trnLng = "" Then trnLng = PSL.GetLangCode(Translations.TargetLangID,pslCodeLangRgn)
If trnLng = "zh" Or trnLng = "ja" Or trnLng = "ko" Then TranLang = "Asia"
If trnLng = "zh" Then
trnLng = PSL.GetLangCode(Translations.TargetLangID,pslCodeLangRgn)
If trnLng = "zh-CHS" Or trnLng = "zh-SG" Then trnLng = "zh-CN"
If trnLng = "zh-CHT" Or trnLng = "zh-HK" Or trnLng = "zh-MO" Then trnLng = "zh-TW"
End If
'读取字串处理设置
DefaultCheckList(0) = MsgList(70)
DefaultCheckList(1) = MsgList(71)
DefaultProjectList(0) = MsgList(89)
DefaultProjectList(1) = MsgList(90)
DefaultProjectList(2) = MsgList(91)
DefaultProjectList(3) = MsgList(92)
DefaultProjectList(4) = MsgList(93)
If mCheckSrc = 1 Or mCheckTrn = 1 Or mPreStrRep = 1 Or mAppStrRep = 1 Then
j = 0
If mAutoSele = 1 Then j = CheckGet("",CheckDataList,"",trnLng)
If j <> 4 Then j = CheckGet("",CheckDataList,"","")
If j <> 4 Then
If TranLang = "Asia" Then CheckName = DefaultCheckList(0)
If TranLang <> "Asia" Then CheckName = DefaultCheckList(1)
Temp = CheckSettings(CheckName,0)
If Trim(Replace(Temp,SubJoinStr,"")) <> "" Then
CheckDataList(0) = CheckName & JoinStr & Temp
Else
CheckName = MsgList(88)
CheckDataList(0) = CheckName & JoinStr & Temp
mAutoSele = 0
iVoSrc = 0
mCheckSrc = 0
mPreStrRep = 0
mSplitTrn = 0
iVoTrn = 0
mCheckTrn = 0
mAppStrRep = 0
End If
End If
If Join(ProjectDataList,"") = "" Then
TempArray = ProjectDataList
For i = LBound(DefaultProjectList) To UBound(DefaultProjectList)
ProjectName = DefaultProjectList(i)
Temp = CheckSettings(ProjectName,1)
If Trim(Replace(Temp,LngJoinStr,"")) <> "" Then
Temp = ProjectName & JoinStr & Temp
CreateArray(ProjectName,Temp,TempArray,ProjectDataList)
End If
Next i
If Join(ProjectDataList,"") = "" Then
iVoSrc = 0
mCheckSrc = 0
iVoTrn = 0
mCheckTrn = 0
End If
End If
End If
AllCont = 1
AccKey = 0
EndChar = 0
Acceler = 0
CheckID = 0
'更改字串检查配置名称
If tSelected(1) = "en2zh" Then tSelected(1) = DefaultCheckList(0)
If tSelected(1) = "zh2en" Then tSelected(1) = DefaultCheckList(1)
'排序检查配置值并转换配置中的转义符
If Join(CheckDataList,"") <> "" Then
CheckDataListBak = CheckDataList
TempArray = Split(CheckDataList(CheckID),JoinStr)
TempDataList = Split(TempArray(1),SubJoinStr)
For i = 0 To UBound(TempDataList)
If i <> 4 And i <> 14 And i <> 15 And i < 18 Then
If TempDataList(i) <> "" Then
If i = 1 Or i = 5 Or i = 13 Or i = 16 Or i = 17 Then
If i = 5 Or i = 7 Then Temp = " " Else Temp = ","
TempList = SortArray(Split(TempDataList(i),Temp,-1),0,"Lenght","<")
TempDataList(i) = Convert(Join(TempList,Temp))
Else
TempDataList(i) = Convert(TempDataList(i))
End If
End If
End If
Next i
TempArray(1) = Join(TempDataList,SubJoinStr)
CheckDataList(CheckID) = Join(TempArray,JoinStr)
CheckName = TempArray(0)
Else
CheckName = MsgList(88)
End If
'获取检查方案设置
If mCheckSrc = 1 Then
TempArray = Split(ProjectDataList(iVoSrc),JoinStr)
SrcProjectName = TempArray(0)
Else
SrcProjectName = MsgList(86)
End If
If mCheckTrn = 1 Then
TempArray = Split(ProjectDataList(iVoTrn),JoinStr)
TempDataList = Split(TempArray(1),LngJoinStr)
ShowOriginalTran = StrToLong(TempDataList(19))
ApplyCheckResult = StrToLong(TempDataList(20))
TrnProjectName = TempArray(0)
Else
TrnProjectName = MsgList(86)
End If
'释放不再使用的动态数组所使用的内存
Erase TempArray,TempList,TempDataList
Erase UIFileList,UIDataList
'开始预处理字串
OldSrcString = srcString
If mPreStrRep = 1 Then srcString = ReplaceStr(0,srcString,0,0)
If mSplitTrn = 0 Then
If mCheckSrc = 1 Then srcString = CheckHanding(CheckID,OldSrcString,srcString,iVoSrc)
If InStr(srcString,"&") Then srcString = Replace(srcString,"&","")
End If
'分别用启用的翻译引擎翻译字串并进行后处理
k = 0
MaxCount = MaxCount + UBound(EngineDataList) + 1
For j = 0 To UBound(EngineDataList)
'查找翻译引擎中对应的语言代码
TempArray = Split(EngineDataList(j),JoinStr)
TempDataList = Split(TempArray(1),SubJoinStr)
LangArray = Split(TempArray(2),SubLngJoinStr)
EngineName = TempArray(0)
EngineID = j
srcLngFind = ""
trnLngFind = ""
LangPair = ""
trnString = ""
If TempDataList(19) <> "1" Then GoTo NextNum
For i = 0 To UBound(LangArray)
LangPairList = Split(LangArray(i),LngJoinStr)
If LCase(srcLng) = LCase(LangPairList(1)) Then
srcLngFind = LangPairList(2)
End If
If LCase(trnLng) = LCase(LangPairList(1)) Then
trnLngFind = LangPairList(2)
End If
If srcLngFind <> "" And trnLngFind <> "" Then Exit For
Next i
If trnLngFind = "" Or trnLngFind = NullValue Then GoTo NextNum
LangPair = srcLngFind & LngJoinStr & trnLngFind
'转换翻译引擎的配置中的转义符
For i = 0 To UBound(TempDataList)
If i > 10 And i < 19 Then
If TempDataList(i) <> "" Then
TempDataList(i) = Convert(TempDataList(i))
End If
End If
Next i
TempArray(1) = Join(TempDataList,SubJoinStr)
EngineDataList(EngineID) = Join(TempArray,JoinStr)
'释放不再使用的动态数组所使用的内存
Erase TempArray,TempDataList,LangArray,LangPairList
'获取测试翻译
'Temp = getTranslate(EngineID,xmlHttp,"Test",LangPair,3)
'测试 Internet 连接
'If Temp = "NotConnected" Then Exit Sub
'测试引擎网址是否为空
'If Temp = "NullUrl" Then GoTo NextNum
'测试引擎引擎是否超时
'If Temp = "Timeout" Then GoTo NextNum
'测试引擎结果是否为空
'If Trim(Temp) = "" Then GoTo NextNum
'开始翻译字串
If mSplitTrn = 0 Then
trnString = getTranslate(EngineID,xmlHttp,srcString,LangPair,0)
Else
Temp = EngineID & JoinStr & CheckID & JoinStr & iVoSrc & JoinStr & mCheckSrc & JoinStr & k
trnString = SplitTran(xmlHttp,srcString,LangPair,Temp,0)
End If
'开始后处理字串并替换原有翻译
If Trim(trnString) <> "" And trnString <> OldSrcString Then
If mCheckTrn = 1 Then
CheckTrnString = CheckHanding(CheckID,OldSrcString,trnString,iVoTrn)
If ApplyCheckResult = 1 Then trnString = CheckTrnString
End If
If mAppStrRep = 1 Then trnString = ReplaceStr(CheckID,trnString,2,1)
Translations.Add(trnString,OldSrcString,100,EngineName & " " & MsgList(4))
End If
NextNum:
If Translations.Count = MaxCount Then Exit For
k = 1
Next j
Skip:
Set xmlHttp = Nothing
Exit Sub
'显示程序错误消息
SysErrorMsg:
If Err.Source <> "ExitSub" Then Call sysErrorMassage(Err,0)
End Sub
'获取在线翻译
Function getTranslate(ID As Long,xmlHttp As Object,srcStr As String,LngPair As String,fType As Long) As String
Dim trnStr As String,srcStrBak As String,LangFrom As String,LangTo As String,Temp As String
Dim i As Long,Pos As Long,Code As String,Body As Variant,xmlObj As Object
If Trim(srcStr) = "" Or LngPair = "" Then Exit Function
TempArray = Split(EngineDataList(ID),JoinStr)
SetsArray = Split(TempArray(1),SubJoinStr)
AppId = SetsArray(1)
Url = SetsArray(2)
UrlTemplate = LCase(SetsArray(3))
Method = SetsArray(4)
Async = SetsArray(5)
User = SetsArray(6)
Password = SetsArray(7)
BodyData = LCase(SetsArray(8))
RequestHeader = LCase(SetsArray(9))
responseType = SetsArray(10)
If responseType = "responseText" Then
TranBeforeStr = SetsArray(11)
TranAfterStr = SetsArray(12)
ElseIf responseType = "responseBody" Then
TranBeforeStr = SetsArray(13)
TranAfterStr = SetsArray(14)
ElseIf responseType = "responseStream" Then
TranBeforeStr = SetsArray(15)
TranAfterStr = SetsArray(16)
ElseIf responseType = "responseXML" Then
TranBeforeStr = SetsArray(17)
TranAfterStr = SetsArray(18)
End If
If Url = "" Then
If fType = 3 Then getTranslate = "NullUrl"
Exit Function
End If
If LngPair <> "" Then
LangFrom = Left(LngPair,InStr(LngPair,LngJoinStr)-1)
LangTo = Mid(LngPair,InStr(LngPair,LngJoinStr)+1)
End If
srcStrBak = srcStr
Pos = InStr(LCase(RequestHeader),"charset")
If Pos <> 0 Then
Temp = Mid(RequestHeader,Pos)
If InStr(Temp,"=") Then Code = ExtractStr(Temp,"=",vbCrLf,1)
Else
On Error GoTo ErrorHandler
xmlHttp.Open Method,Url,Async,User,Password
xmlHttp.send()
Temp = xmlHttp.getResponseHeader("Content-Type")
Pos = InStr(LCase(Temp),"charset")
If Pos <> 0 Then
Temp = Mid(Temp,Pos)
If InStr(Temp,"=") Then Code = ExtractStr(Temp,"=",vbCrLf,1)
Else
Temp = xmlHttp.responseText
Pos = InStr(LCase(Temp),"charset")
If Pos = 0 Then Pos = InStr(LCase(Temp),"lang")
If Pos <> 0 Then
Temp = Mid(Temp,Pos)
If InStr(Temp,"=") Then Code = ExtractStr(Temp,"=",">",1)
End If
End If
xmlHttp.Abort
On Error GoTo 0
End If
If Code <> "" Then Code = RemoveBackslash(Code,"""","""",1)
If LCase(Code) = "utf-8" Or LCase(Code) = "utf8" Then
srcStrBak = Utf8Encode(srcStrBak)
Else
srcStrBak = ANSIEncode(srcStrBak)
End If
If UrlTemplate <> "" Then
If InStr(UrlTemplate,"{url}") = 0 Then UrlTemplate = Url & UrlTemplate
If InStr(UrlTemplate,"{url}") Then UrlTemplate = Replace(UrlTemplate,"{url}",Url)
If InStr(UrlTemplate,"{appid}") Then UrlTemplate = Replace(UrlTemplate,"{appid}",AppId)
If InStr(UrlTemplate,"{text}") Then UrlTemplate = Replace(UrlTemplate,"{text}",srcStrBak)
If InStr(UrlTemplate,"{from}") Then UrlTemplate = Replace(UrlTemplate,"{from}",LangFrom)
If InStr(UrlTemplate,"{to}") Then UrlTemplate = Replace(UrlTemplate,"{to}",LangTo)
Else
UrlTemplate = Url
End If
If BodyData <> "" Then
If InStr(BodyData,"{url}") Then BodyData = Replace(BodyData,"{url}",Url)
If InStr(BodyData,"{appid}") Then BodyData = Replace(BodyData,"{appid}",AppId)
If InStr(BodyData,"{text}") Then BodyData = Replace(BodyData,"{text}",srcStrBak)
If InStr(BodyData,"{from}") Then BodyData = Replace(BodyData,"{from}",LangFrom)
If InStr(BodyData,"{to}") Then BodyData = Replace(BodyData,"{to}",LangTo)
End If
On Error GoTo ErrorHandler
xmlHttp.Open Method,UrlTemplate,Async,User,Password
If RequestHeader <> "" Then
FindStrArr = Split(RequestHeader,vbCrLf)
For i = LBound(FindStrArr) To UBound(FindStrArr)
FindStr = FindStrArr(i)
Pos = InStr(FindStr,",")
If Pos = 0 Then Pos = InStr(FindStr,":")
If Pos <> 0 Then
bstrHeader = Trim(Left(FindStr,Pos-1))
bstrValue = Trim(Mid(FindStr,Pos+1))
If InStr(bstrValue,"{url}") Then bstrValue = Replace(bstrValue,"{url}",Url)
If InStr(bstrValue,"{appid}") Then bstrValue = Replace(bstrValue,"{appid}",AppId)
If InStr(bstrValue,"{text}") Then bstrValue = Replace(bstrValue,"{text}",srcStrBak)
If InStr(bstrValue,"{from}") Then bstrValue = Replace(bstrValue,"{from}",LangFrom)
If InStr(bstrValue,"{to}") Then bstrValue = Replace(bstrValue,"{to}",LangTo)
If LCase(bstrHeader) = LCase("Content-Length") Then
xmlHttp.setRequestHeader bstrHeader,LenB(bstrValue)
Else
xmlHttp.setRequestHeader bstrHeader,bstrValue
End If
End If
Next i
End If
xmlHttp.send(BodyData)
If xmlHttp.readyState < 4 Then
xmlHttp.TimeOut = WaitTimes
Wait WaitTimes
If xmlHttp.readyState < 4 Then getTranslate = "Timeout"
End If
If xmlHttp.readyState = 4 Then
If fType <> 2 Then
If responseType = "responseText" Then
trnStr = xmlHttp.responseText
ElseIf responseType = "responseXML" Then
If fType = 0 Or fType = 3 Then
Set xmlObj = xmlHttp.responseXML
If Not xmlObj Is Nothing Then
trnStr = ReadXML(xmlObj,TranBeforeStr,TranAfterStr)
End If
Set xmlObj = Nothing
End If
If fType = 1 Then trnStr = BytesToBstr(xmlHttp.responseBody,Code)
ElseIf responseType = "responseStream" Then
If fType = 0 Or fType = 3 Then
Body = xmlHttp.responseStream
If LenB(Body) > 0 Then trnStr = BytesToBstr(Body,Code)
End If
If fType = 1 Then trnStr = BytesToBstr(xmlHttp.responseBody,Code)
ElseIf responseType = "responseBody" Then
If fType = 0 Or fType = 3 Then
Body = xmlHttp.responseBody
If LenB(Body) > 0 Then trnStr = BytesToBstr(Body,Code)
End If
If fType = 1 Then trnStr = BytesToBstr(xmlHttp.responseBody,Code)
End If
Else
trnStr = xmlHttp.getAllResponseHeaders
End If
xmlHttp.Abort
'If responseType = "responseText" Then
' If LCase(Code) <> "utf-8" And LCase(Code) <> "utf8" Then
'trnStr = ConvStr(trnStr,Code,"unicodeFFFE")
'codepage = trn.Language.Option(pslOptionActualCodepage)
'trnStr = PSL.ConvertASCII2Unicode(trnStr,codepage)
' End If
'End If
If fType = 0 Or fType = 3 Then
If responseType = "responseXML" Then
getTranslate = trnStr
ElseIf trnStr <> "" Then
getTranslate = ExtractStr(trnStr,TranBeforeStr,TranAfterStr,0)
End If
Else
getTranslate = trnStr
End If
Exit Function
End If
On Error GoTo 0
ErrorHandler:
If Err.Number <> 0 Then
If fType = 3 Then getTranslate = "NotConnected"
End If
End Function
'Utf-8 编码
Function Utf8Encode(textStr As String) As String
Dim Wch As String,Uch As String,Szret As String,i As Long,Nasc As Long
Utf8Encode = textStr
If Trim(textStr) = "" Then Exit Function
For i = 1 To Len(textStr)
Wch = Mid(textStr,i,1)
Nasc = AscW(Wch)
If Nasc < 0 Then Nasc = Nasc + 65536
If (Nasc And &hff80) = 0 Then
Szret = Szret & Wch
Else
If (Nasc And &hf000) = 0 Then
Uch = "%" & Hex(((Nasc \2 ^ 6)) Or &hc0) & Hex(Nasc And &h3f Or &h80)
Szret = Szret & Uch
Else
Uch = "%" & Hex((Nasc \ 2 ^ 12) Or &he0) & "%" & _
Hex((Nasc \ 2 ^ 6) And &h3f Or &h80) & "%" & _
Hex(Nasc And &h3f Or &h80)
Szret = Szret & Uch
End If
End If
Next i
Utf8Encode = Szret
End Function
'ANSI 编码
Public Function ANSIEncode(textStr As String) As String
Dim i As Long,startIndex As Long,endIndex As Long,x() As Byte,Szret As String
ANSIEncode = textStr
If Trim(textStr) = "" Then Exit Function
x = StrConv(textStr,vbFromUnicode)
startIndex = LBound(x)
endIndex = UBound(x)
For i = startIndex To endIndex
Szret = Szret & "%" & Hex(x(i))
Next i
ANSIEncode = Szret
End Function
'转换字符的编码格式
Function ConvStr(textStr As String,inCode As String,outCode As String) As String
Dim objStream As Object
ConvStr = textStr
If Trim(textStr) = "" Or inCode = "" Or outCode = "" Then Exit Function
On Error GoTo ErrorMsg
Set objStream = CreateObject("Adodb.Stream")
If Not objStream Is Nothing Then
With objStream
.Type = 2
.Mode = 3
.CharSet = inCode
.Open
.WriteText textStr
.Position = 0
.CharSet = outCode
ConvStr = .ReadText
.Close
End With
Set objStream = Nothing
End If
Exit Function
ErrorMsg:
Err.Source = "Adodb.Stream"
Call sysErrorMassage(Err,1)
End Function
'转换二进制数据为指定编码格式的字符
Function BytesToBstr(strBody As Variant,outCode As String) As String
Dim objStream As Object
If LenB(strBody) = 0 Or outCode = "" Then Exit Function
On Error GoTo ErrorMsg
Set objStream = CreateObject("Adodb.Stream")
If Not objStream Is Nothing Then
With objStream
.Type = 1
.Mode = 3
.Open
.Write strBody
.Position = 0
.Type = 2
.Charset = outCode
BytesToBstr = .ReadText
.Close
End With
Set objStream = Nothing
End If
Exit Function
ErrorMsg:
Err.Source = "Adodb.Stream"
Call sysErrorMassage(Err,1)
End Function
'写入二进制数据到文件
Function BytesToFile(strBody As Variant,File As String) As Boolean
Dim objStream As Object
BytesToFile = False
If LenB(strBody) = 0 Or File = "" Then Exit Function
On Error GoTo ErrorMsg
Set objStream = CreateObject("Adodb.Stream")
If Not objStream Is Nothing Then
With objStream
.Type = 1
.Mode = 3
.Open
.Write(strBody)
.Position = 0
.SaveToFile File,2
.Flush
.Close
End With
Set objStream = Nothing
BytesToFile = True
End If
Exit Function
ErrorMsg:
Err.Source = "Adodb.Stream"
Call sysErrorMassage(Err,1)
End Function
'解析 XML 格式对象并提取翻译文本
Function ReadXML(xmlObj As Object,IdNames As String,TagNames As String) As String
Dim xmlDoc As Object,Node As Object,Item As Object,IdName As String,TagName As String
Dim x As Long,y As Long,i As Long,Max As Long
If xmlObj Is Nothing Then Exit Function
If IdNames = "" And TagNames = "" Then Exit Function
On Error GoTo ErrorMsg
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
If Not xmlDoc Is Nothing Then
'xmlDoc.Async = False
'xmlDoc.ValidateOnParse = False
'xmlDoc.loadXML(xmlObj) '加载字串
xmlDoc.Load(xmlObj) '加载对象
If xmlDoc.ReadyState > 2 Then
IdNameArray = Split(IdNames,"|")
TagNameArray = Split(TagNames,"|")
On Error Resume Next
For x = 0 To UBound(IdNameArray)
For y = 0 To UBound(TagNameArray)
IdName = IdNameArray(x)
TagName = TagNameArray(y)
If IdName <> "" And TagName = "" Then
Set Item = xmlDoc.getElementById(IdName)
If Item Is Nothing Then
Set Item = xmlDoc.getElementsByTagName(IdName)
End If
ElseIf IdName <> "" And TagName <> "" Then
Set Node = xmlDoc.getElementById(IdName)
If Node Is Nothing Then
Set Item = xmlDoc.getElementsByTagName(TagName)
Else
Set Item = Node.getElementsByTagName(TagName)
If Item.Length = 0 Then Set Item = xmlDoc.getElementById(IdName)
End If
ElseIf IdName = "" And TagName <> "" Then
Set Item = xmlDoc.getElementsByTagName(TagName)
End If
Max = Item.Length
If Max > 0 Then Exit For
Next y
If Max > 0 Then Exit For
Next x
On Error GoTo 0
If Max > 0 Then
For i = 0 To Max-1
If ReadXML <> "" Then ReadXML = ReadXML & Item(i).Text
If ReadXML = "" Then ReadXML = Item(i).Text 'firstChild.nodeValue
Next i
End If
End If
Set xmlDoc = Nothing
End If
Exit Function
ErrorMsg:
Err.Source = "Microsoft.XMLDOM"
Call sysErrorMassage(Err,1)
End Function
'提取指定前后字符之间的值
Function ExtractStr(textStr As String,BeforeStr As String,AfterStr As String,fType As Long) As String
Dim i As Long,x As Long,y As Long,L1 As Long,L2 As Long
Dim Temp As String,bStr As String,aStr As String,toFindText As String
If Trim(textStr) = "" Or (BeforeStr = "" And AfterStr = "") Then Exit Function
toFindText = textStr & vbCrLf
BeforeStrArray = Split(BeforeStr,"|")
AfterStrArray = Split(AfterStr,"|")
For x = 0 To UBound(BeforeStrArray)
For y = 0 To UBound(AfterStrArray)
L1 = 1
For i = 0 To 1
bStr = BeforeStrArray(x)
aStr = AfterStrArray(y)
L1 = InStr(L1,toFindText,bStr)
If L1 > 0 Then
L1 = L1 + Len(bStr)
L2 = InStr(L1,toFindText,aStr)
If fType > 0 And L2 = 0 Then L2 = InStr(L1,toFindText,vbCrLf)
If L2 <> 0 Then
Temp = Mid(toFindText,L1,L2-L1)
If ExtractStr <> "" Then ExtractStr = ExtractStr & Temp
If ExtractStr = "" Then ExtractStr = Temp
End If
If fType > 0 And i + 1 = fType Then Exit For
i = 0
Else
Exit For
End If
Next i
If ExtractStr <> "" Then Exit For
Next y
If ExtractStr <> "" Then Exit For
Next x
End Function
'fType = 0 找出字串中符合 AscRange 范围的字符的位置
'fType <> 0 检查字串是否仅包含数字和符号
Function CheckStr(textStr As String,AscRange As String,fType As Long) As Boolean
Dim i As Long,j As Long,n As Long,k As Long,InpAsc As Long,Length As Long,Max As Long
Dim Pos As Long,MinV As Long,MaxV As Long,Temp As String,Stemp As Boolean
CheckStr = False
If Trim(textStr) = "" Or AscRange = "" Then Exit Function
n = 0
k = 0
Stemp = False
Length = Len(textStr)
AscValue = Split(AscRange,",",-1)
Max = UBound(AscValue)
For i = 1 To Length
InpAsc = AscW(Mid(textStr,i,1))
For j = 0 To Max
Temp = AscValue(j)
Pos = InStr(Temp,"-")
If Pos <> 0 Then
MinV = CLng(Left(Temp,Pos-1))
MaxV = CLng(Mid(Temp,Pos+1))
Else
MinV = CLng(Temp)
MaxV = CLng(Temp)
End If
If InpAsc >= MinV And InpAsc <= MaxV Then
If fType = 0 Then k = i
n = n + 1
Exit For
Else
If fType = 0 Then
If k > 0 Then Stemp = True
Else
If j = Max Then Stemp = True
End If
End If
Next j
If Stemp = True Then Exit For
Next i
If fType <> 0 And n = Length Then CheckStr = True
If fType = 0 And k > 0 Then
CheckStr = True
fType = k
End If
End Function
'分行翻译处理
Function SplitTran(xmlHttp As Object,srcStr As String,LangPair As String,Arg As String,fType As Long) As String
Dim i As Long,srcStrBak As String,srcStringBak As String,Temp As String,Stemp As Boolean
Dim EngineID As Long,CheckID As Long,iVoSrc As Long,mCheckSrc As Long,mHanding As Long
If Trim(srcStr) = "" Or LangPair = "" Or Arg = "" Then Exit Function
TempArray = Split(Arg,JoinStr,-1)
EngineID = StrToLong(TempArray(0))
CheckID = StrToLong(TempArray(1))
iVoSrc = StrToLong(TempArray(2))
mCheckSrc = StrToLong(TempArray(3))
mHanding = StrToLong(TempArray(4))
'用替换法拆分字串
srcStrBak = srcStr
LineSplitChar = "\r\n,\r,\n"
FindStrArr = Split(Convert(LineSplitChar),",",-1)
For i = 0 To UBound(FindStrArr)
FindStr = Trim(FindStrArr(i))
If InStr(srcStrBak,FindStr) Then
srcStrBak = Replace(srcStrBak,FindStr,"*c!N!g*")
End If
Next i
srcStrArr = Split(srcStrBak,"*c!N!g*",-1)
'获取每行的翻译
Temp = srcStr
Stemp = False
For i = 0 To UBound(srcStrArr)
srcString = srcStrArr(i)
srcStringBak = srcString
If srcString <> "" Then
If mHanding = 0 Then
If mCheckSrc = 1 Then srcString = CheckHanding(CheckID,srcStringBak,srcString,iVoSrc)
If InStr(srcString,"&") Then srcString = Replace(srcString,"&","")
If srcString <> "" And srcString <> srcStringBak Then
srcStr = Replace(srcStr,srcStringBak,srcString,,1)
End If
End If
trnString = getTranslate(EngineID,xmlHttp,srcString,LangPair,fType)
If trnString <> "" And trnString <> srcStringBak Then
Temp = Replace(Temp,srcStringBak,trnString,,1)
Stemp = True
End If
End If
Next i
If Stemp = True Then SplitTran = Temp
End Function
'替换特定字符
'fType = 0 正向替换，使用第一个替换字符配置
'fType = 1 还原替换，使用第一个替换字符配置
'fType = 2 正向替换，使用第二个替换字符配置
'fType = 3 还原替换，使用第二个替换字符配置
'Record = 0 不记录替换字符
'Record = 1 记录替换字符
Function ReplaceStr(CheckID As Long,trnStr As String,fType As Long,Record As Long) As String
Dim i As Long,PreStr As String,AppStr As String
ReplaceStr = trnStr
PreRepStr = ""
AppRepStr = ""
If Trim(trnStr) = "" Then Exit Function
'获取选定配置的参数
TempArray = Split(CheckDataListBak(CheckID),JoinStr)
SetsArray = Split(TempArray(1),SubJoinStr)
If fType < 2 Then AutoRepChar = SetsArray(11) Else AutoRepChar = SetsArray(12)
If AutoRepChar <> "" Then
FindStrArr = Split(AutoRepChar,",",-1)
For i = 0 To UBound(FindStrArr)
FindStr = FindStrArr(i)
PreStr = ""
AppStr = ""
If InStr(FindStr,"|") Then
TempArray = Split(FindStr,"|")
If fType = 0 Or fType = 2 Then
PreStr = TempArray(0)
AppStr = TempArray(1)
Else
PreStr = TempArray(1)
AppStr = TempArray(0)
End If
cPreStr = Convert(PreStr)
cAppStr = Convert(AppStr)
End If
If PreStr <> "" And InStr(ReplaceStr,cPreStr) Then
ReplaceStr = Replace(ReplaceStr,cPreStr,cAppStr)
If Record = 1 Then
If PreRepStr <> "" Then
If InStr(PreRepStr,PreStr) = 0 Then PreRepStr = PreRepStr & JoinStr & PreStr
Else
PreRepStr = PreStr
End If
If AppRepStr <> "" Then
If InStr(AppRepStr,AppStr) = 0 Then AppRepStr = AppRepStr & JoinStr & AppStr
Else
AppRepStr = AppStr
End If
End If
End If
Next i
End If
End Function
'检查修正快捷键、终止符和加速器
Function CheckHanding(CheckID As Long,srcStr As String,trnStr As String,iVo As Long) As String
Dim i As Long,srcStrBak As String,trnStrBak As String,LineSplitMode As Long
Dim srcNum As Long,trnNum As Long,srcSplitNum As Long,trnSplitNum As Long,Stemp As Boolean
Dim FindStr As String,srcStrArr() As String,trnStrArr() As String,TempArr() As String
Dim k As Long,l As Long,m As Long
'参数初始化
srcNum = 0
trnNum = 0
srcSplitNum = 0
trnSplitNum = 0
srcStrBak = srcStr
trnStrBak = trnStr
CheckHanding = trnStr
If Trim(srcStr) = "" Then Exit Function
'获取选定配置的参数
TempArray = Split(CheckDataList(CheckID),JoinStr)
SetsArray = Split(TempArray(1),SubJoinStr)
ExcludeChar = SetsArray(0)
PreInsertSplitChar = SetsArray(1)
KeepCharPair = SetsArray(3)
AccessKeyChar = SetsArray(13)
LineSplitMode = StrToLong(SetsArray(15))
AppInsertSplitChar = SetsArray(16)
ReplaceSplitChar = SetsArray(17)
TempArray = Split(ProjectDataList(iVo),JoinStr)
SetsArray = Split(TempArray(1),LngJoinStr)
EnableStringSplit = StrToLong(SetsArray(16))
'配置参数数组化
If ExcludeChar <> "" Then ExcludeCharArr = Split(ExcludeChar,",",-1)
If KeepCharPair <> "" Then KeepCharPairArr = Split(KeepCharPair,",",-1)
If AccessKeyChar <> "" Then AccessKeyCharArr = Split(AccessKeyChar,",",-1)
If EnableStringSplit = 1 Then
LineSplitChar = PreInsertSplitChar & AppInsertSplitChar & ReplaceSplitChar
Temp = PreInsertSplitChar & "," & AppInsertSplitChar & "," & ReplaceSplitChar
If LineSplitChar <> "" Then LineSplitCharArr = Split(Temp,",",-1)
If PreInsertSplitChar <> "" Then k = UBound(Split(PreInsertSplitChar,",",-1)) + 1
If AppInsertSplitChar <> "" Then l = UBound(Split(AppInsertSplitChar,",",-1)) + 1
If ReplaceSplitChar <> "" Then m = UBound(Split(ReplaceSplitChar,",",-1)) + 1
End If
'排除字串中的非快捷键
If ExcludeChar <> "" Then
For i = 0 To UBound(ExcludeCharArr)
FindStr = LTrim(ExcludeCharArr(i))
If FindStr <> "" Then
srcStrBak = Replace(srcStrBak,FindStr,"*a" & i & "!N!" & i & "d*")
trnStrBak = Replace(trnStrBak,FindStr,"*a" & i & "!N!" & i & "d*")
End If
Next i
End If
'过滤不是快捷键的快捷键
If KeepCharPair <> "" Then
For i = 0 To UBound(KeepCharPairArr)
FindStr = Trim(KeepCharPairArr(i))
If FindStr <> "" Then
LFindStr = Trim(Left(FindStr,1))
RFindStr = Trim(Right(FindStr,1))
ToRepStr = LFindStr & "&" & RFindStr
BeRepStr = LFindStr & "*!N!" & i & "!M!" & i & "!N!*" & RFindStr
srcStrBak = Replace(srcStrBak,ToRepStr,BeRepStr)
trnStrBak = Replace(trnStrBak,ToRepStr,BeRepStr)
End If
Next i
End If
'用替换法拆分字串
If EnableStringSplit = 1 Then
BaksrcStr = srcStrBak
BaktrnStr = trnStrBak
If LineSplitChar <> "" Then
For i = 0 To UBound(LineSplitCharArr)
FindStr = Trim(LineSplitCharArr(i))
If FindStr <> "" Then
srcNum = UBound(Split(BaksrcStr,FindStr,-1))
trnNum = UBound(Split(BaktrnStr,FindStr,-1))
Stemp = False
If LineSplitMode = 0 Then
Stemp = True
ElseIf srcNum = trnNum And srcNum <> 0 And trnNum <> 0 Then
Stemp = True
End If
If Stemp = True Then
If InStr(LCase(AccessKeyChar),LCase(FindStr)) Then
BaksrcStr = Insert(BaksrcStr,FindStr,"*c!N!g*",1)
BaktrnStr = Insert(BaktrnStr,FindStr,"*c!N!g*",1)
ElseIf i < k And k <> 0 Then
BaksrcStr = Replace(BaksrcStr,FindStr,"*c!N!g*" & FindStr)
BaktrnStr = Replace(BaktrnStr,FindStr,"*c!N!g*" & FindStr)
ElseIf i >= k And i < k + l + 1 And l <> 0 Then
BaksrcStr = Replace(BaksrcStr,FindStr,FindStr & "*c!N!g*")
BaktrnStr = Replace(BaktrnStr,FindStr,FindStr & "*c!N!g*")
ElseIf i >= k + l And i < k + l + m + 2 And m <> 0 Then
BaksrcStr = Replace(BaksrcStr,FindStr,"*c!N!g*")
BaktrnStr = Replace(BaktrnStr,FindStr,"*c!N!g*")
End If
End If
End If
Next i
End If
srcStrArr = Split(BaksrcStr,"*c!N!g*",-1)
trnStrArr = Split(BaktrnStr,"*c!N!g*",-1)
'字串处理
srcNum = UBound(srcStrArr)
trnNum = UBound(trnStrArr)
If srcNum = trnNum And srcNum <> 0 And trnNum <> 0 Then
TempArr = MergeArray(srcStrArr,trnStrArr)
trnStrBak = ReplaceStrSplit(CheckID,trnStrBak,TempArr,iVo)
Else
trnStrBak = StringReplace(CheckID,srcStrBak,trnStrBak,iVo)
End If
Else
trnStrBak = StringReplace(CheckID,srcStrBak,trnStrBak,iVo)
End If
'计算快捷键数
BaksrcStr = srcStrBak
BaktrnStr = trnStrBak
toRepStr = Trim(AccessKeyCharArr(0))
If AccessKeyChar <> "" Then
For i = 0 To UBound(AccessKeyCharArr)
FindStr = Trim(AccessKeyCharArr(i))
If FindStr <> "" And FindStr <> toRepStr Then
BaksrcStr = Replace(BaksrcStr,FindStr,toRepStr)
BaktrnStr = Replace(BaktrnStr,FindStr,toRepStr)
End If
Next i
End If
srcAccKeyNum = UBound(Split(BaksrcStr,toRepStr,-1))
trnAccKeyNum = UBound(Split(BaktrnStr,toRepStr,-1))
'还原不是快捷键的快捷键
If KeepCharPair <> "" Then
For i = 0 To UBound(KeepCharPairArr)
FindStr = Trim(KeepCharPairArr(i))
If FindStr <> "" Then
LFindStr = Trim(Left(FindStr,1))
RFindStr = Trim(Right(FindStr,1))
ToRepStr = LFindStr & "*!N!" & i & "!M!" & i & "!N!*" & RFindStr
BeRepStr = LFindStr & "&" & RFindStr
srcStrBak = Replace(srcStrBak,ToRepStr,BeRepStr)
trnStrBak = Replace(trnStrBak,ToRepStr,BeRepStr)
End If
Next i
End If
'还原字串中被排除的非快捷键
If ExcludeChar <> "" Then
For i = 0 To UBound(ExcludeCharArr)
FindStr = LTrim(ExcludeCharArr(i))
If FindStr <> "" Then
srcStrBak = Replace(srcStrBak,"*a" & i & "!N!" & i & "d*",FindStr)
trnStrBak = Replace(trnStrBak,"*a" & i & "!N!" & i & "d*",FindStr)
End If
Next i
End If
CheckHanding = trnStrBak
End Function
'在快捷键后插入特定字符并以此拆分字串
Function Insert(SplitString As String,SplitStr As String,InsStr As String,Leng As Long) As String
Dim i As Long,oldLeng As Long,StartNum As Long,EndNum As Long
Dim newLeng As Long,accesskeyStr As String
Insert = SplitString
If UBound(Split(SplitString,SplitStr)) < 2 Then Exit Function
StartNum = InStr(Insert,SplitStr)
EndNum = InStrRev(Insert,SplitStr)
If StartNum < EndNum Then
For i = StartNum To EndNum
If Mid(Insert,i,Len(SplitStr)) = SplitStr Then
oldLeng = InStr(Mid(Insert,i+Len(SplitStr)),SplitStr)
newLeng = InStr(Mid(Insert,i+Len(SplitStr)),InsStr)
accesskeyStr = ""
|手机版|小黑屋|AUTOIT CN
( 鲁ICP备19019924号-1 )谷歌
百度
发表于 2011-12-27 14:38:43