Palatynat Leocji

Kod: Zaznacz cały

    Sub BBCode()
        Application.ScreenUpdating = False
        
        ConvertItalic
        ConvertBold
        ConvertUnderline
        ConvertHyperlinks
        ConvertLists
        ConvertCenter
        
        ActiveDocument.Content.Copy
       
        Application.ScreenUpdating = True
    End Sub

    Private Sub ConvertCenter()
        ActiveDocument.Select
        Dim p As Paragraph
    
        For Each p In Selection.Paragraphs
        
            If p.Alignment = wdAlignParagraphCenter Then
                With p
                    If Len(p.Range.Text) > 1 Then
                        Set rng = ActiveDocument.Range(p.Range.Start, p.Range.End - 1)
                        rng.InsertBefore "[center]"
                        rng.InsertAfter "[/center]"
                     End If
                End With
            End If
        Next p
    End Sub
    
Private Sub ConvertLists()
    Dim l As List
    Dim p As Paragraph
    Dim curLevel As Integer
    Dim i As Integer
    Dim typeStack(10) As String ' hopefully lists aren't indented more than this
        
    curLevel = 1
        
    For Each l In ActiveDocument.Lists
        With l.Range
            For i = 1 To .ListParagraphs.Count
                Set p = .ListParagraphs(i)
                
                p.Range.InsertBefore "[*]"
                
                If p.Range.ListFormat.ListLevelNumber < curLevel Then
                    p.Range.InsertBefore "[/list" & typeStack(curLevel) & "]"
                    curLevel = curLevel - 1
                ElseIf p.Range.ListFormat.ListLevelNumber > curLevel Then
                    curLevel = curLevel + 1
                    typeStack(curLevel) = ExtractListSuffix(p.Range.ListFormat.ListString)
                    p.Range.InsertBefore "[list" & typeStack(curLevel) & "]"
                End If
            Next i
            
            Do While curLevel > 1
                .InsertAfter "[/list" & typeStack(curLevel) & "]"
                curLevel = curLevel - 1
            Loop
            
            Dim bullet As String
            
            bullet = ExtractListSuffix(l.Range.ListFormat.ListString)
            
            .InsertBefore "[list" & bullet & "]"
            .InsertAfter "[/list]" & vbCrLf
            .ListFormat.RemoveNumbers
        End With
    Next l
End Sub

Public Function ExtractListSuffix(bullet As String) As String
    bullet = Left$(bullet, 1)
    
    If InStr(1, "AI1", bullet, vbTextCompare) > 0 Then
        ExtractListSuffix = "=" & bullet
    Else
        ExtractListSuffix = ""
    End If
End Function

    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 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