Macro para Conversor Doc o Docx a BBcode

aforo · Experto Registrado: Feb 13, 2008 Mensajes: 134

Muchas veces tenemos un documento guardado en un documento doc y lo queremos publicar en BBCode (para foros phpbb por ejemplo) y la conversión es una tarea manual larga y tediosa.

Esta Macro Doc-BBcode haría el trabajo.

Code::

'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
    ReplaceInlineShapes_WithIndex
    'ConvertUnderline
    ConvertLists
    ConvertHyperlinks
    'ConvertSize
    '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 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 ReplaceInlineShapes_WithIndex()

Dim oILShp As InlineShape
Dim ILShpIndex As Integer
For Each oILShp In ActiveDocument.InlineShapes
    ILShpIndex = ILShpIndex + 1
    'insert text in place where InlineShape is located
    ActiveDocument.Range(oILShp.Range.Start, oILShp.Range.End).Text = _
                                "[Image" & ILShpIndex & ".Jpg]"
    'delete picture is not needed- it was simply replaced with text

Next
End Sub



Private Sub ConvertSize()

' tag all text of font size <> dfSize
    Dim rDcm As Range
    Dim l As Long
    Dim m As Long
    Dim n As Long

' m = ActiveDocument.Styles("Standard").Font.Size ' german
   ' m = ActiveDocument.Styles("Normal").Font.Size ' english
    m = 10
'get the curent normal size of the document
    n = m - 13
'calculate the differencebetween the normal size of the document and the web size (12)
    Set rDcm = ActiveDocument.Range
' set all paragraph marks to standard value
' and exclude them by this from processing
With rDcm.Find
    .Text = Chr(12)
    While .Execute
        rDcm.Font.Size = m ' <<<
    Wend

End With

For l = 1 To 62
    Set rDcm = ActiveDocument.Range ' <<<<
    If l <> (m - 1) And l <> (m + 1) And l <> m Then ' <<<<
    With rDcm.Find
        .Font.Size = l
        While .Execute
            rDcm.Select ' for testing only
            rDcm.Font.Size = m ' <<<<<<<<<<<<<
            rDcm.InsertBefore "[size=" & l - n & "]"
            rDcm.InsertAfter "[/size]"
            rDcm.Start = rDcm.End
            rDcm.End = ActiveDocument.Range.End
        Wend
    End With
    End If
    Next
End Sub

aforo · Experto Registrado: Feb 13, 2008 Mensajes: 134

Versión 2 del conversor de Word a BBcode mejorada con sustitución de las imágenes por un indice de imagen y simplificación de la conversión de tamaño de letra:

Code::

'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
    'ConvertLists
    ConvertHyperlinks
    'ConvertColor
    ReplaceInlineShapes_WithIndex
    ConvertSize
    
    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 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 ReplaceInlineShapes_WithIndex()

Dim oILShp As InlineShape
Dim ILShpIndex As Integer
For Each oILShp In ActiveDocument.InlineShapes
    ILShpIndex = ILShpIndex + 1
    'insert text in place where InlineShape is located
    ActiveDocument.Range(oILShp.Range.Start, oILShp.Range.End).Text = _
                                "[Image" & ILShpIndex & ".Jpg]"
    'delete picture is not needed- it was simply replaced with text

Next
End Sub


Private Sub ConvertSize()

' tag all text of font size <> dfSize
Dim rDcm As Range
Dim l As Long
Dim m As Long
Dim n As Long

' m = ActiveDocument.Styles("Standard").Font.Size ' german
' m = ActiveDocument.Styles("Normal").Font.Size ' english
m = 11
'get the curent normal size of the document
n = m - 13
'calculate the differencebetween the normal size of the document and the web size (12)


Set rDcm = ActiveDocument.Range
' set all paragraph marks to standard value
' and exclude them by this from processing
With rDcm.Find
.Text = Chr(13)
While .Execute
rDcm.Font.Size = m ' <<<
Wend
End With

For l = 1 To 54
Set rDcm = ActiveDocument.Range ' <<<<
    If l <= m - 2 Then   ' <<<<
        With rDcm.Find
        .Font.Size = l
            While .Execute
                rDcm.Select ' for testing only
                rDcm.Font.Size = m ' <<<<<<<<<<<<<
                rDcm.InsertBefore "[size=9]"
                rDcm.InsertAfter "[/size]"
                rDcm.Start = rDcm.End
                rDcm.End = ActiveDocument.Range.End
            Wend
        End With
    End If
    If l > m + 2 And l < m + 6 Then      ' <<<<
        With rDcm.Find
        .Font.Size = l
            While .Execute
                rDcm.Select ' for testing only
                rDcm.Font.Size = m ' <<<<<<<<<<<<<
                rDcm.InsertBefore "[size=18]"
                rDcm.InsertAfter "[/size]"
                rDcm.Start = rDcm.End
                rDcm.End = ActiveDocument.Range.End
            Wend
        End With
    End If
    If l >= m + 6 Then    ' <<<<
        With rDcm.Find
        .Font.Size = l
            While .Execute
                rDcm.Select ' for testing only
                rDcm.Font.Size = m ' <<<<<<<<<<<<<
                rDcm.InsertBefore "[size=24]"
                rDcm.InsertAfter "[/size]"
                rDcm.Start = rDcm.End
                rDcm.End = ActiveDocument.Range.End
            Wend
        End With
    End If
    
Next
End Sub