Word - Makro do BBCode

W tym dziale rozmawiamy na wszystkie tematy związane z gospodarką
Locked
User avatar
piwniczak
Posts: 5595
Joined: 13 Oct 2008, o 18:01
Gadu-Gadu: 1872511
Location: Czarnolas

Word - Makro do BBCode

Post by piwniczak »

Czuj, czuj,

znalazłem swego czasu w sieci i raczej sobie chwalę takie oto makro. Radzi sobie z podstawowym formatowaniem tekstu(podkreślenia, pogrubienia itd.) i odnośnikami. Niby nic, ale jak ktoś pisze w wordzie, a potem przerabia to na bbcode, to powinien być chociaż odrobinę zadowolony ;)

Code: Select all

    'Word2BBCode-Converter v0.1
 
   Sub Word2BBCode()
     
       Application.ScreenUpdating = False
         
       ConvertItalic
       ConvertBold
       ConvertUnderline
       ConvertHyperlinks
     
       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 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
(—) diuk Krzysztof Czuguł-Chan
II Diuk Duppy, Kasztelan Czarnoleski, Pierwszy Bard Gellonii i Starosarmacji, Jaśniejąca Jurta Czarnolasu, Senator.
Książę Nowego Słońca Stowarzyszenia Błękitnej Łuny

Image
User avatar
Cudzoziemiec 1
Posts: 8782
Joined: 3 Oct 2013, o 13:19

Re: Word - Makro do BBCode

Post by Cudzoziemiec 1 »

Makra są w pytę!
User avatar
Leszke
Posts: 2612
Joined: 20 Mar 2010, o 20:51
Gadu-Gadu: 11062619
Location: Fer
Contact:

Re: Word - Makro do BBCode

Post by Leszke »

Fuuu, co za haniebne ułatwienia. Ja tam wszystko z palca, nawet przycisków bbcode nie używam. Nawet linki ręcznie przepisuję!
Leszek diuk de Ruth
User avatar
piwniczak
Posts: 5595
Joined: 13 Oct 2008, o 18:01
Gadu-Gadu: 1872511
Location: Czarnolas

Re: Word - Makro do BBCode

Post by piwniczak »

Co kto lubi ;p
(—) diuk Krzysztof Czuguł-Chan
II Diuk Duppy, Kasztelan Czarnoleski, Pierwszy Bard Gellonii i Starosarmacji, Jaśniejąca Jurta Czarnolasu, Senator.
Książę Nowego Słońca Stowarzyszenia Błękitnej Łuny

Image
Locked

Return to “Gospodarka”