Rampage 2
2016-01-25, 04:03:00
Morgen,
Ich habe einen riesenlangen Text in MS OneNote geschrieben und an zahlreichen Stellen formatiert (Schriftfarbe, Fett, Unterstrichen und der ganze Kram...) und hatte eigentlich vorgehabt, das Ganze durch einen Konverter in BBCode zu verwandeln, so dass die Formatierung nicht verloren geht - ich will nämlich den gesamten Text als Forum-Beitrag posten (ist weniger eine Message, sondern vielmehr ein Tutorial) und habe keinen Bock, dafür nochmal erneut jede Stelle einzeln formatieren zu müssen...
Das Problem dabei: irgendwie scheint keines der Online-Konverter wirklich zu taugen, weil die Formatierung nicht vollständig korrekt übernommen wird.
Dann habe ich noch ein paar VBA-Skripte im Netz gefunden, die von anderen Usern für MS Word geschrieben wurden (um Word-Formatierungen in BBCode umzuwandeln) - keines dieser Skripte funktioniert, zumal manche schon sehr alt sind (aus dem Jahr 2006...); der Word-VBA-Editor spuckt jedes Mal eine Fehlermeldung aus (Syntaxfehler und andere Programmierfehler).
Nur Eines der Skripte, die ich gefunden habe, läuft fehlerfrei durch - spuckt aber keinen neuen Code aus, es wird Nichts verändert...
Ich dachte, ich poste einfach den Code der gefundenen Skripte und diejenigen von euch, die sich damit auskennen, reparieren den Code einfach:
(besitze Office 2010 - beim Testen habe ich einfach die Formatierung von OneNote 2010 1:1 nach Word 2010 kopiert)
Skript 1: (vom August 2015 - keine Fehlermeldung, aber auch keine Veränderung)
Sub ForumEin()
b = 0
Dim BoldOn As String
Dim BoldOff As String
BoldOn = ""
BoldOff = ""
i = 0
ItalicOn = ""
ItalicOff = ""
u = 0
UnderlineOn = ""
UnderlineOff = ""
Selection.WholeStory
SeRange = Selection.Characters.Count
Selection.StartOf (wdStory)
For StPosition = 1 To SeRange - 1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'Prüfe Bold
If Selection.Font.Bold = True Then
Selection.Font.Bold = False
If b = 0 Then
Selection.InsertBefore (BoldOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
b = 1
End If
Else
If b = 1 Then
Selection.InsertBefore (BoldOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
b = 0
End If
End If
'Prüfe Italic
If Selection.Font.Italic = True Then
Selection.Font.Italic = False
If i = 0 Then
Selection.InsertBefore (ItalicOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
i = 1
End If
Else
If i = 1 Then
Selection.InsertBefore (ItalicOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
i = 0
End If
End If
'Prüfe Underline
If Selection.Font.Underline = wdUnderlineSingle Then
Selection.Font.Underline = False
If u = 0 Then
Selection.InsertBefore (UnderlineOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
u = 1
End If
Else
If u = 1 Then
Selection.InsertBefore (UnderlineOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
u = 0
End If
End If
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next StPosition
If b = 1 Then
Selection.InsertBefore (BoldOff)
End If
If i = 1 Then
Selection.InsertBefore (ItalicOff)
End If
If u = 1 Then
Selection.InsertBefore (UnderlineOff)
End If
End Sub
Quelle (http://schreibblase.moriazwo.de/index.php?page=Thread&postID=1639)
Skript 2: (vom Dezember 2010; scheint eine Modifikation des Original-Skripts von 2006 zu sein...) (erzeugt Fehlermeldung)
Sub Word2BBCode()
Application.ScreenUpdating = False
ConvertHyperlinks
ConvertItalic
ConvertBold
ConvertUnderline
ConvertSuperscript
ConvertSubscript
ConvertStrikethrough
ConvertMonospace
ConvertLists
ConvertQuotes
ActiveDocument.Content.Copy
Call Selection.Find.ClearFormatting
Application.ScreenUpdating = True
End Sub
Private Sub SurroundSelectionWithTag(tagName As String)
With Selection
.InsertBefore "[" & tagName & "]"
.ClearCharacterDirectFormatting
.Collapse (wdCollapseEnd)
.InsertAfter "[/" & tagName & "]"
.ClearCharacterDirectFormatting
End With
End Sub
Private Sub SetupFindObject()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
'.Font.Name = "Consolas" (or whatever else goes here)
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
End With
End Sub
Private Sub ConvertMonospace()
Call SetupFindObject
Selection.Find.Font.Name = "Consolas"
Do While Selection.Find.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.Name = "Calibri"
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Name = "Calibri"
SurroundSelectionWithTag ("fixed")
End If
End With
Loop
End Sub
Private Sub ConvertBold()
Call SetupFindObject
Selection.Find.Font.Bold = True
' note the extra work done on Bold: that's because quote headers are defined
' by being bold, and there are more restrictions on what they can be like in
' order for the quoting code to be released; what is done here is a major
' HACK, but I didn't want to expend even more time figuring out the API
Dim otherLf As String
otherLf = Chr(11)
Do While Selection.Find.Execute
With Selection
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
If InStr(1, .Text, vbCr) Then
.Font.Bold = False
.Collapse
.MoveEndUntil vbCr
ElseIf InStr(1, .Text, otherLf) Then
.Font.Bold = False
.Collapse
.MoveEndUntil otherLf
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr And Not .Text = otherLf Then
' if it's bold until the end of the line, but not including the newline,
' the .InsertAfter statement will keep the current formatting, including
' bold and hyperlink, which screws up quoting functionality; doing the
' below fixes things, and only requires that the quote have content
If .Style = "Quote" Then
' .MoveEnd wdCharacter, 1
' .MoveEnd wdCharacter, -1
End If
.Font.Bold = False
SurroundSelectionWithTag ("b")
End If
End With
Loop
End Sub
Private Sub ConvertItalic()
Call SetupFindObject
Selection.Find.Font.Italic = True
Do While Selection.Find.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
.Font.Italic = False
SurroundSelectionWithTag ("i")
End If
End With
Loop
End Sub
Private Sub ConvertUnderline()
Call SetupFindObject
Selection.Find.Font.Underline = True
Do While Selection.Find.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 And .Range.Hyperlinks.Count = 0 Then
.Font.Underline = False
SurroundSelectionWithTag ("u")
End If
End With
Loop
End Sub
Private Sub ConvertSubscript()
Call SetupFindObject
Selection.Find.Font.Subscript = True
Do While Selection.Find.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.Superscript = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Superscript = False
SurroundSelectionWithTag ("sub")
End If
End With
Loop
End Sub
Private Sub ConvertSuperscript()
Call SetupFindObject
Selection.Find.Font.Superscript = True
Do While Selection.Find.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.Superscript = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Superscript = False
SurroundSelectionWithTag ("super")
End If
End With
Loop
End Sub
Private Sub ConvertStrikethrough()
Call SetupFindObject
Selection.Find.Font.StrikeThrough = True
Do While Selection.Find.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.StrikeThrough = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.StrikeThrough = False
SurroundSelectionWithTag ("s")
End If
End With
Loop
End Sub
Private Sub ConvertQuotes()
Call EnsureBoundedByNormalStyle
Dim r As RegExp
Dim matches As MatchCollection
Set r = New RegExp
Dim paras As Collection
Set paras = New Collection
r.Pattern = "^(?:[b\]([^\r\n]+)[/b\][\r\n\x0B]+)?(.*?)[\r\n]+$"
ActiveDocument.Select
Call Selection.GoTo(wdGoToLine, wdGoToFirst)
With Selection.Find
Call SetupFindObject
.Wrap = wdFindStop
.Style = "Quote"
Do While .Execute
Call paras.Add(Selection.Range)
Loop
End With
Call Selection.GoTo(wdGoToLine, wdGoToLast)
Call paras.Add(Selection.Range)
Dim quotes As Collection
Dim rng As Range
Set quotes = New Collection
Dim qStart As Long
Dim qEnd As Long
Dim lastEnd As Long
lastEnd = paras(1).Start
For Each rng In paras
'Debug.Print rng.Start & " - " & rng.End & " : " & qStart & " : " & qEnd
If lastEnd = rng.Start And rng.Style = "Quote" Then
' continue a quote
qEnd = rng.End
If qStart = 0 Then qStart = rng.Start
ElseIf qStart <> qEnd Then
' new quote
'Debug.Print "adding " & qStart & " - " & qEnd
Call quotes.Add(ActiveDocument.Range(qStart, qEnd))
qStart = rng.Start
qEnd = rng.End
End If
lastEnd = rng.End
Next rng
Dim i As Integer
For i = quotes.Count To 1 Step -1
Call Selection.SetRange(quotes(i).Start, quotes(i).End)
With Selection
Set matches = r.Execute(.Text)
Dim submatch As String
If matches.Count > 0 Then
submatch = matches(0).SubMatches(0)
Else
submatch = ""
End If
If submatch <> "" Then
.Text = r.Replace(.Text, "$2")
Else
.Text = r.Replace(.Text, "$2")
End If
End With
Next i
End Sub
' The code below is kind of hacky, because Microsoft's list implementation
' leaves a lot to be desired. Fortunately, it seems to work well, although
' it has not been tested with blank lines in lists.
'
' This code assumes that needs to be terminated by ,
' instead of [/list]. Making the change would be trivial.
Private Sub ConvertLists()
Dim l As List
Dim p As Paragraph
Dim curLevel As Integer
Dim i As Integer
Dim typeStack(10) As String ' hopefully lists aren't indented more than this
curLevel = 1
For Each l In ActiveDocument.Lists
With l.Range
For i = 1 To .ListParagraphs.Count
Set p = .ListParagraphs(i)
p.Range.InsertBefore " "
If p.Range.ListFormat.ListLevelNumber < curLevel Then
p.Range.InsertBefore "[/list" & typeStack(curLevel) & "]"
curLevel = curLevel - 1
ElseIf p.Range.ListFormat.ListLevelNumber > curLevel Then
curLevel = curLevel + 1
typeStack(curLevel) = ExtractListSuffix(p.Range.ListFormat.ListString)
p.Range.InsertBefore "[list" & typeStack(curLevel) & "]"
End If
Next i
Do While curLevel > 1
.InsertAfter "[/list" & typeStack(curLevel) & "]"
curLevel = curLevel - 1
Loop
Dim bullet As String
bullet = ExtractListSuffix(l.Range.ListFormat.ListString)
.InsertBefore "[list" & bullet & "]"
.InsertAfter "[/list" & bullet & "]" & vbCrLf
.ListFormat.RemoveNumbers
End With
Next l
End Sub
Public Function ExtractListSuffix(bullet As String) As String
bullet = Left$(bullet, 1)
If InStr(1, "AI1", bullet, vbTextCompare) > 0 Then
ExtractListSuffix = "=" & bullet
Else
ExtractListSuffix = ""
End If
End Function
Private Sub ConvertHyperlinks()
'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
If .SubAddress <> "" Then addr = addr & "#" & .SubAddress
'http, ftp
If LCase(Left$(addr, 4)) = "http" Or LCase(Left$(addr, 3)) = "ftp" Then
.Delete 'hyperlink
.Range.InsertBefore ""
.Range.InsertAfter " ( & addr & )"
GoTo ConvertHyperlinks_Next
End If
'mailto:
If LCase(Left$(addr, 7)) = "mailto:" Then
.Delete 'hyperlink
.Range.InsertBefore "" & addr & " "
.Range.InsertAfter ""
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
' If the first or last section of the document is of Quote style, the ConvertQuotes
' routine won't process them; instead of making a change there, which is tricky with
' Microsoft Range objects and such, we just add non-formatted, non-styled whitespace
' if we need to.
Private Sub EnsureBoundedByNormalStyle()
Selection.HomeKey Unit:=wdStory
If Selection.Style = "Quote" Then
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Reset
Selection.Style = ActiveDocument.Styles("Normal")
End If
Selection.EndKey Unit:=wdStory
If Selection.Style = "Quote" Then
Selection.TypeParagraph
End If
End Sub
Quelle (http://luke.breuer.com/time/item/Word2BBCode/683.aspx)
Thx 4 help,
R2
Ich habe einen riesenlangen Text in MS OneNote geschrieben und an zahlreichen Stellen formatiert (Schriftfarbe, Fett, Unterstrichen und der ganze Kram...) und hatte eigentlich vorgehabt, das Ganze durch einen Konverter in BBCode zu verwandeln, so dass die Formatierung nicht verloren geht - ich will nämlich den gesamten Text als Forum-Beitrag posten (ist weniger eine Message, sondern vielmehr ein Tutorial) und habe keinen Bock, dafür nochmal erneut jede Stelle einzeln formatieren zu müssen...
Das Problem dabei: irgendwie scheint keines der Online-Konverter wirklich zu taugen, weil die Formatierung nicht vollständig korrekt übernommen wird.
Dann habe ich noch ein paar VBA-Skripte im Netz gefunden, die von anderen Usern für MS Word geschrieben wurden (um Word-Formatierungen in BBCode umzuwandeln) - keines dieser Skripte funktioniert, zumal manche schon sehr alt sind (aus dem Jahr 2006...); der Word-VBA-Editor spuckt jedes Mal eine Fehlermeldung aus (Syntaxfehler und andere Programmierfehler).
Nur Eines der Skripte, die ich gefunden habe, läuft fehlerfrei durch - spuckt aber keinen neuen Code aus, es wird Nichts verändert...
Ich dachte, ich poste einfach den Code der gefundenen Skripte und diejenigen von euch, die sich damit auskennen, reparieren den Code einfach:
(besitze Office 2010 - beim Testen habe ich einfach die Formatierung von OneNote 2010 1:1 nach Word 2010 kopiert)
Skript 1: (vom August 2015 - keine Fehlermeldung, aber auch keine Veränderung)
Sub ForumEin()
b = 0
Dim BoldOn As String
Dim BoldOff As String
BoldOn = ""
BoldOff = ""
i = 0
ItalicOn = ""
ItalicOff = ""
u = 0
UnderlineOn = ""
UnderlineOff = ""
Selection.WholeStory
SeRange = Selection.Characters.Count
Selection.StartOf (wdStory)
For StPosition = 1 To SeRange - 1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
'Prüfe Bold
If Selection.Font.Bold = True Then
Selection.Font.Bold = False
If b = 0 Then
Selection.InsertBefore (BoldOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
b = 1
End If
Else
If b = 1 Then
Selection.InsertBefore (BoldOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
b = 0
End If
End If
'Prüfe Italic
If Selection.Font.Italic = True Then
Selection.Font.Italic = False
If i = 0 Then
Selection.InsertBefore (ItalicOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
i = 1
End If
Else
If i = 1 Then
Selection.InsertBefore (ItalicOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
i = 0
End If
End If
'Prüfe Underline
If Selection.Font.Underline = wdUnderlineSingle Then
Selection.Font.Underline = False
If u = 0 Then
Selection.InsertBefore (UnderlineOn)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
u = 1
End If
Else
If u = 1 Then
Selection.InsertBefore (UnderlineOff)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
u = 0
End If
End If
Selection.MoveRight Unit:=wdCharacter, Count:=1
Next StPosition
If b = 1 Then
Selection.InsertBefore (BoldOff)
End If
If i = 1 Then
Selection.InsertBefore (ItalicOff)
End If
If u = 1 Then
Selection.InsertBefore (UnderlineOff)
End If
End Sub
Quelle (http://schreibblase.moriazwo.de/index.php?page=Thread&postID=1639)
Skript 2: (vom Dezember 2010; scheint eine Modifikation des Original-Skripts von 2006 zu sein...) (erzeugt Fehlermeldung)
Sub Word2BBCode()
Application.ScreenUpdating = False
ConvertHyperlinks
ConvertItalic
ConvertBold
ConvertUnderline
ConvertSuperscript
ConvertSubscript
ConvertStrikethrough
ConvertMonospace
ConvertLists
ConvertQuotes
ActiveDocument.Content.Copy
Call Selection.Find.ClearFormatting
Application.ScreenUpdating = True
End Sub
Private Sub SurroundSelectionWithTag(tagName As String)
With Selection
.InsertBefore "[" & tagName & "]"
.ClearCharacterDirectFormatting
.Collapse (wdCollapseEnd)
.InsertAfter "[/" & tagName & "]"
.ClearCharacterDirectFormatting
End With
End Sub
Private Sub SetupFindObject()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
'.Font.Name = "Consolas" (or whatever else goes here)
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
End With
End Sub
Private Sub ConvertMonospace()
Call SetupFindObject
Selection.Find.Font.Name = "Consolas"
Do While Selection.Find.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.Name = "Calibri"
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Name = "Calibri"
SurroundSelectionWithTag ("fixed")
End If
End With
Loop
End Sub
Private Sub ConvertBold()
Call SetupFindObject
Selection.Find.Font.Bold = True
' note the extra work done on Bold: that's because quote headers are defined
' by being bold, and there are more restrictions on what they can be like in
' order for the quoting code to be released; what is done here is a major
' HACK, but I didn't want to expend even more time figuring out the API
Dim otherLf As String
otherLf = Chr(11)
Do While Selection.Find.Execute
With Selection
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
If InStr(1, .Text, vbCr) Then
.Font.Bold = False
.Collapse
.MoveEndUntil vbCr
ElseIf InStr(1, .Text, otherLf) Then
.Font.Bold = False
.Collapse
.MoveEndUntil otherLf
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr And Not .Text = otherLf Then
' if it's bold until the end of the line, but not including the newline,
' the .InsertAfter statement will keep the current formatting, including
' bold and hyperlink, which screws up quoting functionality; doing the
' below fixes things, and only requires that the quote have content
If .Style = "Quote" Then
' .MoveEnd wdCharacter, 1
' .MoveEnd wdCharacter, -1
End If
.Font.Bold = False
SurroundSelectionWithTag ("b")
End If
End With
Loop
End Sub
Private Sub ConvertItalic()
Call SetupFindObject
Selection.Find.Font.Italic = True
Do While Selection.Find.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
.Font.Italic = False
SurroundSelectionWithTag ("i")
End If
End With
Loop
End Sub
Private Sub ConvertUnderline()
Call SetupFindObject
Selection.Find.Font.Underline = True
Do While Selection.Find.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 And .Range.Hyperlinks.Count = 0 Then
.Font.Underline = False
SurroundSelectionWithTag ("u")
End If
End With
Loop
End Sub
Private Sub ConvertSubscript()
Call SetupFindObject
Selection.Find.Font.Subscript = True
Do While Selection.Find.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.Superscript = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Superscript = False
SurroundSelectionWithTag ("sub")
End If
End With
Loop
End Sub
Private Sub ConvertSuperscript()
Call SetupFindObject
Selection.Find.Font.Superscript = True
Do While Selection.Find.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.Superscript = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.Superscript = False
SurroundSelectionWithTag ("super")
End If
End With
Loop
End Sub
Private Sub ConvertStrikethrough()
Call SetupFindObject
Selection.Find.Font.StrikeThrough = True
Do While Selection.Find.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.StrikeThrough = False
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.Font.StrikeThrough = False
SurroundSelectionWithTag ("s")
End If
End With
Loop
End Sub
Private Sub ConvertQuotes()
Call EnsureBoundedByNormalStyle
Dim r As RegExp
Dim matches As MatchCollection
Set r = New RegExp
Dim paras As Collection
Set paras = New Collection
r.Pattern = "^(?:[b\]([^\r\n]+)[/b\][\r\n\x0B]+)?(.*?)[\r\n]+$"
ActiveDocument.Select
Call Selection.GoTo(wdGoToLine, wdGoToFirst)
With Selection.Find
Call SetupFindObject
.Wrap = wdFindStop
.Style = "Quote"
Do While .Execute
Call paras.Add(Selection.Range)
Loop
End With
Call Selection.GoTo(wdGoToLine, wdGoToLast)
Call paras.Add(Selection.Range)
Dim quotes As Collection
Dim rng As Range
Set quotes = New Collection
Dim qStart As Long
Dim qEnd As Long
Dim lastEnd As Long
lastEnd = paras(1).Start
For Each rng In paras
'Debug.Print rng.Start & " - " & rng.End & " : " & qStart & " : " & qEnd
If lastEnd = rng.Start And rng.Style = "Quote" Then
' continue a quote
qEnd = rng.End
If qStart = 0 Then qStart = rng.Start
ElseIf qStart <> qEnd Then
' new quote
'Debug.Print "adding " & qStart & " - " & qEnd
Call quotes.Add(ActiveDocument.Range(qStart, qEnd))
qStart = rng.Start
qEnd = rng.End
End If
lastEnd = rng.End
Next rng
Dim i As Integer
For i = quotes.Count To 1 Step -1
Call Selection.SetRange(quotes(i).Start, quotes(i).End)
With Selection
Set matches = r.Execute(.Text)
Dim submatch As String
If matches.Count > 0 Then
submatch = matches(0).SubMatches(0)
Else
submatch = ""
End If
If submatch <> "" Then
.Text = r.Replace(.Text, "$2")
Else
.Text = r.Replace(.Text, "$2")
End If
End With
Next i
End Sub
' The code below is kind of hacky, because Microsoft's list implementation
' leaves a lot to be desired. Fortunately, it seems to work well, although
' it has not been tested with blank lines in lists.
'
' This code assumes that needs to be terminated by ,
' instead of [/list]. Making the change would be trivial.
Private Sub ConvertLists()
Dim l As List
Dim p As Paragraph
Dim curLevel As Integer
Dim i As Integer
Dim typeStack(10) As String ' hopefully lists aren't indented more than this
curLevel = 1
For Each l In ActiveDocument.Lists
With l.Range
For i = 1 To .ListParagraphs.Count
Set p = .ListParagraphs(i)
p.Range.InsertBefore " "
If p.Range.ListFormat.ListLevelNumber < curLevel Then
p.Range.InsertBefore "[/list" & typeStack(curLevel) & "]"
curLevel = curLevel - 1
ElseIf p.Range.ListFormat.ListLevelNumber > curLevel Then
curLevel = curLevel + 1
typeStack(curLevel) = ExtractListSuffix(p.Range.ListFormat.ListString)
p.Range.InsertBefore "[list" & typeStack(curLevel) & "]"
End If
Next i
Do While curLevel > 1
.InsertAfter "[/list" & typeStack(curLevel) & "]"
curLevel = curLevel - 1
Loop
Dim bullet As String
bullet = ExtractListSuffix(l.Range.ListFormat.ListString)
.InsertBefore "[list" & bullet & "]"
.InsertAfter "[/list" & bullet & "]" & vbCrLf
.ListFormat.RemoveNumbers
End With
Next l
End Sub
Public Function ExtractListSuffix(bullet As String) As String
bullet = Left$(bullet, 1)
If InStr(1, "AI1", bullet, vbTextCompare) > 0 Then
ExtractListSuffix = "=" & bullet
Else
ExtractListSuffix = ""
End If
End Function
Private Sub ConvertHyperlinks()
'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
If .SubAddress <> "" Then addr = addr & "#" & .SubAddress
'http, ftp
If LCase(Left$(addr, 4)) = "http" Or LCase(Left$(addr, 3)) = "ftp" Then
.Delete 'hyperlink
.Range.InsertBefore ""
.Range.InsertAfter " ( & addr & )"
GoTo ConvertHyperlinks_Next
End If
'mailto:
If LCase(Left$(addr, 7)) = "mailto:" Then
.Delete 'hyperlink
.Range.InsertBefore "" & addr & " "
.Range.InsertAfter ""
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
' If the first or last section of the document is of Quote style, the ConvertQuotes
' routine won't process them; instead of making a change there, which is tricky with
' Microsoft Range objects and such, we just add non-formatted, non-styled whitespace
' if we need to.
Private Sub EnsureBoundedByNormalStyle()
Selection.HomeKey Unit:=wdStory
If Selection.Style = "Quote" Then
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Font.Reset
Selection.Style = ActiveDocument.Styles("Normal")
End If
Selection.EndKey Unit:=wdStory
If Selection.Style = "Quote" Then
Selection.TypeParagraph
End If
End Sub
Quelle (http://luke.breuer.com/time/item/Word2BBCode/683.aspx)
Thx 4 help,
R2