'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