Aforo, Mis Foros  
Mostrar/Ocultar
Mostrar/Ocultar Menú principal
 Foros
 Buscar
 Foro
 Inicio Grupos
 Grupos
 Opciones de Miembros Web

Mostrar/Ocultar Add

Mostrar/Ocultar Info de Usuario

Bienvenido Anónimo

Usuario
Contraseña

Lista de miembros:
Ultimo: nimmerfall
Nuevos Hoy: 0
Nuevos Ayer: 0
Total: 205

Gente en línea:
Miembros: 0
Visitantes: 17
Total: 17
Donde estan todos:
 Visitantes:
01: Estadística
02: Foro
03: Estadística
04: Foro
05: Estadística
06: Foro
07: Mi Cuenta
08: Foro
09: Foro
10: Foro
11: Foro
12: Inicio
13: Estadística
14: Foro
15: Mi Cuenta
16: Foro
17: Inicio

Administradores conectados:

No hay Administradores conectados!

Mostrar/Ocultar Alianza PequeSites

Mostrar/Ocultar Encuesta
¿Encuentras util Aforo?

Si, por el Contenido
100 %100 %100 %
Si, por el Aspecto
0 %0 %0 %
No, por el Contenido
0 %0 %0 %
No, por el Aspecto
0 %0 %0 %
No se
0 %0 %0 %
Resultados :: Encuestas

votos: 5
Comentarios: 0

Macro Para Conversor Doc O Docx A BBcode -1830- Foro: Lenguajes de programacion y Bases de Datos
Macro para Conversor Doc o Docx a BBcode
Lenguajes de programacion, Bases de Datos, Sistemas Operativos y recursos tecnicos avanzados.

Ver tema anterior :: Ver tema siguiente  
Autor Mensaje
aforo
Experto
Experto


Registrado: Feb 13, 2008
Mensajes: 132

EnvioPublicado: Mie Dic 20, 2017 1:26 pm    Asunto: Macro para Conversor Doc o Docx a BBcode Responder citando

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



macro conversor doc-bbcode.txt
 Descripción:
 Nombre de archivo:  macro conversor doc-bbcode.txt
 Tamaño de archivo:  7.69 KB
 Descargado:  9 veces
Volver arriba
Ver perfil de usuario
Mostrar mensajes de anteriores:   
Todas las horas son GMT + 1 Hora



Cambiar a:  


Puede publicar nuevos temas en este foro
No puede responder a temas en este foro
No puede editar sus mensajes en este foro
No puede borrar sus mensajes en este foro
No puede votar en encuestas en este foro
No Puedes adjuntar archivos en este foro
Tu puedes descargar archivos en este foro


Todo lo que aquí se encuentra es gratuito y esta a la disposicion de los usuarios que lo necesiten. Los comentarios son responsabilidad de los usuarios que los envian. En caso de alguna infracción, no dude en contactar con los moderadores o con el Administrador.
The logos and trademarks used on this site are the property of their respective owners
We are not responsible for comments posted by our users, as they are the property of the poster
Construyendo la web 2.0
Interactive software released under GNU GPL, Code Credits, Privacy Policy

White Theme by WebNaranja.com