Foro Lenguajes de programacion y Bases de Datos: Lenguajes de programacion, Bases de Datos, Sistemas Operativos y recursos tecnicos avanzados.
Responder al tema
Foros de discusión
> WebMasters y Diseño Web
> Foro Lenguajes de programacion y Bases de Datos
aforoDesconectadoRegistrado: Feb 13, 2008 Mensajes: 137 
|
Asunto: Macro para Conversor Doc o Docx a BBcode
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
Adjunto: macro conversor doc-bbcode.txt
|
||||||||||
aforoDesconectadoRegistrado: Feb 13, 2008 Mensajes: 137
|
Asunto: Macro para Conversor Word a BBcode (con imagenes)
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 Europe/Madrid
|
|||||||||||