Ostatní

Níže uvedené makro spuštěné v aplikaci Word odstraní v otevřeném dokumentu nadbytečné pevné mezery a vloží je tam, kde jsou potřeba, tedy na konci řádku za k, o, s, v, w, u, z. Uvažuji i o „w“ kvůli zpracování polského textu. Podobná makra jsou k dispozici na různých webových stránkách, ale žádné z nich nezpracovává poznámky pod čarou. Uvedené makro opraví i text např. „v O Ječmínkovi“, nahradí více mezer za sebou mezerou jednou tak, aby mezi jednotlivými slovy byla vždy jen jedna mezera, na začátku a na konci odstavce odstraní všechny zbytečné prázdné znaky (mezery, tabelátory apod.), odstraní znak ¬.
Použití a šíření makra je zdarma s podmínkou ponechání všech komentářů..
Verze 1.04 - přidáno odstranění znaku ¬, prázdných znaků na začátku odstavce, zjednodušení kódu makra.
Verze 1.03 - přidáno odstranění prázdných znaků před koncem odstavce.
Verze 1.02 - zjednodušení funkce nahrazení více mezer mezerou jednou.
Verze 1.01 - přidáno nahrazení více mezer mezerou jednou tak, aby mezi slovy byla vždy jen jedna mezera.

Sub VlozeniPevneMezeryNaKonciRadkuZaKOSVWUZ()
    'Verze makra 1.04 - 18.11.2022 přidáno odstranění znaku ¬ (volitelné dělící znaménko), odstranění mezer na začátku odstavce, zpřehlednění a zjednodušení kódu makra
    'Verze makra 1.03 - 15.9.2022 přidáno odstranění prázdných znaků před koncem odstavce
    'Verze makra 1.02 - 25.8.2022 zjednodušení funkce nahrazení více mezer mezerou jednou tak, aby mezi slovy byla vždy jen jedna mezera
    'Verze makra 1.01 - 24.8.2022 přidáno nahrazení více mezer mezerou jednou tak, aby mezi slovy byla vždy jen jedna mezera
    'Makro v dokumentu odstraní nadbytečné pevné mezery a vloží je tam, kde jsou potřeba: na konci řádku za k,o,s,v,w,u,z. Uvažuji i o "w" kvůli případnému zpracování polského textu.
    '422 stránek je zpracováno za 14 minut.
    'V průběhu běhu makra lze počítač používat s výjimkou aplikace Word.
    'Použití a šíření makra je zdarma s podmínkou ponechání všech komentářů.
    'Autor michal.beran@cmail.cz, zdroj https://pbn.proweb.cz/ostatni.
    'V případě, že se Vám podaří makro vylepšit, zrychlit, pošlete, prosím, e-mail. Děkuji.

Main

End Sub

Function Main()

Dim Odpoved As Integer

Application.ScreenUpdating = False

Odpoved = MsgBox("Chcete doplnit pevné mezery za neslabičné předložky?", vbYesNo)

StartTime = DateTime.Time
                                             'všechna níže uvedená nahrazení proběhnou v řádcích i v poznámkách pod čarou

NahradZnakyVsude Chr(31), ""     'vymaže znak ¬ (volitelné dělící znaménko)

NahradZnakyVsude "^l", "^p"      'ručně vložený konec řádku (Shift+Enter) nahradí koncem odstavce (Enter)

NahradZnakyVsude Chr$(160), " "  'pevnou mezeru (Ctrl+Shift+Space) nahradí mezerou (Space)

NahradZnakyVsude "^w", " "       'více mezer (prázdných znaků) za sebou nahradí mezerou jedinou

NahradZnakyVsude " ^p", "^p"     'vymaže mezeru před koncem odstavce

If Odpoved = vbYes Then

LzeUkladat 'otestuje zda lze bez problémů použít ActiveDocument.Save

Do  'Je potřeba, aby makro prošlo dokument vícekrát kvůli možnému výskytu textu např.: v O Ječmínkovi
                    ActiveDocument.Save
                    NahradNormPevnou
                Loop Until ActiveDocument.Saved

Else

VymazMezeruNaZacatku

End If

Application.ScreenUpdating = True

MsgBox "Čas zpracování dokumentu: " & Format(DateTime.Time - StartTime, "HH:mm:ss")

End Function

Function VymazMezeruNaZacatku()

Dim Radek As Range
    Dim Slovo As Range

For Each Radek In ActiveDocument.StoryRanges

For Each Slovo In Radek.Words

If Slovo = " " Then
                Slovo.Text = ""
            End If

Next Slovo

Next Radek

End Function

Function NahradZnakyVsude(Find As String, Replace As String)

Dim Doc As Document
    Set Doc = ActiveDocument

Dim ActRange As Range

If Doc.Footnotes.Count > 0 Then              'zpracuje poznámky pod čarou
        Set ActRange = Doc.Footnotes(1).Range
        ActRange.WholeStory
        ActRange.Select

NahradZnaky Find, Replace

End If

Set ActRange = Doc.Range                     'zpracuje řádky
    ActRange.WholeStory
    ActRange.Select

NahradZnaky Find, Replace

End Function

Function NahradZnaky(Find As String, Replace As String)

Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

With Selection.Find
        .Text = Find
        .Replacement.Text = Replace
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With

Selection.Find.Execute Replace:=wdReplaceAll

Selection.Collapse

End Function

Function LzeUkladat() 'otestuje zda lze bez problémů použít ActiveDocument.Save

TestExistuje 'otestuje, zda se nejedná o nový dokument, který ještě nebyl uložen pod konkrétním jménem

TestReadOnly

End Function

Function TestExistuje() 'otestuje, zda se nejedná o nový dokument, který ještě nebyl uložen pod konkrétním jménem

If Not Mid(ActiveDocument.FullName, 2, 1) = ":" Then

MsgBox "Uložte dokument pod konkrétním jménem!" 'dokument není vhodné ukládat příkazem ActiveDocument.Save protože uživatel může dialog ukládání přerušit bez uložení a pak dochází k chybám

End 'ukončí celé makro

End If

End Function

Function TestReadOnly()

If ActiveDocument.ReadOnly Then

JmenoSouboru = ActiveDocument.FullName

NoveJmenoSouboru = StrReverse(Replace(StrReverse(JmenoSouboru), ".", StrReverse(" (Jen pro čtení)."), 1, 1)) 'aby se nahradila jen poslední tečka

If Not "" = Dir(NoveJmenoSouboru, vbDirectory) Then

MsgBox "Protože existuje soubor či adresář " & NoveJmenoSouboru & " nelze pod tímto jménem uložit zpracovávaný dokument! Makro ukončeno."

End

End If

ActiveDocument.SaveAs FileName:=NoveJmenoSouboru

SetAttr NoveJmenoSouboru, vbReadOnly + vbArchive

MsgBox "Soubor " & JmenoSouboru & " je označen atributem Jen pro čtení. Jeho kopie před spuštěním tohoto makra se uložila jako: " & NoveJmenoSouboru & "!"

SetAttr JmenoSouboru, vbNormal + vbArchive

ActiveDocument.Close

Documents.Open FileName:=JmenoSouboru

End If

End Function

Function NahradNormPevnou()

Dim AscK, AscO, AscS, AscV, AscW, AscU, AscZ As Integer

AscK = Asc("K")
    AscO = Asc("O")
    AscS = Asc("S")
    AscV = Asc("V")
    AscW = Asc("W")
    AscU = Asc("U")
    AscZ = Asc("Z")
    AscSpace = Asc(" ")

Dim currCol As Integer
    Dim prevCol As Integer

Dim Lines As Range

Dim currWord As Range
    Dim prevWord As Range

Set prevWord = ActiveDocument.Range.Words.First

Dim prevWordChars As Characters

For Each Lines In ActiveDocument.StoryRanges

prevCol = 1

For Each currWord In Lines.Words

If currWord = " " Then
                currWord.Text = ""
            End If

currCol = currWord.Information(wdFirstCharacterColumnNumber)

If currCol < prevCol Then

Set prevWordChars = prevWord.Characters

If (prevWordChars.Count = 2) Then

Set currWordChars = currWord.Characters

If (Asc(prevWordChars.Last) = AscSpace) Then

Select Case (Asc(UCase(prevWordChars.First.Text)))
                        Case AscK, AscO, AscS, AscV, AscW, AscU, AscZ
                            prevWordChars.Last.Text = Chr$(160)

End Select

End If

Set prevWord = currWord
            prevCol = currCol

Next currWord

Next Lines

End Function

E-knihy jsou super!

Ostatní

Makro na zpracování textu v aplikaci Word