Advertisement
tolikpunkoff

search bold, italic, Courier New text etc. & insert HTML tag

Jan 29th, 2015
523
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub InsertHTMLTags2()
  2. '
  3. ' Вставляет теги HTML
  4. '
  5. '
  6.    'Переход в начало документа
  7.    Selection.HomeKey Unit:=wdStory
  8.    
  9.     'Поиск того, что по центру
  10.    Selection.Find.ClearFormatting
  11.     With Selection.Find
  12.         .ParagraphFormat.Alignment = wdAlignParagraphCenter
  13.         .Text = ""
  14.         .Replacement.Text = ""
  15.         .Forward = True
  16.         .Wrap = wdFindContinue
  17.         .Format = True
  18.         .MatchCase = False
  19.         .MatchWholeWord = False
  20.         .MatchWildcards = False
  21.         .MatchSoundsLike = False
  22.         .MatchAllWordForms = False
  23.     End With
  24.     'Вставка соответствующих тегов
  25.    InsertTags "<center>", "</center>"
  26.     'Возврат в начало документа
  27.    Selection.HomeKey Unit:=wdStory
  28.    
  29.     'Поиск того, что выделено "Курьером"
  30.    Selection.Find.ClearFormatting
  31.     With Selection.Find
  32.         .Font.NameAscii = "Courier New"
  33.         .Text = ""
  34.         .Replacement.Text = ""
  35.         .Forward = True
  36.         .Wrap = wdFindContinue
  37.         .Format = True
  38.         .MatchCase = False
  39.         .MatchWholeWord = False
  40.         .MatchWildcards = False
  41.         .MatchSoundsLike = False
  42.         .MatchAllWordForms = False
  43.     End With
  44.     'Вставка соответствующих тегов
  45.    InsertTags "<code>", "</code>"
  46.     'Возврат в начало документа
  47.    Selection.HomeKey Unit:=wdStory
  48.    
  49.     'Поиск того, что выделено жирным
  50.    Selection.Find.ClearFormatting
  51.     With Selection.Find
  52.         .Font.Bold = True
  53.         .Text = ""
  54.         .Replacement.Text = ""
  55.         .Forward = True
  56.         .Wrap = wdFindContinue
  57.         .Format = True
  58.         .MatchCase = False
  59.         .MatchWholeWord = False
  60.         .MatchWildcards = False
  61.         .MatchSoundsLike = False
  62.         .MatchAllWordForms = False
  63.     End With
  64.     'Вставка соответствующих тегов
  65.    InsertTags "<b>", "</b>"
  66.     'Возврат в начало документа
  67.    Selection.HomeKey Unit:=wdStory
  68.    
  69.     'Поиск того, что выделено курсивом
  70.    Selection.Find.ClearFormatting
  71.     With Selection.Find
  72.         .Font.Italic = True
  73.         .Text = ""
  74.         .Replacement.Text = ""
  75.         .Forward = True
  76.         .Wrap = wdFindContinue
  77.         .Format = True
  78.         .MatchCase = False
  79.         .MatchWholeWord = False
  80.         .MatchWildcards = False
  81.         .MatchSoundsLike = False
  82.         .MatchAllWordForms = False
  83.     End With
  84.     'Вставка соответствующих тегов
  85.    InsertTags "<i>", "</i>"
  86.     'Возврат в начало документа
  87.    Selection.HomeKey Unit:=wdStory
  88.    
  89.     'Поиск того, что выделено зачеркнутым
  90.    Selection.Find.ClearFormatting
  91.     With Selection.Find
  92.         .Font.StrikeThrough = True
  93.         .Text = ""
  94.         .Replacement.Text = ""
  95.         .Forward = True
  96.         .Wrap = wdFindContinue
  97.         .Format = True
  98.         .MatchCase = False
  99.         .MatchWholeWord = False
  100.         .MatchWildcards = False
  101.         .MatchSoundsLike = False
  102.         .MatchAllWordForms = False
  103.     End With
  104.     'Вставка соответствующих тегов
  105.    InsertTags "<s>", "</s>"
  106.     'Возврат в начало документа
  107.    Selection.HomeKey Unit:=wdStory
  108.    
  109.     'Поиск того, что выделено надстрочным индексом
  110.    Selection.Find.ClearFormatting
  111.     With Selection.Find
  112.         .Font.Superscript = True
  113.         .Text = ""
  114.         .Replacement.Text = ""
  115.         .Forward = True
  116.         .Wrap = wdFindContinue
  117.         .Format = True
  118.         .MatchCase = False
  119.         .MatchWholeWord = False
  120.         .MatchWildcards = False
  121.         .MatchSoundsLike = False
  122.         .MatchAllWordForms = False
  123.     End With
  124.     'Вставка соответствующих тегов
  125.    InsertTags "<sup>", "</sup>"
  126.     'Возврат в начало документа
  127.    Selection.HomeKey Unit:=wdStory
  128.    
  129.     'Поиск того, что выделено подстрочным индексом
  130.    Selection.Find.ClearFormatting
  131.     With Selection.Find
  132.         .Font.Subscript = True
  133.         .Text = ""
  134.         .Replacement.Text = ""
  135.         .Forward = True
  136.         .Wrap = wdFindContinue
  137.         .Format = True
  138.         .MatchCase = False
  139.         .MatchWholeWord = False
  140.         .MatchWildcards = False
  141.         .MatchSoundsLike = False
  142.         .MatchAllWordForms = False
  143.     End With
  144.     'Вставка соответствующих тегов
  145.    InsertTags "<sub>", "</sub>"
  146.     'Возврат в начало документа
  147.    Selection.HomeKey Unit:=wdStory
  148.    
  149.     'Очистка условий поиска
  150.    Selection.Find.ClearFormatting
  151. End Sub
  152. Private Sub ShiftArr(ByRef arr As Variant, pos As Long, ctr As Long)
  153.     For I = 1 To ctr
  154.         For J = pos To UBound(arr) - 1
  155.             arr(J) = arr(J + 1)
  156.         Next J
  157.     Next I
  158. End Sub
  159. Private Sub InsertTags(OpenTag As String, CloseTag As String)
  160.     Dim Start_s() As Long
  161.     Dim End_s() As Long
  162.     Dim I As Long
  163.    
  164.     ctr = 0
  165.     shiftctr = 0
  166.     Selection.Find.Execute
  167.     If Not Selection.Find.Found Then Exit Sub
  168.     'Поиск необходимых интервалов
  169.    Do While Selection.Find.Found
  170.         ctr = ctr + 1
  171.         ReDim Preserve Start_s(ctr)
  172.         ReDim Preserve End_s(ctr)
  173.         Start_s(ctr) = Selection.Start
  174.         End_s(ctr) = Selection.End
  175.         Selection.Find.Execute
  176.     Loop
  177.    
  178.    
  179.     ' Удаление лишних интервалов (в которых конец текущего интервала совпадает с началом следующего)
  180.    For I = 1 To ctr - 1
  181.         Do While End_s(I) = Start_s(I + 1)
  182.             ShiftArr Start_s, I + 1, 1
  183.             ShiftArr End_s, I, 1
  184.             shiftctr = shiftctr + 1
  185.         Loop
  186.     Next I
  187.    
  188.     'Изменение размерности - удаление ненужных элементов
  189.    ReDim Preserve Start_s(UBound(Start_s) - shiftctr)
  190.     ReDim Preserve End_s(UBound(End_s) - shiftctr)
  191.    
  192.     'Вставка тегов
  193.    TagLen = Len(OpenTag) + Len(CloseTag)
  194.     AllTagLen = TagLen
  195.     For I = 1 To UBound(Start_s)
  196.         Selection.Start = Start_s(I)
  197.         Selection.End = End_s(I)
  198.         Selection.Text = OpenTag + Selection.Text + CloseTag
  199.         If I <> UBound(Start_s) Then
  200.             Start_s(I + 1) = Start_s(I + 1) + AllTagLen
  201.             End_s(I + 1) = End_s(I + 1) + AllTagLen
  202.             AllTagLen = AllTagLen + TagLen
  203.         End If
  204.     Next I
  205. End Sub
Advertisement
RAW Paste Data Copied
Advertisement