|
Kufer skarbów Tutaj możesz dodać jakiś plik lub znaleźć coś dla siebie |
| Narzędzia wątku | Wygląd |
16-01-2011, 11:40 | #1 |
Reputacja: 1 | 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 11:43. |