attachment:word2wiki.bas of RFC_3

Attachment 'word2wiki.bas'

Attribute VB_Name = "Word2Wiki"

Sub Word2Wiki()
    
    Application.ScreenUpdating = False

    RemoveHyperlinks

    ConvertH1
    ConvertH2
    ConvertH3
    
    ConvertItalic
    ConvertBold
    ConvertUnderline
    
    ConvertLists
    ConvertTables
    
    EscapeSpecialChar
    
    ' Copy to clipboard
    ActiveDocument.Content.Copy
    
    Application.ScreenUpdating = True
End Sub

Private Sub RemoveHyperlinks()
	Dim oField As Field
	For Each oField In ActiveDocument.Fields
		If oField.Type = wdFieldHyperlink Then
			oField.Unlink
		End If
	Next
	Set oField = Nothing
End Sub

Private Sub ConvertH1()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading1)
        .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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "= "
                    .InsertAfter " ="
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                End If
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH2()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading2)
        .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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "== "
                    .InsertAfter " =="
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                End If
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH3()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading3)
        .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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "=== "
                    .InsertAfter " ==="
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                End If
                .Style = normalStyle
            End With
        Loop
    End With
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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "'''"
                    .InsertAfter "'''"
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                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
            Selection.Font.Italic = False
            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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "''"
                    .InsertAfter "''"
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                End If
            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
                    .Collapse
                    .MoveEndUntil vbCr
                End If
                                       
                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore "__"
                    .InsertAfter "__"
                Else
                    .MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
                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
            If .ListFormat.ListType = wdListBullet Then
                .InsertBefore String(.ListFormat.ListLevelNumber, " ") + "* "
            Else
                .InsertBefore String(.ListFormat.ListLevelNumber, " ") + "1. "
            End If
            
            .ListFormat.RemoveNumbers
        End With
    Next para
End Sub

Private Sub ConvertTables()
    Dim thisTable As Table
    Dim thisRow As Row
    Dim ElRango As Object
    For Each thisTable In ActiveDocument.Tables
        With thisTable
            For Each thisRow In .Rows
                thisRow.Range.InsertBefore "||"
                If thisRow.Index = .Rows.Count Then
                    'Cerramos la tabla al final
                    thisRow.Range.InsertAfter "||"
                End If
            Next thisRow
            Set ElRango = .ConvertToText(Separator:="||")
            With ElRango.Find
                .ClearFormatting
                .Text = "^p"
                With .Replacement
                    .ClearFormatting
                    .Text = ""
                End With
                .Execute Replace:=wdReplaceAll
            End With
        End With
    Next thisTable
End Sub


Private Sub EscapeSpecialChar()

    ActiveDocument.Select
    
    With Selection.Find
        .ClearFormatting
        .Text = "%"
        With .Replacement
            .ClearFormatting
            .Text = "~np~%~/np~"
        End With
        .Execute Replace:=wdReplaceAll
    End With

End Sub
Attached Files

To refer to attachments on a page, use attachment:filename, as shown below in the list of files. Do NOT use the URL of the [get] link, since this is subject to change and can break easily.
[get | view] (2011-10-20 20:44:42, 9.7 KB) [[attachment:word2wiki.bas]]
You are not allowed to attach a file to this page.