| JanPolak | 16-01-2011 11:40 |
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
| 