" Dim sUni If iCle = 13 Then sUni = document.all.Saisie.value 'valeur fournie dans le formulaire 'msgbox "AffFicheSaisie: " & sUni If sUni <> "" Then document.location.hash = "" AffFicheNet sUni, sDico, sDicoMot 'document.all.Bloc.innerHtml = "" & sDes & "" If Left(document.all.Bloc.innerHtml, Len(kIdVierge)) = kIdVierge Then document.all.Bloc.innerHtml = "" End If window.event.keyCode = 0 ' bouffer la clé 'CreerBloc '...mis pour post imprimer qui n'est pas synchro, mais éviter (ralentit) End If End Sub '---------- Partie Cjk (par clés) Dim sBlocAct Dim bBlocAct 'continuer à mettre à jour Sub CreerBlocCjk(sDico, sZiCumul) Const kListeCle = "<19968><20008><20022><20031><20057><20101><20108><20128><20154><20799><20837><20843><20866><20886><20907><20960><20981><20992><21147><21241><21269><21274><21304><21313><21340><21353><21378><21430><21448><21475><22231><22303><22763><22786><22794><22805><22823><22899><23376><23424><23544><23567><23586><23608><23662><23665><24027><24037><24049><24062><24178><24186><24191><24308><24318><24331><24339><24400><24417><24435><24515><25096><25142><25163><25903><25908><25991><26007><26020><26041><26080><26085><26352><26376><26408><27424><27490><27513><27571><27595><27604><27611><27663><27668><27700><28779><29226><29238><29243><29247><29255><29273><29275><29356><29572><29577><29916><29926><29976><29983><29992><30000><30091><30098><30326><30333><30382><30399><30446><30683><30690><30707><31034><31160><31166><31348><31435><31481><31859><31992><32566><32593><32650><32701><32769><32780><32786><32819><32895><32905><33251><33258><33267><33276><33292><33307><33311><33390><33394><33400><34381><34411><34880><34892><34915><35198><35211><35282><35328><35895><35910><35925><35960><35997><36196><36208><36275><36523><36554><36763><36784><36789><37009><37193><37318><37324><37329><38263><38272><38428><38582><38585><38632><38737><38750><38754><38761><38859><38893><38899><38913><39080><39131><39135><39318><39321><39340><39592><39640><39647><39717><39727><39730><39740><39770><40165><40565><40575><40613><40635><40644><40653><40657><40697><40701><40718><40723><40736><40763><40778><40786><40845><40860><40864><40869>" Const kCleVolumineuse = "<20154><21475><24515><25163><26408><27700><31992><33400><35328><37329>" ' Inutile, il suffit de calculer l'écart avec la suivante Const kNbCol = 24 '32 'Const kNbLig = 17 Const kNbLigMin = 4 Const kHashImplicite = "#19968" Const kMinCjk = 19968 Const kMaxCjk = 40869 Dim sUni, sUniSui Dim sDes, sDesLig Dim xDeb Dim i, j, k Dim iNbLig sBlocAct = "" bBlocAct = True RafraichirBloc 'déclencher le chrono, mais il se déclenche seulement quand on sort de cette procédure window.status = "Recherche des caractères..." 'msgbox "CreerBlocCjk" 'NB, vient chaque fois qu'on sélectionne un car. car déclencé par onfocus 'window.setInterval "RafraichirBloc()", 100 'ne marche pas mieux que window.setTimeout sDes = "" sUni = document.location.hash If sUni = "" Then sUni = kHashImplicite sUni = Mid(sUni, 2) i = Instr(kListeCle, sUni) sUniSui = Mid(kListeCle, i + 7, 5) iNbLig = Int((sUniSui - sUni) / kNbCol) + 1 If iNbLig < kNbLigMin Then iNbLig = kNbLigMin For i = 0 To iNbLig - 1 For j = 0 To kNbCol - 1 k = (sUni + i * kNbCol + j) If (k < kMaxCjk) And (Instr(kListeCle, k) > 1) Then sDesLig = sDesLig & "&#" & k & ";" 'ElseIf DefExiste(sDico, k) Then ElseIf Instr(sZiCumul, ChrW(k)) > 0 Then sDesLig = sDesLig & "&#" & k & ";" Else sDesLig = sDesLig & "&#" & k & ";" End If Next sDes = sDes & sDesLig If i Mod 1 = 8 Then 'document.all.Bloc.innerHtml = "" & i & sDes & "" 'inutile... sBlocAct = "" & sDes & "" 'window.status = i End If sDesLig = "" If k >= kMaxCjk Then Exit For Next bBlocAct = False window.status = "Terminé" 'window.clearInterval document.all.Bloc.innerHtml = "" & sDes & "" document.selection.empty document.all.Bloc.setActive End Sub Sub RafraichirBloc ' Problème: n'est enclenché que lorsque CreerBlocCjk est fini, quelque soit le délai '... on pourra le détruire Dim iChrono 'window.status = "Rafraîchir" If bBlocAct Then 'If bBlocAct < 30 Then setTimeout "RafraichirBloc()", 100 document.all.Bloc.innerHtml = sBlocAct iChrono = 0 Do While iChrono < 10000 iChrono = iChrono + 1 Loop bBlocAct = bBlocAct + 1 End If End Sub Sub SaisirCle(iCle, sDico, sDicoMot) ' Afficher la traduction du texte sélectionné si iCle est correcte Const kCleAffFiche = 13 Const kCleVisible = 32 If iCle = kCleVisible Then VisibleIntervertir window.event.keyCode = 0 ' bouffer la clé ElseIf iCle = kCleAffFiche Then AffFiche sDico, sDicoMot window.event.keyCode = 0 ' bouffer la clé End If End Sub Sub VisibleIntervertir() ' Cacher ou montrer les caractères sans traduction Dim sVisible sVisible = document.styleSheets(1).rules(inconnu).style.display If sVisible = "none" Then document.styleSheets(1).rules(inconnu).style.display = "inline" Else document.styleSheets(1).rules(inconnu).style.display = "none" End If End Sub '---------- partie pinyin Sub CreerBlocPinyin(sDico) Const kNbCol = 32 Const kNbLigMin = 8 Const kHashImplicite = "a" Const kDelimPin = "." Const kMaxPinTons = 5 Dim iNbLig Dim sPin Dim tPin, i Dim sDes, sHom sDes = "" sPin = document.location.hash sPin = Mid(sPin, 2) If sPin = "" Then sPin = kHashImplicite sPin = AccentuerPinyin(sPin) tPin = Split(sPin, kDelimPin) For i = 0 To kMaxPinTons - 1 sHom = TrouverHomophones(sDico, tPin(i)) If sHom <> "" Then sDes = sDes & " " & tPin(i) & " " & TrouverHomophones(sDico, tPin(i)) Next document.all.Bloc.innerHtml = "" & sDes & "" document.selection.empty document.all.Bloc.setActive End Sub '---------- partie commune Sub AffSelFiche(sDico, sDicoMot) AffFiche sDico, sDicoMot 'refuser si on n'est pas dans document.all.BlocCjk AffSel sDico End Sub Sub AffFiche(sDico, sDicoMot) Dim sFiche, raSel Dim iUni, sUni, sPin, sTra Dim iClasse 'extraire les premières lignes dans chott.vs Set raSel = document.selection.createRange() sUni = raSel.text ' iClasse = raSel.ClassName 'msgbox iClasse If sUni = "" then Exit Sub 'If document.selection.style.class = "Pin" Then bPin = True AffFicheNet sUni, sDico, sDicoMot End Sub Sub AffFicheNet(sUni, sDico, sDicoMot) Dim sFiche Dim iUni Dim sPin, sTra, bExact If sUni = "" then Exit Sub iUni = Ascw(Left(sUni,1)) If iUni < 0 Then iUni = iUni + &H10000 bExact = False If window.event.altKey Then bExact = True 'recherche exacte si Alt If iUni < kMinCjk Then sUni = Trim(sUni) If AscW(Left(sUni, 1)) >= kDebKana Then If Len(sUni) < 2 Then Exit Sub 'If window.event.altKey Then sUni = kDelimChamp & sUni & kDelimChamp Else If Len(sUni) < 3 Then Exit Sub 'If window.event.altKey Then sUni = ", " & sUni & "," 'recherche exacte si Alt End If sFiche = CreerFicheLatin(sDico, sDicoMot, sUni, bExact) Else sUni = iUni sFiche = CreerFiche(sDico, sDicoMot, iUni, sPin, sTra) End If If sFiche <> "" Then document.selection.empty document.all.Fiche.innerHtml = sFiche AffShufa sUni, sPin End If End Sub Sub AffShufa(sUni, sPin) ' En entrée les 5 chiffres Unicode et le pinyin 'Const kNomRep = "../../sh/" Const kNomRep = "../sh/" Dim sPinNet Dim sNomFi Dim s, sIcone, sIconeAction 'sPinNet = DesaccentuerPinyin(sPin) 'sPinNet = Ucase(Left(sPinNet, 1)) & Mid(sPinNet, 2) 'sNomFi = kNomRep & "zh" & sPinNet & "-" & sUni & ".gif" sNomFi = kNomRep & "zh" & "-" & sUni & ".gif" s = "
 " 's = "

 " sIconeAction = "onclick='vbScript:CacherMontrerShufa'" sIcone = "书 " '书s 26360t Shufa.innerHtml = sIcone & s End Sub Sub CacherMontrerShufa If document.all.imShufa.style.display = "none" Then document.all.imShufa.style.display = "inline" Else document.all.imShufa.style.display = "none" End If 'this.style.background-color = "#00099" 'msgbox "Coucou" End Sub Sub TraiterErreurs() ' Une seule erreur pour le moment 'msgbox "TraiterErreurs" Shufa.innerHtml = "" 'image non trouvée: effacer son marqueur End Sub Sub ChargementTermine() document.body.style.cursor = "default" End Sub -->