Sub LingeaHeslo() ' 'Předpřipraví aktuální řádek tabulky pro zanesení do uživatelského slovníku 'Lingea Lexiconu. Některé změny je nutno dodělat ručně. ' 'CHYBY '* dává o jedno navíc. Prošel jsem všechna podřazená makra a nenašel jsem chybu. Dim Skupiny() On Error Resume Next Selection.SelectRow Selection.Copy ChangeFileOpenDirectory "C:\David\Jazyky\latina\" 'Cestu si změňte Documents.Open FileName:="llprac.doc", ConfirmConversions:=True, ReadOnly:= _ False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _ "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto 'Název souboru si změňte na nějaký, který v daném 'adresáři existuje. Selection.WholeStory Selection.Paste Application.ScreenUpdating = False Application.run macroname:="LingeaZnakyUpravit" Selection.Find.Replacement.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Značka pozn. pod čarou") With Selection.Find .text = "^?" .Replacement.text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll 'Selection.TypeText text:=vbTab & vbTab Selection.MoveUp unit:=wdLine, Count:=2 Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:= _ True 'Dodání valence. Je zde lepší než na konci, zejm. kvůli závorkovým 'valencím a #&#&# v LingeaValenceNelatinská. Application.run macroname:="LingeaValenceDodat" Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^t" .Replacement.text = "^p=" .Wrap = wdFindContinue .Format = False .Execute Replace:=wdReplaceOne 'Jen jednou. End With 'Call LingeaTvaryDodatKonkrétní 'Ne, toto ledacos kazí. PrvniOdstavec = ActiveDocument.Paragraphs(1) 'Ověříme, zda jsou uvedeny různé tvary slova. If InStr(1, PrvniOdstavec, ", ") Then Selection.HomeKey unit:=wdStory With Selection.Find .text = ", " .Replacement.text = "^p") End If With Selection.Find .text = "^t" .Replacement.text = "^p" With Selection.Find .text = "; " .Replacement.text = "^p=" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "(" .Replacement.text = "> tam musí zůstat. Proto v externím makru udělána 'distinktivním kódem, který nyní nahradíme. With Selection.Find .text = ">#&#&#>" .Replacement.text = ">>" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " Skupiny = Array("I.", "II.", "III.", "IV.", "V.", "VI.") For i = 0 To UBound(Skupiny) With Selection.Find .text = "=" & Skupiny(i) & " " .Replacement.text = "^p=" .Wrap = wdFindContinue .MatchCase = True .Execute Replace:=wdReplaceAll End With Next Selection.Find.MatchCase = False Selection.WholeStory 'První znak. If ActiveDocument.Characters(1) <> "#" Then Selection.HomeKey unit:=wdStory Selection.TypeText text:="#" End If 'LingeaValenceDodat spustíme ještě jednou, protože k některým nahrazením došlo 'až při druhém spuštění a odstraňování přebytečných značek funguje zdá se 'bezchybně. Pokud vám to kód nějak kazí, vymažte následující řádek. Application.run macroname:="LingeaValenceDodat" Application.run macroname:="LingeaUpřesněníTypuPoznámekPodleSeznamuZkratek" Application.run macroname:="LingeaTvaryDodatKonkrétní" With Selection.Find .text = "). Některé změny je nutno dodělat ručně. 'Cestu si změňte. If Selection.Characters.Count < 2 Then Selection.SelectRow End If Selection.Copy ChangeFileOpenDirectory "C:\David\Jazyky\latina\" 'Cestu si změňte Documents.Open FileName:="llprac.doc", ConfirmConversions:=True, ReadOnly:= _ False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _ "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto 'Název souboru si změňte na nějaký, který v daném 'adresáři existuje. Selection.WholeStory Selection.TypeParagraph Selection.Paste Application.run macroname:="LingeaZnakyUpravit" 'Smazání poznámek pod čarou. Selection.Find.Replacement.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Značka pozn. pod čarou") With Selection.Find .text = "^?" .Replacement.text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll 'Selection.TypeText text:=vbTab & vbTab Selection.HomeKey unit:=wdStory Selection.MoveDown unit:=wdLine, Count:=1 Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:= _ True Application.run macroname:="LingeaValenceDodat" Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue .Format = False .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p" .Replacement.text = "^p> tam musí zůstat. Proto v externím makru udělána 'distinktivním kódem, který nyní nahradíme. With Selection.Find .text = ">#&#&#>" .Replacement.text = ">>" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Také ">" ve fontu SPIonic nahradíme. With Selection.Find .text = ">" .Replacement.text = ")" .Forward = True .Wrap = wdFindContinue .Format = True .Execute Replace:=wdReplaceAll End With Selection.Find.Format = False Selection.Find.ClearFormatting 'Značka užívaná mnou místo středníku v poznámkách. With Selection.Find .text = "::" .Replacement.text = ";" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Call LingeaUpřesněníTypuPoznámekPodleSeznamuZkratek Selection.HomeKey unit:=wdStory Selection.Delete Selection.WholeStory Selection.Copy End Sub Sub LingeaValenceDodat() 'Dodá značky valence (francouzské, české, anglické a latinské) do aktivního 'dokumentu obsahujícího uživatelský slovník pro Lingea Lexicon (). 'Jde jen o velmi hrubý nástroj; ve výstupu je mnoho chyb, které je třeba 'upravit pozměněním makra, hromadným nahrazováním či ručně. 'Vyžaduje též velmi jednotně uváděnou valenci v předloze. 'Obecný problém je: buď nahradím kratší výrazy (např. "co") už v první vlně, 'ale to pak makro nenajde např. "pro co", protože to bude vypadat "pro ", 'nebo nahradit nejdříve "pro co" a pak "co", což zase povede k výsledku '">". Nejlepší by bylo po dokončení vzniklé chyby opravit pomocí 'Selection.Find (vymazat všechny řetězce ">"). 'CHYBY '* Někdy nefunguje správně a pak najednou ano. Je to divné, ale je to tak. ' Ověřeno mnohokrát. Zkuste v případě problémů zcela zavřít Word a pak jej znovu ' spustit a makro spustit znovu. 'Vytvoříme si kolekci, abychom nemuseli opakovat nahrazování do kódu jednotlivě 'pro každou položku. Dim Valence As New Collection 'Zrušíme aktualizaci obrazovky. Application.ScreenUpdating = False Selection.HomeKey unit:=wdStory 'Odstraníme před všemi entery mezeru. With Selection.Find .text = " ^p" .Wrap = wdFindContinue .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll End With 'Naskládáme si položky do kolekce. 'Obecné poznámky ke skladbě vyhledavacího řetězce: 'je nutné myslet na podobná slova (o čem - o čemž), na to, že někdy bývá 'vazba na začátku řádku (takže mezera před nemusí být vhodná, ale jindy je zase 'potřebná: "koho" nesmí nahrazovat na "ně"). Nicméně je potřeba 'zpracovat velmi časté řádky typu "(st.)" prokázat co. To uděláme pomocí dvojího 'nahrazení, jednoho pro pouhou mezeru, jednoho se závorkou. 'Další problém jsou předložková lemmata: for = pro ; 'výsledek by neměl být , ale je takový; to se nedá nic dělat. 'Obecně platí, že když jsou jednodušší dřív (např. "co"), tak to daný řetězec 'změní natolik, že se jako složitější (např. "pro co") nenajdou. Je třeba 'dávat nejdřív ta složitější a pak ta jednodušší, ale to zase vede k tomu, že 'se značky valence duplikují. 'Ruční úprava bude vždy nutná; ve výstupu je mnoho chyb. Často se opakující 'chyby lze opravit nahrazováním ve Wordu. With Valence 'Francouzština .Add (" de qc. \`a q.") .Add (" \`a q. de faire qc.") .Add (" \`a q., qc.") .Add (" qc. \`a q.") .Add (" qc. \`a qc.") .Add (" q./qc. \`a q./qc.") .Add (" \`a q./qc.") .Add (" \`a q.") .Add (" \`a qc.") .Add (" de qc. sur qc.") .Add (" qc. sur q.") .Add (" \`a q. de faire qc.") .Add (" q. de faire qc.") .Add (" q. \`a faire qc.") .Add (" q. sur qc.") .Add (" q. pour qc.") .Add (" q. de qc.") .Add (" de q., qc.") .Add (" de q./qc.") .Add (" de q.") .Add (" de qc.") .Add (" entre qc. et qc.") .Add (" entre q. et q.") .Add (" contre q., qc.") .Add (" contre q./qc.") .Add (" contre q.") .Add (" contre qc.") .Add (" par q., qc.") .Add (" par q./qc.") .Add (" par q.") .Add (" par qc.") .Add (" sans q./qc.") .Add (" sans q., qc.") .Add (" sans q.") .Add (" sans qc.") .Add (" dans qc.") .Add (" avec q., qc.") .Add (" avec q./qc.") .Add (" avec q.") .Add (" avec qc.") .Add (" pour q., qc.") .Add (" pour q.") .Add (" pour qc.") .Add (" \`a faire qc.") .Add (" de faire qc.") .Add (" pour faire qc.") .Add (" faire qc.") .Add (" q. o\`u") .Add (" q., qc.") .Add (" q./qc.") .Add (" q.") .Add (" qc.") 'Čeština .Add (" koho z čeho") .Add (" co z čeho") .Add (" co k čemu") .Add (" co pro koho") .Add (" co komu") .Add (" co odkud") .Add (" bez koho / čeho") .Add (" bez koho/čeho") .Add (" bez koho") .Add (" bez čeho") .Add (" koho / čeho") .Add (" koho/čeho") .Add (" do koho") .Add (" do čeho") .Add (" u koho za koho") .Add (" u koho/čeho") .Add (" u koho / čeho") .Add (" z koho/čeho") .Add (" z čeho") .Add (" z koho") .Add (" u koho") .Add (" u čeho") .Add (" ke komu / k čemu") .Add (" ke komu / čemu") .Add (" proti komu / čemu") .Add (" proti komu/čemu") .Add (" komu k čemu") .Add (" komu s čím") .Add (" komu na co") .Add (" komu / čemu") .Add (" komu/čemu") .Add (" komu, čemu") .Add (" ke komu") .Add (" komu co") .Add (" koho k čemu") .Add (" k čemu^p") .Add (" k čemu,") .Add (" k čemu ") .Add (" komu,") 'Tento způsob zpracování funguje správně, vyřešen níže. .Add (" komu^p") 'Tento způsob zpracování funguje, ověřeno, ale někdy až na druhé spuštění. .Add (" komu ") .Add (" čemu") .Add (" co na koho") .Add (" na koho / na co") .Add (" na koho/co") .Add (" na koho / co") .Add (" na koho") .Add (" od koho / čeho") .Add (" od koho/čeho") .Add (" od koho") .Add (" od čeho") .Add (" koho o čem") .Add (" koho na koho") .Add (" koho na co") .Add (" koho do čeho") .Add (" koho za co") .Add (" koho s kým") .Add (" koho čím") .Add (" koho kam") .Add (" koho odkud") .Add (" koho, čeho") .Add (" koho čeho") .Add (" čeho") .Add (" čeho,") .Add (" čeho^p") .Add (" na co") .Add (" o co") .Add (" v co") .Add (" za co") .Add (" v koho") .Add (" koho za koho") .Add (" za koho / co") .Add (" za koho/co") .Add (" za koho") .Add (" v koho / co") .Add (" v koho/co") .Add (" pro koho / co") .Add (" pro koho/co") .Add (" na koho / co") .Add (" pro koho") .Add (" koho / co") .Add (" koho/co") .Add (" koho komu") .Add (" co od koho") .Add (" koho") .Add (" pro co") .Add (" dělat co") .Add (" udělat co") .Add (" co s čím") .Add (" co v čem") .Add (" co komu") .Add (" co čím") .Add ("absol./co ") .Add (" co,") .Add (" co ") .Add (" co^p") .Add (" při kom,") .Add (" při kom^p") .Add (" při kom ") .Add (" při čem,") .Add (" při čem^p") .Add (" při čem ") .Add (" o kom / o čem") .Add (" o kom / čem") .Add (" o kom/čem") .Add (" o kom") .Add (" o čem ") .Add (" o čem,") .Add (" o čem^p") 'Takto dáno, aby to nenahrazovalo "o čemž". .Add (" na kom") .Add (" po kom / čem") .Add (" po kom/čem") .Add (" po kom / po čem") .Add (" po kom") .Add (" po čem") .Add (" v čem ") .Add (" v čem,") .Add (" v čem^p") .Add (" v kom / čem") .Add (" v kom/čem") .Add (" v kom / v čem") .Add (" v kom") .Add (" na kom / na čem") .Add (" na čem") .Add (" před kým / čím") .Add (" před kým/čím") .Add (" před kým") .Add (" před čím") .Add (" s kým / čím") .Add (" s kým") .Add (" s čím") .Add (" kým / čím") .Add (" kým/čím") .Add (" kým") .Add (" čím") .Add (" kde,") .Add (" kde^p") .Add (" kam,") .Add (" kam^p") .Add (" kam)") .Add (" kam ") 'Angličtina .Add (" sb. to sb.") .Add (" sb. to st.") .Add (" st. in st.") .Add (" for sb. / st.") .Add (" for sb./st.") .Add (" for sb.") .Add (" for st.") .Add (" with sb. / st.") .Add (" with sb./st.") .Add (" with sb.") .Add (" with st.") .Add (" by sb. / st.") .Add (" by sb./st.") .Add (" by sb.") .Add (" by st.") .Add (" in sb. / st.") .Add (" in sb./st.") .Add (" in sb.") .Add (" in st.") .Add (" of sb. / st.") .Add (" of sb./st.") .Add (" of sb.") .Add (" of st.") .Add (" after sb. / st.") .Add (" after sb./st.") .Add (" after sb.") .Add (" after st.") .Add (" on sb. / st.") .Add (" on sb./st.") .Add (" on sb.") .Add (" on st.") .Add (" from sb. / st.") .Add (" from sb./st.") .Add (" from sb.") .Add (" from st.") .Add (" to sb. / st.") .Add (" to sb./st.") .Add (" to sb.") .Add (" to st.") .Add (" by sb. / st.") .Add (" by sb./st.") .Add (" by sb.") .Add (" by st.") .Add (" about sb. / st.") .Add (" about sb./st.") .Add (" about sb.") .Add (" about st.") .Add (" sb. / st.") .Add (" sb./st.") .Add (" sb.") .Add (" st.") 'Latina .Add ("alqs") .Add ("alqd alci") .Add ("alqd facere") .Add (" contra alqm") .Add ("alqm alci") .Add ("alcis rei / alqa re") .Add ("alcis rei") .Add ("alicuius rei") .Add ("alcis") .Add ("alicuius") .Add ("alci / alci rei") .Add ("alci rei") .Add ("alci") .Add ("in alqm") .Add ("alqm unde") .Add ("alqm in alqd") .Add ("in alqd") .Add ("alqm/alqd") .Add ("alqm / alqd") .Add ("alqm") .Add ("aliquem") .Add (" alqd de alqd") .Add ("ad alqd") .Add ("absol./alqd") .Add (" alqd per alqm") .Add (" alqd") .Add (" aliquid") .Add (" ab alqo") .Add (" ex alqa re") .Add (" de alqo") .Add (" cum alqo") .Add (" pro alqo") .Add ("alqo") .Add ("ab aliquo") .Add (" de aliquo") .Add ("aliquo") .Add (" de alqa re") .Add (" ab alqa re") .Add ("pro alqa re") .Add (" sine alqa re") .Add (" in alqa re") .Add ("alqa re") .Add (" de aliqua re") .Add ("aliqua re") 'Zkratky pádů v závorkách z obou stran. To nebývají poznámky : ty bývají 'širší. Takže toto mužeme přidat. Také sem dáme absolutní užití a infinitiv. .Add ("inf.") .Add ("absol.") .Add ("gen.") .Add ("dat.") .Add ("ak.") .Add ("abl.") .Add ("lok.") .Add ("instr.") 'Řečtina viz LingeaValenceNelatinská. Spouští se i tímto makrem. End With 'Problém s mezerou na začátku je ten, že pokud je valence uvedená v závorkách, 'tak k nahrazení nedojde. Na druhou stranu je to dobrá ochrana proti 'nežádoucímu nahrazení tam, kde nejde o předložku, nýbrž o konec slova. Proto 'provedeme pomocné nahrazování. Níže zase vrátíme tuto změnu zpět. With Selection.Find .text = "(" .Wrap = wdFindContinue .Replacement.text = "(@&@ " .Execute Replace:=wdReplaceAll End With For Each Polozka In Valence StatusBar = "Probíhá doplňování značek valence." 'Nejprve nastavíme, aby byl výsledek zatržen červeně a tučně; tak si bude 'uživatel moci výsledek snadněji zkontrolovat. With Selection.Find.Replacement.Font .Bold = True .Color = wdColorRed End With 'Vyrobíme si ořezanou verzi položky. OrizlaPolozka = Polozka Oriznute1 = "" Oriznute2 = "" 'Nyní si položku ořežeme. If Left(Polozka, 1) = " " Then 'LTrim mi nefungovalo OrizlaPolozka = Right(Polozka, Len(Polozka) - 1) Oriznute1 = " " End If If Right(OrizlaPolozka, 1) = "," Then OrizlaPolozka = Left(OrizlaPolozka, Len(OrizlaPolozka) - 1) Oriznute2 = "," End If If Right(OrizlaPolozka, 2) = "^p" Then OrizlaPolozka = Left(OrizlaPolozka, Len(OrizlaPolozka) - 2) Oriznute2 = Oriznute2 & "^p" End If If Right(OrizlaPolozka, 2) = " " Then OrizlaPolozka = Left(OrizlaPolozka, Len(OrizlaPolozka) - 1) Oriznute2 = Oriznute2 & " " End If 'Nyní vlastní nahrazování. Nejprve verze se závorkou. With Selection.Find .text = "(" & OrizlaPolozka & ")" .Wrap = wdFindContinue .Format = True .Replacement.text = "" & Oriznute2 .Execute Replace:=wdReplaceAll End With 'Nyní verze bez závorky. With Selection.Find .text = Polozka .Replacement.text = Oriznute1 & "" & Oriznute2 .Wrap = wdFindContinue .Format = True .Execute Replace:=wdReplaceAll End With Next 'Nelatinská valence včetně značky <1.> za pomoci externího makra. On Error Resume Next Application.run macroname:="LingeaValenceNelatinská" 'Několik dodatečných úprav. Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "(@&@ " .Wrap = wdFindContinue .Replacement.text = "(" .Execute Replace:=wdReplaceAll .Format = False End With With Selection.Find .text = "^p>" .Wrap = wdFindContinue .Replacement.text = ">^p" .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "> změní na apod. 'Je potřeba nechat cyklus proběhnout dostkrát a zároveň nedospět 'k nekonečnému cyklu. Spočítáme si proto nejdřív počet značek valence. 'Neumím to jednoduše, jen složitě. Takže to musíme udělat složitě. Selection.WholeStory maxkol = 0 ZpracovatPrac = Selection.text Do ObsahujePrac = InStr(1, ZpracovatPrac, " 0 Then maxkol = maxkol + 1 End If ZpracovatPrac = Right(ZpracovatPrac, Len(ZpracovatPrac) - ObsahujePrac - 3) Loop Until ObsahujePrac = 0 Selection.HomeKey unit:=wdStory 'Přeskočíme na první značku valence. With Selection.Find .text = ("". Selection.Extend With Selection.Find .text = (">") .Wrap = wdFindContinue .Forward = True .Execute End With Selection.EscapeKey 'Zrušíme Extend. 'Cyklus, který bude v celém dokumentu provádět odstraňování. PocetKol = 0 Do 'Někdy docházelo k chybě na řádku Zkraceny = Right(Retezec, Len(Retezec) - 3): 'Invalid Procedure..., protože nebyl označený žádný text, neboť dokument 'žádný řetězec " 0 Then 'Pokud obsahuje, provedeme nahrazení v řetězci. Mid(Zkraceny, Obsahuje, 3) = " " 'Z pravého konce vyřadíme jeden znak ">" Zkraceny = Left(Zkraceny, Len(Zkraceny) - 1) 'Složíme dohromady s první značkou valence. Vysledny = "") .Wrap = wdFindStop .Forward = True .Execute End With Selection.EscapeKey 'Ochrana proti nekonečnému cyklu. 'Počítání MaxKol nefungovalo vždy správně, tak přidáme nějaká kola navíc. 'Nic by to nemělo zkazit. If PocetKol > maxkol + 100 Then Exit Do Loop Until Selection.Find.Found = False 'Dodatečné nahrazení mezer vzniklých přepsáním nadbytečných značek. 'Šlo by to také řešit jednoduše již v řetězci spojením Left a Right, kterým 'lze vyříznout některou vnitřní část řetězce. With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = " " .Replacement.text = " " .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "#&#&#" .Replacement.text = "" .Wrap = wdFindContinue '.Execute Replace:=wdReplaceAll End With 'Následující krok někdy dělá víc škody než užitku. Pokud se duplikují jen značky 'valence, tak už je vymazání zadní značky vyřešeno výše. With Selection.Find .text = ">>" .Replacement.text = ">" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Další dodatečné úpravy With Selection.Find .text = "" na poznámky odpovídajícího typu. Dim b As New Collection Dim d As New Collection Dim f As New Collection Dim m As New Collection Dim s As New Collection Dim x As New Collection Dim z As New Collection 'Nejdříve si naskládáme prvky do jednotlivých kolekcí. 'Je to úspornější a přehlednější než pro každou položku vypisovat samostatné 'nahrazování. With b .Add ("alch.") .Add ("anat.") .Add ("antroponym.") .Add ("archit.") .Add ("astr.") .Add ("astrol.") .Add ("bibl.") .Add ("biol.") .Add ("bot.") .Add ("círk.") .Add ("děj.") .Add ("dopr.") .Add ("ekon.") .Add ("etnonym.") .Add ("fil.") .Add ("film.") .Add ("fot.") .Add ("fyz.") .Add ("geogr.") .Add ("geol.") .Add ("geom.") .Add ("gram.") .Add ("hud.") .Add ("hut.") .Add ("chem.") .Add ("inform.") .Add ("jaz.") .Add ("kuch.") .Add ("les.") .Add ("lit.") .Add ("liturg.") .Add ("lék.") .Add ("log.") .Add ("mat.") '.Add ("poč.") 'toto se kryje s někdy mnou užívanou zkr. pro "počátek". Užívat inform. .Add ("meteor.") .Add ("metr.") .Add ("mysl.") .Add ("náb.") .Add ("námoř.") .Add ("obch.") .Add ("práv.") .Add ("sport.") .Add ("tech.") .Add ("telev.") .Add ("teol.") .Add ("typogr.") .Add ("voj.") .Add ("zahr.") .Add ("zeměd.") End With With d .Add ("amer.") .Add ("angl.") .Add ("anglosas.") .Add ("arab.") .Add ("att.") .Add ("belg.") .Add ("boh.") .Add ("dial.") .Add ("dór.") .Add ("germ.") .Add ("hebr.") .Add ("chcsl.") .Add ("ión.") .Add ("jihofr.") .Add ("kanad.") .Add ("nářeč.") .Add ("rcsl.") .Add ("reg.") End With With f .Add ("Aischylos") .Add ("Caesar") .Add ("Castanet") .Add ("Cicero") .Add ("Curtius") .Add ("DHC") .Add ("Euth. Akm.") .Add ("Euth. Zigab.") .Add ("Fournier") .Add ("Hérodotos") .Add ("Homér") .Add ("Horatius") .Add ("Int. Ioh.") .Add ("Livius") .Add ("Ovidius") .Add ("Platón") .Add ("Plautus") .Add ("Plinius") .Add ("RS") .Add ("Septuaginta") .Add ("Sofokl.") .Add ("Tacitus") .Add ("Thúkydidés") .Add ("TDH") .Add ("Vergilius") .Add ("Vg.") .Add ("Xenofón") End With With m .Add ("akt.") .Add ("částice") .Add ("čísl.") .Add ("dep.") .Add ("fem.") .Add ("fut.") .Add ("imp.") .Add ("impf.") .Add ("ind.") .Add ("indecl.") .Add ("indekl.") .Add ("inf.") .Add ("interj.") .Add ("j. č.") .Add ("jiné je") .Add ("komp.") .Add ("med.") .Add ("medpas.") .Add ("mn. č.") .Add ("neměn.") .Add ("neos.") .Add ("nesklon.") .Add ("impers.") .Add ("intrans.") .Add ("instr.") .Add ("konj.") .Add ("trans.") .Add ("o osobách") .Add ("o věcech") .Add ("part.") .Add ("pas.") .Add ("perf.") .Add ("pers.") .Add ("pf.") .Add ("plpf.") .Add ("předl.") .Add ("předpona") .Add ("předklonka") .Add ("příklonka") .Add ("přípona") .Add ("adv.") .Add ("sg.") .Add ("spojka") .Add ("subj.") .Add ("subst.") .Add ("superl.") .Add ("adj.") .Add ("pl.") .Add ("refl.") .Add ("sloveso") .Add ("zájm.") .Add ("záp.") .Add ("zvrat.") End With With s '.Add ("^#^#. stol.") 'Toto není platný znak do pole Nahradit čím. '.Add ("^#. stol.") 'Bylo by nutné to řešit jinak, přes speciální 'cyklus, který by zpracoval ty řetězce, kde jsou použity zástupné znaky. .Add ("arg.") .Add ("arch.") .Add ("bás.") .Add ("csl.") .Add ("dět.") .Add ("err.") .Add ("fam.") .Add ("hist.") .Add ("hovor.") .Add ("klas.") .Add ("kniž.") .Add ("iron.") .Add ("lid.") 'Toto vyřeší i řetězec "lid. lat." .Add ("mod.") .Add ("neklas.") .Add ("neol.") .Add ("od 1") '.Add ("od ^#^#. stol.") '.Add ("od ^#. stol.") .Add ("ojed.") .Add ("pozd.") .Add ("střv.") .Add ("vulg.") .Add ("zast.") .Add ("zhrub.") .Add ("zř.") End With With x .Add ("v. t.") .Add ("viz") .Add ("form.") End With With z .Add ("???") .Add ("ak. sl.") .Add ("asi,") .Add ("asi;") .Add ("BTL") .Add ("DZ") .Add ("česky DZ") .Add ("dávám") .Add ("doplnit") .Add ("el. sl.") .Add ("etym. sl.") .Add ("GEL") .Add ("hic sic") .Add ("LL") .Add ("LMALB") .Add ("LN") .Add ("LS") .Add ("Mill.") .Add ("MLLM") .Add ("nenal.") .Add ("nic v ") .Add ("nic víc") .Add ("ověřeno") .Add ("ověřit") .Add ("PR") .Add ("překlad DZ") .Add ("přel.") .Add ("přeložil DZ") .Add ("Pražák") .Add ("R)") .Add ("tak ") .Add ("takto ") .Add ("TLFI") .Add ("sic") .Add ("snad,") .Add ("snad;") .Add ("zde skutečně") .Add ("zde takto") .Add ("zřejmě,") .Add ("zřejmě;") End With Application.ScreenUpdating = False Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting 'Provedené změny zvýrazníme modře a tučně. With Selection.Find.Replacement.Font .Bold = True .Color = wdColorBlue End With 'Začínáme nahrazovat (po jednotlivých kolekcích). Podmínka je zbytečná, protože 'jsme si položky sami do kolekce naskládali, takže víme, že tam jsou. 'Lze ji odstranit. If b.Count > 0 Then For Each Polozka In b With Selection.Find .text = " 0 Then For Each Polozka In d With Selection.Find .text = " 0 Then For Each Polozka In f With Selection.Find .text = " 0 Then For Each Polozka In m With Selection.Find .text = " 0 Then For Each Polozka In s With Selection.Find .text = " 0 Then For Each Polozka In x With Selection.Find .text = " 0 Then For Each Polozka In z With Selection.Find .text = " 0 Then Selection.HomeKey unit:=wdStory Selection.MoveDown unit:=wdLine, Count:=18 Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:= _ True End If 'Vymažeme případné přebytečné řádky a přebytečné tabulátory. With Selection.Find .text = "^t^t" .Replacement.text = "^t" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^t^t^t^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^t^t^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^t^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With 'Snahy provádět následující nahrazování přes Do ... Loop selhaly na hodnotě 'Selection.Find.Found, kterou vracelo makro jako False zřejmě i v případě, 'kdy došlo na konec dokumentu (ač výše v dokumentu ještě vyhledávaný řetězec byl). 'Proto je to zde vyřešeno prostým opakováním akce. Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "^p^p" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Application.ScreenUpdating = True 'Uložíme dokument. ActiveDocument.Save 'Nyní se dotážeme, zda se z tohoto souboru mají vytvořit dva speciální soubory. Odpoved = MsgBox("Mají se nyní vytvořit speciální soubory pro slovníky obou směrů?", 3) If Odpoved = vbCancel Then Exit Sub If Odpoved = vbNo Then Exit Sub If Odpoved = vbYes Then 'Část cizojazyčno-česká, přesněji ta, kde mají být heslovými slovy slova 'v levém sloupci tabulky. ActiveDocument.SaveAs FileName:="lingea-uziv-cizocz.doc", FileFormat:= _ wdFormatAuto, LockComments:=False, Password:="", AddToRecentFiles:= _ True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _ False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False 'Zákaz dělení slov. ActiveDocument.AutoHyphenation = False 'Převody formátu. Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^p" .Replacement.text = "^p^p#" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^t" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^p^p" .Replacement.text = "^p^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^p^p" .Replacement.text = "^p^p" .Wrap = wdFindContinue .Forward = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p#^p" .Replacement.text = "" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll If ActiveDocument.Characters(1) <> "#" Then Selection.HomeKey unit:=wdStory Selection.TypeText text:="#" End If ActiveDocument.Save 'Část česko-cizojazyčná, přesněji ta, kde mají být heslovými slovy slova 'v pravém sloupci tabulky. ChangeFileOpenDirectory cesta Documents.Open FileName:="lingea-uziv.doc", ConfirmConversions:=True, _ ReadOnly:=False, AddToRecentFiles:=True, PasswordDocument:="", _ PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _ WritePasswordTemplate:="", Format:=wdOpenFormatAuto ActiveDocument.SaveAs FileName:="lingea-uziv-czcizo.doc", FileFormat:= _ wdFormatAuto, LockComments:=False, Password:="", AddToRecentFiles:= _ True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _ False, SaveNativePictureFormat:=False, SaveFormsData:=False, _ SaveAsAOCELetter:=False 'Zákaz dělení slov. ActiveDocument.AutoHyphenation = False 'Převody formátu. Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^t^t" .Replacement.text = "^t" .Forward = True .Wrap = wdFindContinue .Format = False End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll 'Převod na tabulku Selection.WholeStory Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=3, _ NumRows:=57, Format:=wdTableFormatNone, ApplyBorders:=True, ApplyShading _ :=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:=True, _ ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False, _ AutoFit:=True, AutoFitBehavior:=wdAutoFitFixed Selection.HomeKey unit:=wdStory Selection.SelectColumn Selection.Cut Selection.InsertColumnsRight Selection.MoveLeft unit:=wdCharacter, Count:=1 Selection.Paste Selection.MoveRight unit:=wdCell Selection.MoveRight unit:=wdCell Selection.Columns.Delete 'Zpětný převod na text Selection.HomeKey unit:=wdStory Selection.MoveDown unit:=wdLine, Count:=11 Selection.Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:= _ True 'Dokončení nahrazování Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^p" .Replacement.text = "^p^p#" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^t^p" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^t" .Replacement.text = "^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p^p^p" .Replacement.text = "^p^p" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .text = "^p#^p" .Replacement.text = "" .Wrap = wdFindContinue End With Selection.Find.Execute Replace:=wdReplaceAll If ActiveDocument.Characters(1) <> "#" Then Selection.HomeKey unit:=wdStory Selection.TypeText text:="#" End If ActiveDocument.Save 'Nyní jsou oba soubory hotové a otevřené. Oznámíme to uživateli. zprava = "Oba soubory jsou hotové a otevřené. Nyní je potřeba z nich " _ & "prostřednictvím schránky (Ctrl+C) obsah ručně překopírovat " _ & "do příslušných uživatelských slovníků, otevřených v Poznámkovém " _ & "bloku. Možná je třeba provést ručně nějaké úpravy, např. smazat " _ & "přebytečné řádky. Za použití dalších maker, zejm. LingeaÚpravaDoPokročilejšíhoFormátu, " _ & "je možné přikročit k pokročilým úpravám." MsgBox zprava End If End Sub Sub LingeaHTML() 'Převede aktivní dokument (v němž musí být databáze v mé verzi značkování pro LL) 'do formátu HTML. Poté je nutné makrem LingeaHTMLrozdělit vytvořit jednotlivé 'soubory. 'Výstup se dá přímo přenést do souboru, ale není abecedně řazený; k abecednímu 'řazení je nejlepší rozdělit je do jednotlivých souborů pomocí LingeaHTMLrozdělit 'a poté spojit pomocí LingeaHTMLSpojit. Application.ScreenUpdating = False Call DěleníSlovZakázat 'Očíslujeme významy. Neposouvat dolů! Kódy typu “ obsahují klíčový znak! 'A také nedávat nic nad to. Call LingeaHTMLVýznamyOčíslovat 'Převedeme fonetickou abecedu. Call LingeaHTMLFonetickáAbeceda 'Opravení apostrofů. Selection.HomeKey unit:=wdStory With Selection.Find .text = "'" .Replacement.text = "’" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Opravení uvozovek na české. Zvážit, zda ponechat, či ne; někdy jsou v textech 'cizojazyčných příkladů, kde české být nemají. Call UvozovkyAnglickéNaČeské With Selection.Find .text = ChrW(8222) .Replacement.text = "„" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = ChrW(8220) .Replacement.text = "“" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Napravení speciálních znaků z kódů Lingey do znaků podporovaných kódováním 'windows-1250, popř. do speciálních kódů HTML. Call LingeaHTMLSpeciálníZnaky Selection.HomeKey unit:=wdStory Selection.TypeText "

" Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = "^p" .Replacement.text = "

^p

" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "

" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "

" .Replacement.text = "

" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "

" .Replacement.text = "

" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Různé hlavičky a poznámky. co = "

http://mujweb.cz/www/david.zbiral/jazyky.htm

" zaco = "

http://mujweb.cz/www/david.zbiral/jazyky.htm

" Call Nahradit(co, zaco) co = "

David Zbíral

" zaco = "

David Zbíral

" Call Nahradit(co, zaco) co = "^p

Charakteristika:" zaco = "^p

Charakteristika:" Call Nahradit(co, zaco) 'Postup na samotnou hlavičku titulu funguje, ale v dlouhém dokumentu dělal 'problémy - asi problém funkce NahrazovaciFunkce; patrně nekonečný cyklus. '(Nicméně před dodáním Neobsahuje Chr(13) do prvního postupu; teď už by to 'možná fungovalo správně). 'Vyřazeno a tuto část hlavičky je nutné dodělat ručně. Zpracováno 'jen to, kde je možné přesně určit syntaxi, jednodušším postupem. co = "KÝ SLOVNÍK ^#

" zaco = "^&" Call NahraditCase(co, zaco) co = "

ČESKO-" zaco = "

ČESKO-" Call NahraditCase(co, zaco) co = "

" zaco = "

" Call Nahradit(co, zaco) 'Levy = "

" 'Pravy = "KÝ SLOVNÍK ^#

" 'NahraditCo = "

" 'NahraditZaCo = "" 'Neobsahuje = Chr(13) 'Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Pravy = "" 'NahraditCo = "

" 'NahraditZaCo = "" & Chr(13) & Chr(13) & Chr(13) & "

" 'Neobsahuje = Chr(13) 'Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) ' je značka, kterou je zbytečné převádět do HTML. Smažeme ji. With Selection.Find .text = "" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With With Selection.Find .text = "" .Replacement.text = "^p" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Přeznačkujeme příklad se syntaxí ?x = y. Použijeme k tomu právě uvolněnou 'značku r. Rovnítko, bez rovnítka a nakonec samotná značka. Levy = "

?" Pravy = "

" NahraditCo = "=" NahraditZaCo = "" Neobsahuje = Chr(13) Obsahuje = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Bez rovnítka; jen pokud již neobsahuje , tj. pokud neproběhl minulý krok. Levy = "

?" Pravy = "

" NahraditCo = "

" NahraditZaCo = "

" Neobsahuje = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Nyní vlastní značka příkladu. Levy = "

?" Pravy = "

" NahraditCo = "

?" NahraditZaCo = "

" Neobsahuje = Chr(13) Obsahuje = "" 'Funkci zavoláme dvakrát; nefungovalo to nějak dobře. Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Segmenty, jež jsou součástí hlavičky hesla, nemají být ve výsledném kódu 'uzavřeny do

a

, proto některé entery vyřadíme. Kvůli úspornosti kódu 'makra a eleganci si pro Levy vytvoříme speciální kolekci. 'Nejprve vymazání značky

. NahraditCo = "

" NahraditZaCo = "" Neobsahuje = Chr(13) Obsahuje = "" Pravy = "

" Dim Leve As New Collection With Leve .Add ("

z těchto kombinací. Předefinujeme jen NahraditCo a Pravy, 'vše ostatní zůstane tak. Pravy = ">" NahraditCo = "

" For Each Levy In Leve Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Next 'HESLOVÉ SLOVO. Ani to nebude uzavřeno ve značce

. Levy = "

#" Pravy = "

" NahraditCo = "

#" NahraditZaCo = "" ' 'Abych nezapomněl, že bylo použito "a href", které je určeno vzhledem 'k tomu, že to dělá problémy, jen pro mně, přidám to do hlášení na konci. hlaseni = "" If InStr(NahraditZaCo, "") <> 0 Then hlaseni = " Bylo použito hypertextové označení hesla." Neobsahuje = Chr(13) Obsahuje = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Levy = "" NahraditCo = "

" NahraditZaCo = "" ' Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'OSTATNÍ ČÁSTI HESLA. 'Zavoláme si samostatnou funkci, v níž je určeno, co se má čím nahradit. 'Tato funkce tvoří jádro převodu. Kvůli úspornosti a eleganci budeme postupovat 'za použití pole. Pozor je potřeba dát na vnořené značky. Je nutné dát vždy 'ty, které bývají vnořené, až za ty, které jsou vyšší. 'Proto je c., e. aj. na konci a proto nahrazujeme za "" za " 0 Then pridavek = "()" If InStr(zavorkyhranate, zn) <> 0 Then pridavek = "[]" If InStr(svorky, zn) <> 0 Then pridavek = "{}" 'Nahrazení značky vzadu: ">" za "". Levy = "<" & zn & "." 'Tj. " 0 Then pridavek = "()" If InStr(zavorkyhranate, zn) <> 0 Then pridavek = "[]" If InStr(svorky, zn) <> 0 Then pridavek = "{}" If InStr(vlnovka, zn) <> 0 Then pridavek = "~" With Selection.Find .text = "<" & zn & "." .Replacement.text = "" & Left(pridavek, 1) .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next i 'Nahrazení pomocných segmentů za ">". With Selection.Find .text = "@&@" .Replacement.text = ">" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Několik závěrečných úprav: speciální třída

pro span p, q, w (bude tam 'větší odsazení zleva a menší písmo). Dim TridaP As New Collection With TridaP .Add ("p") .Add ("q") .Add ("w") End With For Each i In TridaP With Selection.Find .text = "

" .Replacement.text = "

" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next 'span="1" nefunguje; je třeba tam mít písmeno, jak jsem zjistil (chyba nebyla 've stylopise, měnil jsem to tam paralelně). With Selection.Find .text = "" .Replacement.text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Závěrečná nahrazení z makra LingeaHTMLVýznamyOčíslovat co = "@43@43@" zaco = "" .Replacement.text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next i 'Také heslové slovo má speciální třídu. With Selection.Find .text = "" .Replacement.text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'span="1" nefunguje; je třeba tam mít písmeno (chyba nebyla 've stylopise, měnil jsem to tam paralelně). With Selection.Find .text = "" .Replacement.text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'U valence ale nahradíme nadbytečné spany za speciální třídu span.vr. 'Musíme to provést pro uvozovky typu Chr(34) i uvozovky typu Chr(8222), které Word 'patrně při nahrazeních použil. Levy = "" Pravy = "" NahraditCo = "" NahraditZaCo = "" Neobsahuje = Chr(13) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Levy = "" NahraditCo = "" NahraditZaCo = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Levy = "" NahraditCo = "" NahraditZaCo = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Levy = "" NahraditCo = "" NahraditZaCo = "" 'NahraditCo = "" 'NahraditZaCo = "" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Poznámka latinkou v nitru textu psaného jiným písmem; automatizovaně dodáme 'pro znak paragrafů, který v řecko-české databázi zastupuje závorky (zabrané v řeckém 'fontu přízvuky). Vzniká tak dost škaredý segment kódu, nicméně vše je vymezeno 'takovými značkami, jak má: výstup má přehlednější datovou strukturu. Levy = "" Pravy = "" NahraditCo = "§§" NahraditZaCo = "(&#&" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Funkci voláme třikrát, protože nahradí jen první výskyt; pokud je mezi týmiž 'dvěma vymezovači více výskytů, je nutné akci opakovat. Levy = "" 'Ostatní proměnné zůstanou. Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) NahraditCo = "§" NahraditZaCo = ")&#&" Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Levy = "" 'Ostatní proměnné zůstanou. Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) co = "&#&" zaco = "" Call Nahradit(co, zaco) 'Synonymum: vlnovka působí zmatek. With Selection.Find .text = "~" .Replacement.text = "" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Apostrof musíme vrátit zpátky na rovný; v SPIonic musí být rovný. With Selection.Find .text = "’" .Replacement.text = "'" .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With 'Vložení tvrdých mezer před příklonné české předložky s, v, z. Call TvrdeMezeryHTMLPredPredlozky 'Oprava. co = "" zaco = "

" Call Nahradit(co, zaco) 'Funkci převodu znaků LingeaHTMLSpeciálníZnaky v řeckém sl. ani volat nebudeme. ActiveDocument.Save StatusBar = "Hotovo." End Sub Sub LingeaHTMLČeskoŘecký() 'Převod česko-řeckého slovníku. Zavoláme základní převod a poté provedeme dodatečné 'úpravy; je to tak jistější a jednodušší. Call LingeaHTMLŘeckoČeský co = "" zaco = "" Call Nahradit(co, zaco) co = "" zaco = "" Call Nahradit(co, zaco) co = "

" zaco = "

" Call Nahradit(co, zaco) co = "

" zaco = "

" Call Nahradit(co, zaco) co = ">" zaco = "" Call Nahradit(co, zaco) 'Nahrazení §§ za závorky nějak nefungovalo správně. Ale jinde se znak 'asi nevyskytuje, takže zvolíme jednodušší postup. co = "§§" zaco = "(" Call Nahradit(co, zaco) co = "§" zaco = ")" Call Nahradit(co, zaco) StatusBar = "Hotovo." End Sub Sub LingeaHTMLSpeciálníZnaky() 'Změní lingeovské kódy speciálních znaků na příslušné znaky či kódy v HTML. 'Důraz je kladen na francouzské znaky (ač se zdaleka neomezuje jen na ně); 'nezpracovány všechny kódy LL. Také velká písmena byla zpracována jen velmi výběrově. 'Postupovat budeme voláním funkce Nahradit pro každý prvek dvou paralelních polí '(v rámci úspornosti kódu a kvůli snadnosti opačného použití pole pro převod znaků 'z HTML do kódů Lingea). Pozor při přidávání prvků - je třeba se nesplést, 'segment nahrazující musí být na místě paralelním se segmentem k nahrazení '(musejí mít stejný index). 'Písmena s tečkami, pak s accentus gravis, pak s tildou a další, ligatury a nakonec 'stříšky. 'Připravíme si písmena se stříškou, která dělají problémy, protože stříšku si 'vyhrazuje Word jako zástupný znak. co = "^" zaco = "@&@12" Call Nahradit(co, zaco) 'Dělení pole na několik řádků sice editor neopravoval, ale dělalo vážné problémy: 'první a poslední prvek každého řádku se ignoroval. poleco = Array("\:a", "\:e", "\:i", "\:o", "\:u", "\:y", "\`a", "\`e", "\`i", "\`o", "\`u", "\~n", "\~a", "\~e", "\~i", "\~o", "\~u", "\~y", "\,c", "\,C", "\@a", "\@o", "\:A", "\:E", "\:I", "\:O", "\:U", "\`A", "\`E", "\`I", "\`O", "\`U", "\@&@12a", "\@&@12e", "\@&@12i", "\@&@12o", "\@&@12u", "\@&@12A", "\@&@12E", "\@&@12I", "\@&@12O", "\@&@12U") polezaco = Array("ä", "ë", "ï", "ö", "ü", "ÿ", "à", "è", "ì", "ò", "ù", "ñ", "ã", "ẽ", "ĩ", "õ", "ũ", "ỹ", "ç", "Ç", "æ", "œ", "Ä", "Ë", "Ï", "Ö", "Ü", "À", "È", "Ì", "Ò", "Ù", "â", "ê", "î", "ô", "û", "Â", "Ê", "Î", "Ô", "Û") If UBound(poleco) <> UBound(polezaco) Then MsgBox ("Pole Nahradit co a pole Nahradit za co mají různý počet prvků. Zkontrolujte kód procedury, je v něm zřejmě chyba. Makro se nyní ukončí.") Exit Sub End If For i = 0 To UBound(poleco) co = poleco(i) zaco = polezaco(i) Call NahraditCase(co, zaco) Next i 'Nahrazení těch stříšek, které byly značkami homonym. co = "@&@12" zaco = "{" 'Tento znak je potřeba, nový znak totiž musí být pro daný účel 'přijatelný i v řec. fontu Grenet. Call Nahradit(co, zaco) End Sub Sub LingeaHTMLSpeciálníZnakyDoLingea() 'Převede znaky z HTML do lingeovských kódů. poleco = Array("ä", "ë", "ï", "ö", "ü", "ÿ", "à", "è", "ì", "ò", "ù", "ñ", "ã", "ẽ", "ĩ", "õ", "ũ", "ỹ", "ç", "Ç", "æ", "œ", "Ä", "Ë", "Ï", "Ö", "Ü", "À", "È", "Ì", "Ò", "Ù", "â", "ê", "î", "ô", "û", "Â", "Ê", "Î", "Ô", "Û") polezaco = Array("\:a", "\:e", "\:i", "\:o", "\:u", "\:y", "\`a", "\`e", "\`i", "\`o", "\`u", "\~n", "\~a", "\~e", "\~i", "\~o", "\~u", "\~y", "\,c", "\,C", "\@a", "\@o", "\:A", "\:E", "\:I", "\:O", "\:U", "\`A", "\`E", "\`I", "\`O", "\`U", "\@&@12a", "\@&@12e", "\@&@12i", "\@&@12o", "\@&@12u", "\@&@12A", "\@&@12E", "\@&@12I", "\@&@12O", "\@&@12U") If UBound(poleco) <> UBound(polezaco) Then MsgBox ("Pole Nahradit co a pole Nahradit za co mají různý počet prvků. Zkontrolujte kód procedury, je v něm zřejmě chyba. Makro se nyní ukončí.") Exit Sub End If For i = 0 To UBound(poleco) co = poleco(i) zaco = polezaco(i) Call NahraditCase(co, zaco) Next i End Sub Sub LingeaHTMLrozdělit() 'Z dokumentu zpracovaného makrem LingeaHTML (či jeho modifikací pro jazyky 'užívající cizích abeced) vytvoří jednotlivé soubory .HTM pro každé heslo. 'Testování: proběhlo na výbornou; všechna hesla tam byla, nic neopomenuto. 'Kontrolováno i makrem LingeaSoupisLemmat. Set fso = CreateObject("Scripting.FileSystemObject") 'U řeckého nahradíme entryr za entry, aby se to načítalo správně. co = "" zaco = "" Call Nahradit(co, zaco) 'Pomocný segment na konci. Selection.EndKey wdStory Selection.TypeParagraph Selection.TypeText "" 'Načítání jednotlivých hesel a tvorba textových souborů. Adresar = InputBox("Zadejte cestu k cílovému adresáři", "Cílový adresář", "C:\David\Jazyky\htmlsl\p") If Adresar = vbCancel Then Exit Sub Adresar = Trim(Adresar) If Not fso.FolderExists(Adresar) Then fso.CreateFolder Adresar hlaseni = "Zadaný adresář neexistoval; byl makrem automaticky vytvořen." End If 'Výchozí nabídku pro zkusíme zjistit sami. vychozitit = "" odst1 = ActiveDocument.Paragraphs(1) prvniznacka = InStr(odst1, ">") If prvniznacka <> 0 Then practit = Mid(odst1, prvniznacka + 1) druhaznacka = InStr(practit, "<") If druhaznacka <> 0 Then vychozitit = Left(practit, druhaznacka - 1) vychozitit = Left(vychozitit, 1) & LCase(Mid(vychozitit, 2)) End If End If titulek = InputBox("Zadejte hlavní součást titulku okna prohlížeče - obvykle název slovníku", "Titulek", vychozitit) If titulek = vbCancel Then Exit Sub If Right(Adresar, 1) <> "\" Then Adresar = Adresar & "\" pripona = InputBox("Zadejte příponu názvu souboru (např. ""frcz1"" apod.)", "Přípona názvu") If pripona = vbCancel Then Exit Sub autor = InputBox("Zadejte autora slovníku", "Autor", "David Zbíral") If autor = vbCancel Then Exit Sub 'Určíme maximální počet kol pomocí nahrazení všech "#". Je to v dlouhých 'dokumentech daleko rychlejší než porovnávání řetězců. Nahradíme za distinktivní 'řetězec a ten pak nahradíme zpátky. Selection.HomeKey wdStory maxkol = 0 Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Do StatusBar = "Probíhá zjišťování počtu kol." With Selection.Find .text = "<span class=""entry"">" .Replacement.text = "@2&2@" .Forward = True .Wrap = wdFindContinue .Execute Replace:=wdReplaceOne End With maxkol = maxkol + 1 Loop While Selection.Find.Found = True co = "@2&2@" zaco = "<span class=""entry"">" Call Nahradit(co, zaco) 'Skočíme na první výskyt. Selection.HomeKey wdStory With Selection.Find .text = "<span class=""entry"">" .Forward = True .Wrap = wdFindContinue .Execute End With 'Všechny české uvozovky převedeme na anglické. 'Jinak to tropí při porovnávání řetězců neplechu. Call UvozovkyČeskéNaAnglické 'Načítání hesel; kvůli problému se znaky musíme načíst dvakrát: 'poprvé jen kvůli názvu souboru, podruhé po zavolání makra LingeaHTMLSpeciálníZnaky 'za účelem vlastního převodu. Snad se podaří, aby se jméno krylo s obsahem... 'a vytváření souborů HTML pro každé z nich. Do StatusBar = "Probíhá načítání hesel a vytváření souboru pro každé heslo." poradirovnitka = 0 'Rozšíření až k dalšímu lemmatu. With Selection.Find .text = "<span class=""entry"">" .Forward = True .Wrap = wdFindContinue .Execute End With Selection.Extend With Selection.Find .text = "<span class=""entry"">" .Forward = True .Wrap = wdFindContinue .Execute End With Selection.MoveLeft unit:=wdCharacter Selection.MoveUp unit:=wdParagraph, Count:=1 Selection.EscapeKey 'Tady byla chyba, zabíralo to i násl. křížek. Experimentálně vyřešeno takto. PocetKol = PocetKol + 1 Heslo = Selection.text levyvymezovac = "<span class=""entry"">" lheslo = InStr(Heslo, levyvymezovac) pracHeslo = Mid(Heslo, lheslo + Len(levyvymezovac)) pheslo = InStr(pracHeslo, "</span>") If pheslo = 0 Then Exit Do 'Ochrana před chybou za posledním heslem. HesloveSlovo = Left(pracHeslo, pheslo - 1) HesloveSlovo = Trim(HesloveSlovo) 'Nyní vyřešení znaků v HesloveSlovo, které se stane názvem souboru. 'Explicitně udaný index homonyma: nebudeme řešit jinak než duplicity, protože 'se už takto vyřeší výborně: or-1-frcz1.htm. 'Některé znaky HTML převedeme. htmlznaky = Array("nbsp", "#8217") For i = 0 To UBound(htmlznaky) HesloveSlovo = Replace(HesloveSlovo, "&" & htmlznaky(i) & ";", "") Next 'Ostrý přídech v řečtině a "j" (nahradíme v přepise za "s"). If Left(pripona, 3) = "rec" Then 'Navrátíme entryr do Hesla; ovšem jen u řeckého slovníku. Heslo = Replace(Heslo, "<span class=""entry"">", "<span class=""entryr"">") If Mid(HesloveSlovo, 2, 1) = "(" Then HesloveSlovo = "h" & Left(HesloveSlovo, 1) & Mid(HesloveSlovo, 3) ElseIf Mid(HesloveSlovo, 3, 1) = "(" Then HesloveSlovo = "h" & Left(HesloveSlovo, 2) & Mid(HesloveSlovo, 4) End If If Right(HesloveSlovo, 1) = "j" Then HesloveSlovo = Left(HesloveSlovo, Len(HesloveSlovo) - 1) & "s" End If 'Nyní do HesloveSlovo navrátíme lingeovské formátování, aby 'se nám snadno odstraňovala diakritika. poleco = Array("ä", "ë", "ï", "ö", "ü", "ÿ", "à", "è", "ì", "ò", "ù", "ñ", "ã", "ẽ", "ĩ", "õ", "ũ", "ỹ", "ç", "Ç", "æ", "œ", "Ä", "Ë", "Ï", "Ö", "Ü", "À", "È", "Ì", "Ò", "Ù", "â", "ê", "î", "ô", "û", "Â", "Ê", "Î", "Ô", "Û") polezaco = Array("\:a", "\:e", "\:i", "\:o", "\:u", "\:y", "\`a", "\`e", "\`i", "\`o", "\`u", "\~n", "\~a", "\~e", "\~i", "\~o", "\~u", "\~y", "\,c", "\,C", "\@a", "\@o", "\:A", "\:E", "\:I", "\:O", "\:U", "\`A", "\`E", "\`I", "\`O", "\`U", "\@&@12a", "\@&@12e", "\@&@12i", "\@&@12o", "\@&@12u", "\@&@12A", "\@&@12E", "\@&@12I", "\@&@12O", "\@&@12U") For izn = 0 To UBound(poleco) zn = poleco(izn) zn2 = polezaco(izn) If Left(zn2, 6) = "\@&@12" Then zn2 = Right(zn2, 1) HesloveSlovo = Replace(HesloveSlovo, zn, zn2) Next retezec = HesloveSlovo Call OdstraňovačNealfanumerickýchZnakůANečeskéDiakritiky(retezec) HesloveSlovo = retezec 'Ověření existence souboru; pokud už existuje, přidáme číslo. poradisoub = 1 '1; 1 je implicitní; tam, kde není nic, začneme indexy až od dvojky. neniprvni = False konecrady = False If fso.FileExists(Adresar & HesloveSlovo & "-" & pripona & ".htm") Then neniprvni = True Do 'Zjišťujeme, jak vysoký musíme dát index. poradisoub = poradisoub + 1 If Not fso.FileExists(Adresar & HesloveSlovo & poradisoub & "-" & pripona & ".htm") Then konecrady = True End If Loop Until konecrady = True End If pridavek = "" If neniprvni = True Then pridavek = "-" & poradisoub 'HesloveSlovo = HesloveSlovo & "-" & poradisoub If poradisoub = 1 Then poradisoub = "" 'Vytvoření souboru. ent = Chr(13) & Chr(10) Set soubor = fso.CreateTextFile(Adresar & HesloveSlovo & "-" & pripona & pridavek & ".htm", True) hlavicka = "<html>" & ent & "<head>" & ent & "<meta http-equiv=""content-type"" content=""text/html; charset=windows-1250"">" & ent & "<meta name=""author"" content=""" & autor & """>" & ent & "<meta name=""copyright"" content=""" & autor & """>" & ent & "<title>" & HesloveSlovo & " - " & titulek & " - © " & autor & "" & ent & "" & ent & "" & ent spodek = "

© " & autor & ", http://mujweb.cz/www/david.zbiral/jazyky.htm, david.zbiral@post.cz (lze též použít poštovní formulář na webu)
Zdarma pro soukromé nekomerční použití. Nedistribuovat.



" & ent & "" & ent & "" soubor.WriteLine hlavicka & Heslo & ent & spodek Set soubor = Nothing 'Přesouváme se na další heslo. Selection.EscapeKey Selection.MoveRight unit:=wdCharacter 'Selection.MoveRight unit:=wdCharacter Loop While PocetKol < maxkol - 1 'Takhle to vycházelo experimentálně. Ale raději 'ověřit, zda je ve slovníku vše - podle posledního a předposledního hesla. 'Když se dalo jen jako < maxkol, tak to pokaždé vytvořilo nakonec jeden soubor 'obsahující skoro celý slovník. StatusBar = "Hotovo. " & hlaseni End Sub Sub LingeaHTMLSpojit() 'Spojí hesla z jednotlivých souborů do jednoho slovníku. 'Bere v úvahu příponu názvu. 'Účelem je abecední řazení; u dlouhých slovníků je toto načítání daleko rychlejší 'než abecední řazení rozsáhlého Array. cesta = InputBox("Zadejte cestu ke zdrojovému adresáři.", "Cesta", "C:\David\Jazyky\htmlsl\") If cesta = "" Then Exit Sub soucastnazvu = InputBox("Zadejte příponu názvu těch souborů, které se nyní mají zpracovat (např. ""frcz1"").") cesta = Trim(cesta) If Right(cesta, 1) <> "\" Then cesta = cesta & "\" Documents.Add DocumentType:=wdNewBlankDocument 'Soubor, kam budeme vpisovat. Call DěleníSlovZakázat Set fso = CreateObject("Scripting.FileSystemObject") Set Adresar = fso.GetFolder(cesta) For Each f In Adresar.Files StatusBar = "Probíhá načítání obsahu souborů." If soucastnazvu = "" Or InStr(f, soucastnazvu) <> 0 Then pripona = fso.GetExtensionName(f) If pripona = "htm" Then Set txt = fso.OpenTextFile(f) obsah = txt.ReadAll zacatekhesla = InStr(obsah, " 0 Then Heslo = Mid(obsah, zacatekhesla) konechesla = InStr(Heslo, "

") Heslo = Left(Heslo, konechesla - 1) Selection.TypeText Heslo End If End If End If Next 'Zrušení nadbytečných enterů. co = "^p^p^p" zaco = "^p^p" Call Nahradit(co, zaco) Call Nahradit(co, zaco) 'Oprava. co = "" zaco = "

" Call Nahradit(co, zaco) Set Adresar = Nothing StatusBar = "Hotovo." End Sub Function NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) 'Nahrazovací funkce volaná různými procedurami, které jí předávají 'hodnoty proměnných Levy, Pravy atd. 'Užité metody: s Levy, Pravy jen Selection.Find, s NahraditCo, NahraditZaCo 'jen porovnávání řetězců. Takže do Levy, Pravy lze zadávat znaky jako ^p pro enter 'apod. Problém byl jen u řádku If (InStr(Selection.text, Levy) = 0) Or (InStr(Selection.text, Pravy) = 0) Then Exit Do 'To je ale asi nesmyslná ochrana, protože to máme pevně v rukou díky Selection.Find. 'Takže toto ověřování bylo zrušeno. Kdyby se v budoucnu kvůli tomu vyskytly problémy, 'např. nekonečný cyklus, tak tam tuto podmínku v nějaké podobě vrátit. 'Výchozí je binární porovnávání, tj. rozlišuje velikost písmen. '!!! Pozor na UVOZOVKY. V NahraditCo a NahraditZaCo je znak rovné uvozovky interpretován 'jako Chr(34), takže české Chr(8222) a Chr(8220) se nenahradí - ověřeno. 'A muselo to být správně i u vymezovačů: takže je nutno zadávat uvozovky typu „ a “, 'pokud se mají nahradit sekvence, které je obsahují. (Lze je získat přenesením do 'pozn. bloku z Wordu a pak z pozn. bloku do editoru VB). 'Viz LingeaHTMLŘeckoČeský, kde to je vyřešené. '!!! Viz též VymazavaciFunkce. Ta umí jednodušší věci udělat lépe, např. prosté 'nahrazení řetězce vymezeného určitými znaky, včetně podmínek obsahuje a neobsahuje. 'V tomto světle je např. níže uvedené opatření se zástupným "\*" často 'zbytečně složitým řešením. 'Funkce Nahradit(co, zaco) je určena k běžnému nahrazování přes Selection.find - 'žádné vymezovače nezohledňuje a jejím účelem je vlastně jen úspornost kódu procedur. 'PROBLÉM: někdy dělá problém správné přeskočení na další výskyt. Například se 'nahradí jen každý druhý výskyt. Je to tam, kde se maže samotný levý vymezovač, 'respektive obecněji když NahraditCo obsahuje řetězec totožný s Levy. Bylo to patrně 'vyřešeno. Pokud by se chyby takového rázu někde znovu objevily, je třeba hledat 'problém v části Přeskočení na další výskyt. (Pozn.: vyřešení otestováno na LingeaHTML). Dim ObsahujeHvezdicku 'Soukromý zástupný znak "\*" pro libovolný počet znaků. If Obsahuje = Empty Then Obsahuje = "" If Neobsahuje = Empty Then Neobsahuje = "" ' Application.ScreenUpdating = False Selection.HomeKey unit:=wdStory 'Přeskočíme na první výskyt. Pokud nebyl levý vymezovač nalezen, skončíme. With Selection.Find .text = Levy .Wrap = wdFindContinue .Forward = True .Execute If .Found = False Then Exit Function End With 'Rozšíříme Selection k následujícímu znaku Pravy. Selection.Extend With Selection.Find .text = Pravy .Wrap = wdFindContinue .Forward = True .Execute End With Selection.EscapeKey 'Zrušíme Extend. 'Cyklus, který bude v celém dokumentu provádět odstraňování. PocetKol = 0 PocetNahrazeni = 0 Do StatusBar = "Probíhá nahrazování " & Chr(34) & NahraditCo _ & Chr(34) & " za " & Chr(34) & NahraditZaCo & Chr(34) _ & " mezi vymezovači " & Chr(34) & Levy & Chr(34) & " a " _ & Chr(34) & Pravy & Chr(34) & "." PocetKol = PocetKol + 1 'Ochrana proti nežádoucímu pokračování: pokud řetězec neobsahuje levý a 'pravý vymezovač, vyskoč z cyklu. Poněkud nadbytečné a možná působí část 'problémů s uvozovkami, zrušeno. 'If (InStr(Selection.text, Levy) = 0) Or (InStr(Selection.text, Pravy) = 0) Then Exit Do 'Pokud označený text (neobsahuje řetězec zadaný do Neobsahuje nebo pokud 'nebyla podmínka Neobsahuje zadána) a zároveň pokud (nebyl zadán znak, 'který řetězec musí nutně obsahovat, aby k nahrazení došlo, nebo pokud 'sice zadán byl, ale Selection.text ho neobsahuje), tak provedeme nahrazení. If ((InStr(1, Selection.text, "" & Neobsahuje & "") = 0) Or (Neobsahuje = "")) And ((Obsahuje = "") Or (InStr(1, Selection.text, "" & Obsahuje & "") <> 0)) Then 'Nejprve podmínka, do které se skočí, pokud byl zadán zástupný znak 'hvězdičky; zadávám speciálním kódem \*. ObsahujeHvezdicku = InStr(NahraditCo, "\*") If ObsahujeHvezdicku <> 0 Then levacast = Left(NahraditCo, ObsahujeHvezdicku - 1) pravacast = Right(NahraditCo, Len(NahraditCo) - Len(levacast) - 2) obsahujelevoucast = InStr(Selection.text, levacast) If obsahujelevoucast <> 0 Then zalevoucastivtextu = Mid(Selection.text, obsahujelevoucast + Len(levacast)) obsahujepravoucast = InStr(zalevoucastivtextu, pravacast) zapravoucasti = Mid(zalevoucastivtextu, obsahujepravoucast + Len(pravacast)) End If If obsahujepravoucast <> Empty And obsahujepravoucast <> 0 Then zastoupenytext = Left(zalevoucastivtextu, obsahujepravoucast - 1) 'napravoodzastoupenehotextu = Mid(zalevoucastivtextu, Len(zastoupenytext)) kNahrazeni = levacast & zastoupenytext & pravacast obsahujehv = InStr(Selection.text, kNahrazeni) End If If obsahujehv <> 0 And obsahujehv <> Empty Then Selection.text = Left(Selection.text, obsahujehv - 1) & NahraditZaCo & zapravoucasti PocetNahrazeni = PocetNahrazeni + 1 End If Else 'Běžné nahrazení (v případě, že hvězdičku neobsahuje). Poradi = InStr(1, Selection.text, NahraditCo) If Poradi <> 0 Then Selection.text = Left(Selection.text, Poradi - 1) & NahraditZaCo & Right(Selection.text, Len(Selection.text) - Poradi + 1 - Len(NahraditCo)) 'Soupis = Soupis & Selection.text & vbLf PocetNahrazeni = PocetNahrazeni + 1 'Dalo by se přidat i Else, kdyby se dobře promyslelo. End If End If End If 'Přeskočení na další výskyt. 'Dalo by se řešit i jinak - nepracovat v dokumentu, 'nýbrž s řetězcem, do kterého by se nejdřív načetl celý dokument a poté by se 'pomocí cyklu s InStr zjišťovalo, jestli tam ještě tato značka je. 'Ale to je daleko pomalejší, v dlouhých dokumentech neúnosně. With Selection.Find .text = Levy .Forward = True 'Tam, kde NahraditCo obsahuje Levy, je třeba skočit dvakrát, protože poprvé 'se najde ještě jednou Levy, který už byl zpracován. 'Dělá to problémy tam, kde je obsažen dokonce víckrát; asi nejde o 'nekonečný cyklus, ale hrozně to průběh prodlouží, zvlášť v dlouhých 'dokumentech. Řádky EscapeKey a MoveRight podmínky dodány nově právě 've snaze to řešit, ale bez úspěchu. If InStr(Selection.text, Levy) <> 0 Then .Wrap = wdFindContinue .Execute 'Selection.EscapeKey 'Selection.MoveRight unit:=wdCharacter, Count:=1 Else 'Pokud je NahraditCo obsaženo v Levy, zrušíme selection jinak - pohybem. 'wdFindContinue by totiž působilo potíže - nefungovala by ochrana 'proti nekonečnému cyklu. Selection.EscapeKey Selection.MoveRight unit:=wdCharacter, Count:=3 End If .Wrap = wdFindStop .Execute If .Found = False Then Exit Do 'Ochrana proti nekonečnému cyklu End With Selection.Extend With Selection.Find .text = Pravy .Wrap = wdFindStop .Forward = True .Execute End With If Selection.Find.Found = False Then Exit Do 'Ochrana proti nekonečnému cyklu Selection.EscapeKey 'Ochrana proti nekonečnému cyklu. // Vyřazeno kvůli zrychlení. 'Počítání MaxKol nefungovalo vždy správně, tak přidáme nějaká kola navíc. 'Je to poněkud těžkopádné, ale nic by to nemělo zkazit. // Vyřazeno kvůli zrychlení. 'If PocetKol > maxkol Then Exit Do Loop Until Selection.Find.Found = False Selection.HomeKey unit:=wdStory Application.ScreenUpdating = True 'Pokud nebylo žádné nahrazení provedeno, oznámíme to uživateli a skončíme. If PocetNahrazeni = 0 Then 'MsgBox "Nebylo provedeno žádné nahrazení. Makro se nyní ukončí." 'Exit Function End If StatusBar = "" Application.ScreenUpdating = True End Function Function Nahradit(co, zaco) 'Jednoduchá nahrazovací funkce přes Selection.Find, které mohou různé procedury 'předávat hodnoty proměnných co a zaco. 'Pozor na nastavení různých parametrů, je tu dáno pevně! Může to vést k neobjevení 'chyby ve volající proceduře (člověk si např. neuvědomí, že je v této fci nastaveno 'MatchCase = False). Selection.HomeKey unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = co .Replacement.text = zaco .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll End With End Function Function NahraditCase(co, zaco) 'Modifikace funkce Nahradit(co, zaco) s MatchCase = true Selection.HomeKey unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = co .Replacement.text = zaco .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll .MatchCase = False End With End Function Function NahraditWildCards(co, zaco) 'Modifikace funkce Nahradit(co, zaco) s MatchWildCards = True. Selection.HomeKey unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .text = co .Replacement.text = zaco .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = True .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll .MatchCase = False .MatchWildcards = False End With End Function Sub OdstraňovačDiakritikyANealfanumerickýchZnakůproc() 'Odstraní diakritiku z označeného textu a převede všechna písmena na malá. 'Mezery nahradí za spojovníky a ostatní nealfanumerické znaky vymaže. 'Určeno zejm. na úpravu řetězců, které se mají stát názvy souborů. retezec = Selection.text Call OdstraňovačDiakritikyANealfanumerickýchZnaků(retezec) Selection.TypeText retezec End Sub Sub OdstraňovačNealfanumerickýchZnakůANečeskéDiakritikyproc() 'Odstraní nečeskou diakritiku z označeného textu a převede všechna písmena na malá. 'Mezery nahradí za spojovníky a ostatní nealfanumerické znaky vymaže. 'Určeno zejm. na úpravu řetězců, které se mají stát názvy souborů. retezec = Selection.text Call OdstraňovačNealfanumerickýchZnakůANečeskéDiakritiky(retezec) Selection.TypeText retezec End Sub Function OdstraňovačDiakritikyANealfanumerickýchZnaků(retezec) 'Přetvoří vstupní řetězec na podobu bez diakritiky. Nealfanumerické znaky vymaže, 'jen spojovníky a podtržítka nechá. Mezery převede na spojovníky. Určeno zejm. 'k úpravě názvů souborů. Postupuje porovnáváním jednotlivých písmen; nevhodné 'pro dlouhé řetězce. Vyřezává jen českou diakritiku a výjimečně 'nějakou další; jiná nezpracována. 'Funkčnost ověřena. Do řetězců jednotlivých písmen lze přidat i další znaky. Dim a, c As String a = "áäâă" & ChrW(224) & ChrW(227) c = "čç" d = "ď" e = "éëěę" & ChrW(232) & ChrW(7869) & ChrW(234) i = "íî" & ChrW(239) & ChrW(236) & ChrW(297) l = "ľł" n = "ň" & ChrW(241) o = "óöô" & ChrW(242) & ChrW(245) r = "ř" s = "š" t = "ť" u = "úüů" & ChrW(249) & ChrW(361) & ChrW(251) y = "ý" & ChrW(255) & ChrW(7929) z = "ž" retezec = LCase(retezec) 'Všechno bude malým písmem. Ušetří nám to vypisování. povolene = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890_-" For poradcislo = 1 To Len(retezec) zn = Mid(retezec, poradcislo, 1) If InStr(1, povolene, zn, 1) = 0 Then 'Nastavíme TextCompare - argument 1. If zn = " " Then zn = "-" ElseIf zn = ChrW(230) Then zn = "ae" ElseIf zn = ChrW(339) Then zn = "oe" ElseIf InStr(a, zn) <> 0 Then zn = "a" ElseIf InStr(c, zn) <> 0 Then zn = "c" ElseIf InStr(d, zn) <> 0 Then zn = "d" ElseIf InStr(e, zn) <> 0 Then zn = "e" ElseIf InStr(i, zn) <> 0 Then zn = "i" ElseIf InStr(l, zn) <> 0 Then zn = "l" ElseIf InStr(n, zn) <> 0 Then zn = "n" ElseIf InStr(o, zn) <> 0 Then zn = "o" ElseIf InStr(r, zn) <> 0 Then zn = "r" ElseIf InStr(s, zn) <> 0 Then zn = "s" ElseIf InStr(t, zn) <> 0 Then zn = "t" ElseIf InStr(u, zn) <> 0 Then zn = "u" ElseIf InStr(y, zn) <> 0 Then zn = "y" ElseIf InStr(z, zn) <> 0 Then zn = "z" Else zn = "" End If End If novyretezec = novyretezec & zn Next retezec = novyretezec End Function Function OdstraňovačNealfanumerickýchZnakůANečeskéDiakritiky(retezec) 'Odstraní všechny nealfanumerické znaky a zruší diakritiku několika znaků. 'Běžnou českou diakritiku nechá na pokoji. Změna je jen v naplnění proměnných na začátku. 'Ale jejich osamostatnění v rámci úspornosti do zvl. fce by nutilo předávat si je 'všechny, což by moc kódu tím pádem neušetřilo. Dim a, c As String a = "äâă" & ChrW(224) & ChrW(227) c = "ç" d = "" e = "ëę" & ChrW(232) & ChrW(7869) & ChrW(234) i = "î" & ChrW(239) & ChrW(236) & ChrW(297) l = "ľł" n = "" & ChrW(241) o = "öô" & ChrW(242) & ChrW(245) r = "" s = "" t = "" u = "ü" & ChrW(249) & ChrW(361) & ChrW(251) y = "" & ChrW(255) & ChrW(7929) z = "" povolene = "abcdefghijklmnopqrstuvwxyz1234567890_-áčďéěíňóřšťúůýž" retezec = LCase(retezec) 'Všechno bude malým písmem. For poradcislo = 1 To Len(retezec) zn = Mid(retezec, poradcislo, 1) If InStr(1, povolene, zn, 1) = 0 Then 'Nastavíme TextCompare - argument 1. If zn = " " Then zn = "-" ElseIf InStr(a, zn) <> 0 Then zn = "a" ElseIf InStr(c, zn) <> 0 Then zn = "c" ElseIf InStr(d, zn) <> 0 Then zn = "d" ElseIf InStr(e, zn) <> 0 Then zn = "e" ElseIf InStr(i, zn) <> 0 Then zn = "i" ElseIf InStr(l, zn) <> 0 Then zn = "l" ElseIf InStr(n, zn) <> 0 Then zn = "n" ElseIf InStr(o, zn) <> 0 Then zn = "o" ElseIf InStr(r, zn) <> 0 Then zn = "r" ElseIf InStr(s, zn) <> 0 Then zn = "s" ElseIf InStr(t, zn) <> 0 Then zn = "t" ElseIf InStr(u, zn) <> 0 Then zn = "u" ElseIf InStr(y, zn) <> 0 Then zn = "y" ElseIf InStr(z, zn) <> 0 Then zn = "z" Else zn = "" End If End If novyretezec = novyretezec & zn Next retezec = novyretezec End Function Sub TvrdeMezeryHTMLPredPredlozky() 'Vloží před "v", "s" a "z" HTML kód pevných mezer. Druhý prvek pole 'je určen k nahrazování i tam, kde předložka následuje hned za nějakou značkou. pridavky = Array(" ", ">", "^p", "(", """") For i = 0 To UBound(pridavky) prid = pridavky(i) co = prid & "s " zaco = prid & "s " Call Nahradit(co, zaco) co = prid & "v " zaco = prid & "v " Call Nahradit(co, zaco) co = prid & "z " zaco = prid & "z " Call Nahradit(co, zaco) Next End Sub Sub LingeaHTMLVýznamyOčíslovat() 'Provede místní očíslování významů v celém aktivním dokumentu. 'Vyřešený problém: při ladění neustále docházelo k chybám v číslování; 'příčina objevena: nadřazené makro již předtím provádělo úpravy za ’, 'které obsahuje křížek! Application.ScreenUpdating = True If ActiveDocument.Characters.Last <> "#" Then Selection.EndKey unit:=wdStory Selection.TypeText text:="#" End If Selection.HomeKey wdStory 'Určíme maximální počet kol pomocí nahrazení všech "#". Je to v dlouhých 'dokumentech daleko rychlejší než porovnávání řetězců. Nahradíme za distinktivní 'řetězec a ten pak nahradíme zpátky. maxkol = 0 Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Do StatusBar = "Probíhá zjišťování počtu kol." With Selection.Find .text = "#" .Replacement.text = "@2&2@" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceOne End With maxkol = maxkol + 1 Loop While Selection.Find.Found = True co = "@2&2@" zaco = "#" Call Nahradit(co, zaco) Selection.HomeKey wdStory With Selection.Find .text = "#" .Forward = True .Wrap = wdFindContinue .Execute End With 'Načítání hesel, jejich změna po jednom a opětovné napsání. Do StatusBar = "Probíhá načítání hesel a číslování heslových oddílů." poradirovnitka = 0 'Rozšíření až k dalšímu lemmatu. With Selection.Find .text = "#" .Forward = True .Wrap = wdFindContinue .Execute End With Selection.Extend With Selection.Find .text = "#" .Forward = True .Wrap = wdFindContinue .Execute End With Selection.MoveLeft unit:=wdCharacter Selection.MoveUp unit:=wdParagraph, Count:=1 Selection.EscapeKey 'Tady byla chyba, zabíralo to i násl. křížek. Experimentálně vyřešeno takto. PocetKol = PocetKol + 1 Heslo = Selection.text hesloprac = Heslo delkahesla = Len(Heslo) poradirovnitka = 0 rovnitko = InStr(Heslo, Chr(13) & "=") If rovnitko <> 0 Then Do poradirovnitka = poradirovnitka + 1 noveheslo = Left(hesloprac, rovnitko) & "@43@43@ class=""num"">" & poradirovnitka & "@34@34@" & Right(hesloprac, delkahesla - rovnitko - 1) hesloprac = noveheslo delkahesla = Len(hesloprac) rovnitko = InStr(hesloprac, Chr(13) & "=") Loop Until rovnitko = 0 soupisretezcu = soupisretezcu & Heslo Selection.text = noveheslo 'Selection.TypeText noveheslo vede k vymazání všeho. Else Selection.text = Heslo End If Selection.EscapeKey Selection.MoveRight unit:=wdCharacter Selection.MoveRight unit:=wdCharacter Loop While PocetKol < maxkol 'Závěrečné nahrazení pomocných znaků za "" 'proběhnou v nadřazených makrech až nakonec. 'Smazání pomocného znaku # na konci, který jsme vložili. Selection.EndKey wdStory Selection.TypeBackspace StatusBar = "Hotovo." End Sub Sub LingeaHTMLFonetickáAbeceda() 'Převede z fonetické abecedy lingeovského formátování zčásti do IPA, zčásti do 'náhradních znaků podporovaných MSIE. Zpracovává jen některé znaky se zvláštním 'důrazem na francouzské fonémy. Levy = " UBound(fonethtml) Then MsgBox ("Pole mají různý počet prvků. Zkontrolujte kód procedury, je v něm zřejmě chyba. Makro se nyní ukončí.") Exit Sub End If For i = 0 To UBound(fonetll) NahraditCo = fonetll(i) NahraditZaCo = fonethtml(i) Call NahrazovaciFunkce(Levy, Pravy, NahraditCo, NahraditZaCo, Obsahuje, Neobsahuje) Next End Sub Sub LingeaHTMLZpátky() 'Převede z HTML do Lingey. Není určeno ke kompletnímu převodu, nýbrž k napravení 'nechtěného spuštění makra v dokumentu, který nebyl lingeovskou databází, 'ale obsahoval některé lingeovské značky. zavorky = "bdfmnsuz" zavorkyhranate = "h" svorky = "y" vlnovka = "j" znacky = Array("0", "1", "b", "d", "f", "g", "h", "i", "k", "l", "m", "n", "o", "s", "t", "u", "v", "x", "y", "z", "p", "q", "w", "j", "a", "e", "c") For i = 0 To UBound(znacky) zn = znacky(i) pridavek = "" If InStr(zavorky, zn) <> 0 Then pridavek = "()" If InStr(zavorkyhranate, zn) <> 0 Then pridavek = "[]" If InStr(svorky, zn) <> 0 Then pridavek = "{}" If InStr(vlnovka, zn) <> 0 Then pridavek = "~" With Selection.Find .text = "" & Left(pridavek, 1) .Replacement.text = "<" & zn & "." .Wrap = wdFindContinue .Execute Replace:=wdReplaceAll End With Next i co = "" zaco = ">" Call Nahradit(co, zaco) End Sub