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

Někdy je potřeba v počítači zvětšit diskový oddíl. Pomocí NIUBI Partition Editoru to jde velice snadno. Tento program dokáže zvětšit i diskový oddíl nacházející se mezi dvěma jinými oddíly – před tím ovšem musíte jeden ze zmíněných sousedních oddílů zmenšit. To vše beze ztráty dat, nebo nutnosti data přenést na jiný disk. Vyzkoušel jsem při řešení chyby aktualizace Windows, kdy bylo potřeba před touto aktualizací zvětšit systémem rezervovaný odddíl nacházející se na úplném začátku pevného disku. Nicméně pro jistotu doporučuji si vždy důležitá data z disku, s kterým budete pracovat, zálohovat. NIUBI Partition Editor je pro domácí použití free. Lze ho stáhnout z těchto stránek.

E-knihy jsou super!

Ostatní

Makro na zpracování textu v aplikaci Word

Jak ze systému Windows odinstalovat, co normálně odinstalovat nejde

Nejlepší partition manager