Información de Usuario

Bienvenido Anonymous




Lista de miembros:
Último: grimpow
Nuevos Hoy: 0
Nuevos Ayer: 0
Total: 206

Gente OnLine:
Members: 0
Visitors: 0
Total: 0
Who Is Where:
Encuesta
¿Encuentras util Aforo?

Si, por el Contenido
100.0%

No se
0.0%

No, por el Aspecto
0.0%

No, por el Contenido
0.0%

Si, por el Aspecto
0.0%

Resultados :: Encuestas
6 votes
Macro Para Conversor Doc O Docx A BBcode -1831- Foro: Lenguajes de programacion y Bases de Datos - Foros - Aforo, Mis Foros
Foros de discusión - Lenguajes de programacion y Bases de Datos

Macro para Conversor Doc o Docx a BBcode Responder al tema


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.

'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
Attachment: macro conversor doc-bbcode.txt
Description
Nombre de archivo macro conversor doc-bbcode.txt
Filesize 7.69 KiB
Descargado 45 vece(s)

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:

'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
Todas las horas son UTC


Cambiar a: