Word to BBCode Macro

This forum is now closed as part of retiring phpBB2
Forum rules
READ: phpBB.com Board-Wide Rules and Regulations

This forum is now closed due to phpBB2.0 being retired.
Post Reply
mkruer
Registered User
Posts: 74
Joined: Mon Apr 28, 2003 7:49 pm

Word to BBCode Macro

Post by mkruer » Thu Jun 01, 2006 1:04 am

I hope this is the correct place; Does anyone know of a MS word macro that will convert a document in word into BBCode. It doesn’t need to be anything fancy, only the basic stuff.

-TIA-

mkruer
Registered User
Posts: 74
Joined: Mon Apr 28, 2003 7:49 pm

Post by mkruer » Sat Jun 03, 2006 4:11 am

Because no one cares, and I could not find one on the web, here is one that I pieced together. I suck at VB, and this is probably not the most efficient coding practice, but hey it works. For the time being I am keeping within the original BBCode specs listed http://www.phpbb.com/phpBB/faq.php?mode=bbcode

If anyone can help I would really appreciate it.

Right now, the Bold, Underline, Italic works fully
Colors, and html work but they have bugs in them
And I have no clued at this time on how to fix the Font Size and Lists to work correctly.

Code: Select all

'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
        
    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
            .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

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

Graham
Former Team Member
Posts: 8462
Joined: Tue Mar 19, 2002 7:11 pm
Location: UK
Contact:

Post by Graham » Sat Jun 03, 2006 11:58 am

I'm moving this to the MOD Development forum since it's not really a convertor in the nature of this forum
"So Long, and Thanks for All the Fish"

phpBB Useful Links: Knowledge Base | Userguide | Forum Search | MOD Database | Styles Database
My Links: Blog!

Ex0dus
Registered User
Posts: 98
Joined: Mon Nov 01, 2004 1:17 am
Location: Zarasu, Lithuania
Contact:

Post by Ex0dus » Sat Jun 03, 2006 2:37 pm

Its a good start ^_^ once some of the aformentioned bugs are worked out it would be a nice thing for those of us who use word to pre-post to use ^_^

-Ex0dus

User avatar
MHobbit
Former Team Member
Posts: 4761
Joined: Thu Mar 18, 2004 5:32 pm
Location: There and Back Again

Post by MHobbit » Sat Jun 03, 2006 9:24 pm

Moved to MOD Requests.
Former phpBB MOD Team member
No private support is offered.
"There’s too many things to get done, and I’m running out of days..."

mkruer
Registered User
Posts: 74
Joined: Mon Apr 28, 2003 7:49 pm

Post by mkruer » Sun Jun 04, 2006 9:06 am

I think that if we (if anyone is willing to help) break the current could down, we can come up with a fairly robust macro. Currently the biggest annoyance for me is the font size. What I am trying to do is get the default font size of the document (let face it not everyone used 12pt as their default, but its considered the universal default) none the less the script should work something like this.

Get the default font size.
Subtract the default from the universal default 12.
Then search the document for text that has a different size then the default and all the [size=xx in to the beginning of the text, and [whack/size] where it changes back to normal.

The guts of the script would be .InsertBefore "[size=" & fSize + dSize & "]"
Where fSize is the font size, and dSize is the difference in the default size.

That way we will know that if you have word set up to use 10pt as the default font size, and it comes across a 16pt font, that when it add the font tag, it labels the 16pt font as 18pt. I hope everyone got that.


Code: Select all

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 

dokdeath
Registered User
Posts: 1
Joined: Fri May 11, 2007 8:17 pm

Re: Word to BBCode Macro

Post by dokdeath » Thu May 24, 2007 6:22 pm

Just wanted to chime in real quick and thank you for the code you put together. I tried it in Word 2007 and the only thing that bombed out on me was the color function but i commented it out and everything else ran fine. I don't need it to be TOO fancy so what you have here minus the color function is exactly what I needed. Thank you!

:ugeek:

Post Reply

Return to “[2.0.x] MOD Requests”