'Sub word2bb()
'
' word2bb Macro
'
'
'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: Word2MediaWikiPlus@beadsoft.de
'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
    
    ConvertTitle
    ConvertItalic
    ConvertBold
    ConvertUnderline
    ConvertSize
    ConvertLists
    ConvertHyperlinks
    CovertCenter
    ConvertNote
    AddCarriageReturns

   
    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
            .InsertBefore "[List]"
            For i = 1 To .ListFormat.ListLevelNumber
                If .ListFormat.ListType = wdListBullet Then
                    .InsertBefore "[*]"
                Else
                    .InsertBefore "[#]"
                End If
            Next i
            .InsertBefore "[List]"
            .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

Private Sub CovertCenter()
    Dim Par As Paragraph, Rng As Range
    For Each Par In ActiveDocument.Paragraphs
        If Par.Alignment = wdAlignParagraphCenter Then
            If Rng Is Nothing Then
                Set Rng = Par.Range
            Else
                Rng.End = Par.Range.End
            End If
        Else
            Call CenterFmt(Rng)
        End If
        If Par.Range.End = ActiveDocument.Range.End Then
            Call CenterFmt(Rng)
        End If
    Next
End Sub

Private Sub CenterFmt(Rng As Range)
If Not Rng Is Nothing Then
  With Rng
    .End = .End - 1
    .InsertBefore "[center]"
    .InsertAfter "[/center]"
  End With
  Set Rng = Nothing
End If
End Sub

Private Sub ConvertTitle()
Application.ScreenUpdating = False
Dim Par As Paragraph, Rng As Range
For Each Par In ActiveDocument.Paragraphs
  If Par.Style = "Title" Then
    If Rng Is Nothing Then
      Set Rng = Par.Range
    Else
      Rng.End = Par.Range.End
    End If
  Else
    Call TitleFmt(Rng)
  End If
  If Par.Range.End = ActiveDocument.Range.End Then
    Call TitleFmt(Rng)
  End If
Next
Application.ScreenUpdating = True
End Sub

Private Sub TitleFmt(Rng As Range)
If Not Rng Is Nothing Then
  With Rng
    .End = .End - 1
    .InsertBefore "[t]"
    .InsertAfter "[/t]"
  End With
  Set Rng = Nothing
End If
End Sub

Private Sub AddCarriageReturns()
    Dim doc As Document
    Dim para As Paragraph

    Set doc = ActiveDocument

    For Each para In doc.Paragraphs
        If para.Style = doc.Styles(wdStyleNormal) Then
            para.Range.InsertBefore vbCr
        End If
    Next para
End Sub

Private Sub ConvertNote()

    Dim Par As Paragraph, Rng As Range
    For Each Par In ActiveDocument.Paragraphs
        If Par.Style = "Heading 5" Then
            If Rng Is Nothing Then
                Set Rng = Par.Range
            Else
                Rng.End = Par.Range.End
            End If
        Else
            Call NoteFmt(Rng)
        End If
            If Par.Range.End = ActiveDocument.Range.End Then
            Call NoteFmt(Rng)
        End If
    Next
End Sub

Private Sub NoteFmt(Rng As Range)
If Not Rng Is Nothing Then
  With Rng
    .End = .End - 1
    .InsertBefore "[color=#ff0000]"
    .InsertAfter "[/colot]"
  End With
  Set Rng = Nothing
End If
End Sub