word-to-worldanvil-bbcode.vba

word-to-worldanvil-bbcode.vba

'Word2BBCode-Converter v0.1, June 2, 2006
'Matthew Kruer
'Some parts adapted from
'Word2Wiki-Converter V0.4, May 28, 2006
'http://de.wikipedia.org/wiki/Wikipedia:Helferlein/Word2MediaWikiPlus
'Original Version by InfPro: http://www.infpro.com/downloads/downloads/wordmedia.htm
'Major improvements by Gunter Schmidt, Mail me: [email protected]
'Works only with Word 2000 and above
'License: GPL: Feel free to use and modify. Keep the credits and do not sell.

Sub Word2BBCode()
    
    Application.ScreenUpdating = False
        
    ConvertItalic
    ConvertBold
    ConvertUnderline
    ConvertSize
    ConvertLists
    ConvertHyperlinks
    ConvertColor
   
    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 ConvertSize()
   
Dim fSize&
   
    If convertFontSize = False Then Exit Sub
   
    If DefaultFontSize = 12 Then DefaultFontSize = 12
    fSize = 12
       
    For fSize = 1 To 50
    If fSize > DefaultFontSize + 1 Or fSize < DefaultFontSize - 1 Then 'at least two points difference
        ActiveDocument.Select
        With Selection.Find
    
            .ClearFormatting
            .Font.Size = fSize
            .Text = ""
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Forward = True
            .Wrap = wdFindContinue
    
            Do While .Execute
                With Selection
    
                    If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
                        ' Just process the chunk before any newline characters
                        ' We'll pick-up the rest with the next search
                        .Collapse
                        .MoveEndUntil vbCr
                    End If
    
                    ' Don't bother to markup newline characters (prevents a loop, as well)
                    If Not .Text = vbCr Then
                        If fSize = DefaultFontSize Then
                            .InsertBefore "[size=" & fSize & "]"
                            .InsertAfter "[/size]"
                         End If
                    End If
    
                    If useDefaultStyle Then .Style = ActiveDocument.Styles(DefaultStyleName) 'must be localized to your language, see CONST on top
                    .Font.Size = DefaultFontSize
                    '.Collapse wdCollapseEnd
                    '.MoveLeft , 4, True
                    'ClearFormatting
    
                End With
            Loop
        End With
    End If
    Next

End Sub
Private Sub ConvertLists()
   Dim para As Paragraph
    For Each para In ActiveDocument.ListParagraphs
        With para.Range
            For i = 1 To .ListFormat.ListLevelNumber
                .InsertBefore "[li]"
                .InsertAfter "[/li]"
            Next i
            .InsertBefore "[ul]"
            .InsertAfter "[/ul]"
            .ListFormat.RemoveNumbers
            
        End With
    Next para
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

Sub ConvertColor()
    'converts the colors of the text to HTML-Colors
    'maybe there is a faster method?
    
    Dim CurColor& 'Current Color, indicates change
    Dim OpenColor& 'Color the font was opened with
    Dim pgColor&
    Dim cNo& 'Number of characters
    Dim txt$
    Dim FontOpen As Boolean
    Dim pg As Paragraph
    
    'First check, if the paragraphs have different colors
    'seems Word gives 9999999 if more than one color!
    
    For Each pg In ActiveDocument.Paragraphs
        'blanks at the beginning
        If pgColor <> pg.Range.Font.Color Then
            pgColor = pg.Range.Font.Color
            If pgColor = "9999999" Then 'different colors in paragraph
                'Check each letter in paragraph
                'I found no other possibility other then to check each letter
                'Dead slow
                cNo = 0
                With pg.Range
                Do While cNo < .Characters.Count
                    cNo = cNo + 1
                    'Debug.Print cNo, .Characters(cNo)
                    If cNo Mod 20 = 0 Then DoEvents
                    If CurColor <> .Characters(cNo).Font.Color Then
                        If FontOpen = False Then
                            'open font
                            CurColor = .Characters(cNo).Font.Color
                            If RGB2HTML(CurColor) <> "#000000" Then
                                OpenColor = .Characters(cNo).Font.Color
                                txt = "[font color=""" & RGB2HTML(OpenColor) & """]"
                                .Characters(cNo).InsertBefore txt
                                FontOpen = True
                                cNo = cNo + Len(txt) - 1
                            End If
                        Else
                            'close font
                            CurColor = 0
                            OpenColor = 0
                            txt = "[/font]"
                            .Characters(cNo).InsertBefore txt
                            FontOpen = False
                            cNo = cNo + Len(txt) - 1
                        End If
                    End If
                Loop
                End With
                
            ElseIf FontOpen = False Then
                    'open font
                    pgColor = pg.Range.Font.Color
                    If RGB2HTML(pgColor) <> "#000000" Then
                        OpenColor = pg.Range.Font.Color
                        txt = "[font color=""" & RGB2HTML(OpenColor) & """]"
                        pg.Range.InsertBefore txt
                        FontOpen = True
                        cNo = cNo + Len(txt) - 1
                    End If
                Else
                    'close font
                    If pgColor <> OpenColor Then
                        CurColor = 0
                        OpenColor = 0
                        txt = "[/font]"
                        pg.Range.InsertBefore txt
                        FontOpen = False
                        cNo = cNo + Len(txt) - 1
                    End If
                'End If
            End If
            
        End If
    Next
    
End Sub