Macro para Conversor Doc o Docx a BBcode 🥇 Foro Lenguajes de programacion y Bases de Datos 🗺️

Aforo · 13-02-2008

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 · 13-02-2008

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

Macro para Conversor Doc o Docx a BBcode 🥇 Foro Lenguajes de programacion y Bases de Datos 🗺️

Asunto: Macro para Conversor Doc o Docx a BBcode

Asunto: Macro para Conversor Word a BBcode (con imagenes)