Attribute VB_Name = "Module1" Sub Kapitaliki() ' ' SmallCaps Makro ' Makro zapisane 99-05-25 przez Piotr Bieńkowski ' Selection.Font.SmallCaps = True Selection.EndKey Unit:=wdLine Selection.Font.SmallCaps = False End Sub ' Opis Zaznaczonemu fragmentowi tekstu nadaje atrybut Kapitaliki. ' Uruchamianie Skrót klawiszowy lub przycisk na pasku. '---------------------------------------------------------- '2. Pogrubienie akapitu '---------------------------------------------------------- Sub BoldPara() ' Makro zapisane 99-05-25 przez Piotr Bieńkowski Selection.Paragraphs(1).Range.Select Selection.Font.Bold = True Selection.EndKey Unit:=wdLine Selection.Font.Bold = False End Sub ' Opis zaznacza akapit i nadaje mu atrybut Pogrubiebie. ' Uruchamianie Ja wolę skrót klawiszowy, ale może być również przycisk. '---------------------------------------------------------- ' 3. Pogrubienie i podkreślenie akapitu '---------------------------------------------------------- Sub BoldUndPara() ' Makro zapisane 99-05-25 przez Piotr Bieńkowski Selection.Paragraphs(1).Range.Select Selection.Font.Bold = True Selection.Font.Underline = True Selection.EndKey Unit:=wdLine Selection.Font.Bold = False Selection.Font.Underline = False End Sub ' Opis zaznacza akapit i nadaje mu atrybut Pogrubiebie i Podkreślenie. ' ' Uruchamianie Ja wolę skrót klawiszowy, ale może być również przycisk. '---------------------------------------------------------- ' 4. Wyzerowanie atrybutów tekstu '---------------------------------------------------------- Sub BIUFalse() ' ' ' Makro zapisane 99-09-06 przez Piotr Bieńkowski ' Selection.Font.Bold = False Selection.Font.Underline = False Selection.Font.Italic = False Selection.Font.SmallCaps = False End Sub ' Opis Bywa że jakiemuś kawałkowi tekstu nadajemy różne formatowania, a potem nie ' możemy się ich pozbyć. Ustaw kursor za zmodyfikowanym fragmentem i uruchom makro. To ' makro 'ucina' Pogrubienie, Podkreślenie, Kursywę i Kapitaliki. Łatwo można je ' zmodyfikować, aby ucinało więcej atrybutów. ' ' Uruchamianie Ja wolę skrót klawiszowy, ale może być i przycisk na pasku. ' ' ' '---------------------------------------------------------- ' 5. Ułamki i cale '---------------------------------------------------------- Sub InchFrac() ' ' InchFrac Makro ' Makro zapisane 99-09-14 przez Piotr Bienkowski ' Selection.MoveLeft Unit:=wdCharacter, Count:=3 Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Font.Superscript = wdToggle Selection.MoveRight Unit:=wdCharacter, Count:=2 Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend Selection.Font.Subscript = wdToggle Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.Font.Subscript = wdToggle Selection.TypeText Text:="""" End Sub ' Opis Chcesz, żeby ułamki wyglądały na ułamki? Word tylko ' niektóre zamienia na typograficzne. Jak zrobić aby 5/8 ' miało '5' u góry a '8' u dołu? Użyj tego makra. Napisz np ' 5/8 i uruchom makro. Makro to dopisuje również znak " na ' oznaczenie cali, bo stosuję je do ułamków cali. Jeżeli ' tego nie chcesz, usuń ostatnią linię przed 'End Sub'. ' ' Uruchamianie Ja wolę skrót klawiszowy, ale może być i ' przycisk na pasku. '---------------------------------------------------------- ' 6. Prosty apostrof '---------------------------------------------------------- Sub StraitQuot() ' ' StraitQuot Makro ' Makro zapisane 99-09-14 przez Piotr Bienkowski ' Selection.InsertSymbol CharacterNumber:=34, Unicode:=True End Sub ' Opis Czasami zachodzi potrzeba wstawienia prostego ' cudzysłowu, a nie typograficznego. Z nieznanych mi ' przyczyn, Word podmienia prosty cudzysłów na ' typograficzny, jeśli wstawia się go przez 'Wstaw - ' Symbol'. Nie robi tego, jeśli się użyje tego makra. ' ' Uruchamianie Proponuję przycisk na pasku. ' ' ' '---------------------------------------------------------- ' 7. Następne Okno --- Poprzednie Okno '---------------------------------------------------------- Sub NastOkno() Application.Run MacroName:="NextWindow" End Sub Sub PoprzOkno() Application.Run MacroName:="PrevWindow" End Sub ' Opis Nie wiem czy się zgodzisz, ale jeśli pracujesz z ' wieloma dokumentami Worda jednocześnie (tzn. masz wiele ' otwartych dokumentów) to przełączanie się między nimi ' przez Menu 'Okno' nie należy do najefektywniejszych ' czynności. Dwa powyższe makra służą do przełączania się do ' następnego lub poprzedniego okna. ' ' Jak się okazało, istnieje skrót klawiszowy Ctrl-F6, który ' robi dokładnie to samo Ale może komuś bardziej podoba się ' przełączanie przez klikanie. ' ' Uruchamianie Najlepiej przypisać do paska przycisków a ' przyciskom nadać ikonki ze strzałkami w lewo i w prawo. ' (Word ma takie gotowe). '---------------------------------------------------------- ' 8. Zaznaczanie akapitu '---------------------------------------------------------- Sub SelPara() ' ' SelPara Makro ' Makro zapisane 99-04-21 przez Piotr Bieńkowski ' original idea by Paweł Lutze With Selection .StartOf Unit:=wdParagraph, Extend:=wdMove .MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend End With End Sub ' Opis: Jezeli zamiast klikać dwukrotnie w akapit wolisz ' skrót klawiszowy, to makro jest dla ciebie. Makro to można ' również wykorzystać w innych makrach, które mogą odwoływać ' się do niego gdy zachodzi potrzeba zaznaczenia aktualnego ' akapitu. ' ' Uruchamianie Możesz je podpiąć pod skrót klawiszowy lub ' przycisk na pasku przycisków (wtedy zyskujesz jedno ' kliknięcie zamiast dwóch). ' ' ' ' ' '---------------------------------------------------------- ' 9. Tabelka bez ramek '---------------------------------------------------------- Sub TableBorderNone() ' ' TableBorderNone Makro ' Makro zapisane 99-05-13 przez Piotr Bieńkowski ' With Selection.Tables(1) .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone .Borders(wdBorderTop).LineStyle = wdLineStyleNone .Borders(wdBorderBottom).LineStyle = wdLineStyleNone .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone .Borders(wdBorderVertical).LineStyle = wdLineStyleNone .Borders.Shadow = False End With With Options .DefaultBorderLineStyle = wdLineStyleSingle .DefaultBorderLineWidth = wdLineWidth050pt .DefaultBorderColorIndex = wdAuto End With End Sub ' Opis Za jednym kliknięciem pozbaw tabelę wszystkich widocznych linii. ' ' Uruchamianie Proponuję umieścić przycisk na pasku Tabele i narzędzia. ' ' ' '---------------------------------------------------------- ' 10. Pionowy podział komórki na dwie '---------------------------------------------------------- Sub SplitCellin2() ' ' SplitCellin2 Makro ' Makro zapisane 99-08-10 przez Piotr Bieńkowski ' Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=False End Sub ' Opis Bieżącą komórkę tabeli dzieli pionowo na dwie. ' ' Uruchamianie Proponuję przycisk na pasku "Tabele i krawędzie". ' ' '---------------------------------------------------------- ' 11. Podział komórki poziomo na dwie '---------------------------------------------------------- Sub SplitCellHorizontally() ' ' SplitCellHorizontally Makro ' Makro zapisane 99-08-13 przez Piotr Bieńkowski ' Selection.Cells.Split NumRows:=2, NumColumns:=1, MergeBeforeSplit:=False End Sub ' Opis Bieżącą komórkę tabeli dzieli poziomo na dwie. ' ' Uruchamianie Proponuję przycisk na pasku "Tabele i krawędzie". ' ' ' ' [ Na górę ] '---------------------------------------------------------- ' 12. Numerowanie komórek tabeli z użyciem pola Seq '---------------------------------------------------------- Sub Sequitur() ' ' Sequitur Makro ' Makro zapisane 99-09-06 przez Piotr Bieńkowski ' MsgBox ("Opis Numerowanie pionowo kolejnych komórek tabeli na ' przykład w kolumnie L.p.. Należy ręcznie wstawić ' pierwsze pole typu 'Seq' w komórce rozpoczynającej ' numerację. Aby wstawić kolejny numer, należy ustawić ' kursor w następnej komórce poniżej i uruchomić makro. ' Makro kopiuje pole, uaktualnia je, a następnie przesuwa ' kursor o jedną komórkę w prawo, gdzie możemy umieścić ' treść danego punktu itd." & vbCrLf & "BEZ POLA DZIAŁANIE MAKRA ZAKOŃCZY SIĘ BŁĘDEM!!!") Selection.PreviousField.Select Selection.Copy Selection.MoveDown Unit:=wdLine, Count:=1 Selection.Paste Selection.PreviousField.Select Selection.Fields.Update Selection.MoveRight Unit:=wdCell End Sub ' Opis Numerowanie pionowo kolejnych komórek tabeli na ' przykład w kolumnie "L.p.". Należy ręcznie wstawić ' pierwsze pole typu 'Seq' w komórce rozpoczynającej ' numerację. Aby wstawić kolejny numer, należy ustawić ' kursor w następnej komórce poniżej i uruchomić makro. ' Makro kopiuje pole, uaktualnia je, a następnie przesuwa ' kursor o jedną komórkę w prawo, gdzie możemy umieścić ' treść danego punktu itd. ' ' Uruchamianie: Proponuję przycisk na pasku "Tabele i ' krawędzie". ' ' ' ' ' '---------------------------------------------------------- ' 13. Numerowanie komórek tabeli zwykłym tekstem '---------------------------------------------------------- Sub NumerowanieKolumn() ' Makro zapisane 24-11-1999 przez Piotr Bienkowski numer = 1 While Selection.Information(wdWithInTable) = True Selection.InsertAfter numer numer = numer + 1 Selection.MoveDown Unit:=wdLine, Count:=1 Wend End Sub ' Opis: Makro numeruje wiersze tabeli od komórki, w której stoi kursor ' do ostatniej komórki w danej kolumnie. Najlepiej uruchamiać na "świeżo utworzonej" tabeli. ' ' Uruchamianie: Przycisk na pasku lub skrót klawiszowy. ' '---------------------------------------------------------- ' 14. Wypełnianie kolumny zadanym ciągiem znaków '---------------------------------------------------------- Sub Kolwyp() ' PODANIE CIĄGU ZNAKÓW Dim Komunikat, Tytul, Domyslne, Ciag Komunikat = "Podaj ciag znakow" ' Ustaw tekst monitu. Tytul = "Ciag znakow" ' Ustaw tytul. Domyslne = "szt" ' Ustaw wartosc domyslna. ' Wyswietl komunikat, tytul i wartosc domyslna. Ciag = InputBox(Komunikat, Tytul, Domyslne) 'WYPEŁNIENIE While Selection.Information(wdWithInTable) = True Selection.TypeText Text:=Ciag Selection.MoveDown Unit:=wdLine, Count:=1 Wend End Sub Sub CloseAllNoSave() Application.Documents.Close SaveChanges:=wdDoNotSaveChanges End Sub Sub BeautifyOCR() ' ' BeautifyOCR Makro ' Makro zapisane 2003-08-14 przez Piotr Bieńkowski ' For x = 1 To ActiveDocument.Paragraphs.Count ActiveDocument.Paragraphs(x).Range.Select With Selection.Font .Spacing = 0 .Scaling = 100 .Position = 0 .Kerning = 0 End With Next x End Sub Sub langconvPL() Dim mystoryrange As Range For Each mystoryrange In ActiveDocument.StoryRanges 'mystoryrange.LanguageID = wdEnglishUS mystoryrange.LanguageID = wdPolish mystoryrange.NoProofing = False Next mystoryrange scount = ActiveDocument.Shapes.Count For x = 1 To scount ActiveDocument.Shapes(x).Select If ActiveDocument.Shapes(x).TextFrame.HasText = True Then ActiveDocument.Shapes(x).TextFrame.TextRange.Select Selection.LanguageID = wdPolish End If Next x Selection.Collapse Direction:=wdCollapseEnd CommandBars("Reviewing").Visible = False End Sub Sub langconvEN() Dim mystoryrange As Range For Each mystoryrange In ActiveDocument.StoryRanges mystoryrange.LanguageID = wdEnglishUS mystoryrange.NoProofing = False 'mystoryrange.LanguageID = wdPolish Next mystoryrange scount = ActiveDocument.Shapes.Count For x = 1 To scount ActiveDocument.Shapes(x).Select If ActiveDocument.Shapes(x).TextFrame.HasText = True Then ActiveDocument.Shapes(x).TextFrame.TextRange.Select Selection.LanguageID = wdEnglishUS End If Next x Selection.Collapse Direction:=wdCollapseEnd CommandBars("Reviewing").Visible = False End Sub Sub LangConvEN_Batch() Dim mystoryrange As Range For z = 1 To Application.Documents.Count Application.Documents(z).Activate For Each mystoryrange In ActiveDocument.StoryRanges mystoryrange.LanguageID = wdEnglishUS mystoryrange.NoProofing = False 'mystoryrange.LanguageID = wdPolish Next mystoryrange scount = ActiveDocument.Shapes.Count For x = 1 To scount ActiveDocument.Shapes(x).Select If ActiveDocument.Shapes(x).TextFrame.HasText = True Then ActiveDocument.Shapes(x).TextFrame.TextRange.Select Selection.LanguageID = wdEnglishUS End If Next x Selection.Collapse Direction:=wdCollapseEnd Next z CommandBars("Reviewing").Visible = False End Sub Sub Reverse() Dim Dwaslowa As New Collection slowo1 = Selection.Words(1) last1 = Right(slowo1, 1) slowo2 = Selection.Words(2) last2 = Right(slowo2, 1) If last1 = " " Then slowo1 = RTrim(slowo1) End If If last2 = " " Then slowo2 = RTrim(slowo2) End If Dwaslowa.Add slowo1 Dwaslowa.Add slowo2 Selection.Delete Selection.InsertAfter Dwaslowa.Item(2) Selection.InsertAfter " " Selection.InsertAfter Dwaslowa.Item(1) Selection.InsertAfter " " Selection.Collapse Direction:=wdCollapseStart End Sub Sub SelectBetweenRoundBrackets() Selection.MoveEndUntil Cset:="(", Count:=wdBackward Selection.MoveEndUntil Cset:=")", Count:=wdForward End Sub Sub PDFCharCorr() ' ' PDFCharCorr Makro ' Makro zapisane 2003-07-30 przez Piotr Bieńkowski ' '------------------------- ' ń '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(402) .Replacement.Text = "ń" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ś '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(234) .Replacement.Text = "ś" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ą '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(224) .Replacement.Text = "ą" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ł '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(8719) .Replacement.Text = "ł" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ę '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(8242) .Replacement.Text = "ę" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ę - druga "mutacja '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(180) .Replacement.Text = "ę" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ż '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(733) .Replacement.Text = "ż" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ł '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(184) .Replacement.Text = "ż" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ó '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "¨®" .Replacement.Text = "ó" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' ć '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "ç" .Replacement.Text = "ć" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ż '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(730) .Replacement.Text = "Ż" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ę '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(162) .Replacement.Text = "Ę" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ń '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(161) .Replacement.Text = "Ń" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ą '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(209) .Replacement.Text = "Ą" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ć '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(229) .Replacement.Text = "Ć" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '------------------------- ' Ś '------------------------- Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(194) .Replacement.Text = "Ś" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub '---------------------------------------------------------- 'KONIEC MAKR '----------------------------------------------------------