Spis Stron RPG Regulamin Wieści POMOC Kalendarz
Wróć   lastinn > RPG - ogólnie > Kufer skarbów
Zarejestruj się Użytkownicy

Kufer skarbów Tutaj możesz dodać jakiś plik lub znaleźć coś dla siebie


 
 
Narzędzia wątku Wygląd
Stary 16-01-2011, 12:40   #1
 
JanPolak's Avatar
 
Reputacja: 1 JanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemuJanPolak to imię znane każdemu
generowanie [znaczników] w MS Word

Przydatną rzecz dziś znalazłem. Makro do Worda zmieniające formatowanie tekstu (pogrubienia, kursywy) na znaczniki w [nawiasach kwadratowych]. Obsługuje bolda, italic, underline i zamianę hypelinków na tag URL. Nie ma co prawda kolorów, justowań i bardziej skomplikowanych tagów, ale można je dopisać, jak ktoś ma zaparcie do grzebania w kodzie. Nie wiem, jak dla Was, ale dla mnie to jest bomba.

Convert Word document to BBcode

I dla porządku wklejam sam kod:
Kod HTML:
 'Word2BBCode-Converter v0.1

    Sub Word2BBCode()
       
        Application.ScreenUpdating = False
           
        ConvertItalic
        ConvertBold
        ConvertUnderline
        ConvertHyperlinks
       
        ActiveDocument.Content.Copy
       
        Application.ScreenUpdating = True
    End Sub
    Private Sub ConvertBold()
        ActiveDocument.Select
       
        With Selection.Find
       
            .ClearFormatting
            .Font.Bold = True
            .Text = ""
           
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
           
            .Forward = True
            .Wrap = wdFindContinue
           
            Do While .Execute
                With Selection
                    If InStr(1, .Text, vbCr) Then
                        ' Just process the chunk before any newline characters
                        ' We'll pick-up the rest with the next search
                              .Font.Bold = False
                        .Collapse
                        .MoveEndUntil vbCr
                    End If
                                           
                    ' Don't bother to markup newline characters (prevents a loop, as well)
                    If Not .Text = vbCr Then
                        .InsertBefore "[b]"
                        .InsertAfter "[/b]"
                    End If
                   
                    .Font.Bold = False
                End With
            Loop
        End With
    End Sub
    Private Sub ConvertItalic()
        ActiveDocument.Select
       
        With Selection.Find
       
            .ClearFormatting
            .Font.Italic = True
            .Text = ""
           
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
           
            .Forward = True
            .Wrap = wdFindContinue
           
            Do While .Execute
                With Selection
                    If InStr(1, .Text, vbCr) Then
                        ' Just process the chunk before any newline characters
                        ' We'll pick-up the rest with the next search
                        .Font.Italic = False
                        .Collapse
                        .MoveEndUntil vbCr
                    End If
                                           
                    ' Don't bother to markup newline characters (prevents a loop, as well)
                    If Not .Text = vbCr Then
                        .InsertBefore "[i]"
                        .InsertAfter "[/i]"
                    End If
                   
                    .Font.Italic = False
                End With
            Loop
        End With
    End Sub
    Private Sub ConvertUnderline()
        ActiveDocument.Select
       
        With Selection.Find
       
            .ClearFormatting
            .Font.Underline = True
            .Text = ""
           
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
           
            .Forward = True
            .Wrap = wdFindContinue
           
            Do While .Execute
                With Selection
                    If InStr(1, .Text, vbCr) Then
                        ' Just process the chunk before any newline characters
                        ' We'll pick-up the rest with the next search
                        .Font.Underline = False
                        .Collapse
                        .MoveEndUntil vbCr
                    End If
                                           
                    ' Don't bother to markup newline characters (prevents a loop, as well)
                    If Not .Text = vbCr Then
                        .InsertBefore "[u]"
                        .InsertAfter "[/u]"
                    End If
                   
                    .Font.Underline = False
                End With
            Loop
        End With
    End Sub

    Private Sub ConvertHyperlinks()
        'converts Hyperlinks
        '24-MAY-2006: only convert http..., mark others with error marker

    Dim hyperCount&
        Dim i&
        Dim addr$ ', title$

        hyperCount = ActiveDocument.Hyperlinks.Count

        For i = 1 To hyperCount

            With ActiveDocument.Hyperlinks(1) 'must be 1, since the delete changes count and position

                addr = .Address
                If Trim$(addr) = "" Then addr = "no hyperlink found"
                'title = .Range.Text
               
                'http, ftp
                If LCase(Left$(addr, 4)) = "http" Or LCase(Left$(addr, 3)) = "ftp" Then
                    .Delete 'hyperlink
                    .Range.InsertBefore "[url=" & addr & "]"
                    .Range.InsertAfter "[/url]"
                   
                    GoTo ConvertHyperlinks_Next
                End If
               
                'mailto:
                If LCase(Left$(addr, 7)) = "mailto:" Then
                    .Delete 'hyperlink
                    .Range.InsertBefore "[email]" & addr & " "
                    .Range.InsertAfter "[/email]"
                   
                    GoTo ConvertHyperlinks_Next
                End If
               
                'file guess
                If Len(addr) > 4 Then 'the reason for not nice goto
                    If Mid$(addr, Len(addr) - 3, 1) = "." Then
                        .Delete
                        .Range.InsertBefore "[file://" & Replace(addr, " ", "_") & " "
                        .Range.InsertAfter "]"
                       
                        GoTo ConvertHyperlinks_Next
                    End If
                End If
               
                'unidentified
                .Delete
                .Range.InsertBefore UnableToConvertMarker & "[" & addr & " "
                .Range.InsertAfter "]"

    ConvertHyperlinks_Next:
            End With

        Next i

    End Sub
 
__________________
Jestem Polakiem, mam na to papier i cały system zachowań.

Ostatnio edytowane przez JanPolak : 16-01-2011 o 12:43.
JanPolak jest offline   Odpowiedź z Cytowaniem
 



Zasady Pisania Postów
Nie Możesz wysyłać nowe wątki
Nie Możesz wysyłać odpowiedzi
Nie Możesz wysyłać załączniki
Nie Możesz edytować swoje posty

vB code jest Wł.
UśmieszkiWł.
kod [IMG] jest Wł.
kod HTML jest Wył.
Trackbacks jest Wył.
PingbacksWł.
Refbacks are Wył.


Czasy w strefie GMT +2. Teraz jest 13:30.



Powered by: vBulletin Version 3.6.5
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Search Engine Optimization by vBSEO 3.1.0
Pozycjonowanie stron | polecanki
Free online flash Mario Bros -Mario games site

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172