Соколов Владимир Дмитриевич : другие произведения.

Макросы для распараллеливания текста

Самиздат: [Регистрация] [Найти] [Рейтинги] [Обсуждения] [Новинки] [Обзоры] [Помощь|Техвопросы]
Ссылки:
Школа кожевенного мастерства: сумки, ремни своими руками
 Ваша оценка:

   Текст макроса Convert
  
   Sub Convert()
   '
   Selection.HomeKey Unit:=wdStory
   With Selection.Find
   .Text = "^p^p"
   .Replacement.Text = "$"
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   With Selection.Find
   .Text = "^p"
   .Replacement.Text = " "
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   With Selection.Find
   .Text = "$"
   .Replacement.Text = "^p^p"
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   With Selection.Find
   .Text = "^-"
   .Replacement.Text = ""
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   With ActiveDocument.Paragraphs
   .LineUnitAfter = 1
   .Alignment = wdAlignParagraphLeft
   .FirstLineIndent = CentimetersToPoints(0.5)
   End With
   Selection.WholeStory
   Selection.Font.Size = 12
   Selection.Font.Name = "Times New Roman"
   With Selection.Find
   .Execute FindText:=" ", Forward:=True
   While .Found = True
   .Replacement.Text = " "
   .Execute Replace:=wdReplaceAll
   Application.Run MacroName:="RepeatFind"
   Wend
   End With
   Selection.HomeKey Unit:=wdStory
   With Selection.Find
   .Text = "^p "
   .Replacement.Text = "^p"
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   Selection.HomeKey Unit:=wdStory
   With Selection.Find
   .Text = " ^p"
   .Replacement.Text = "^p"
   .Forward = True
   .Wrap = wdFindContinue
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   End Sub
  
   Текст макроса column02
  
   Sub column02()
   Dim lang As String
   ' Перед запуском необходимо выделить текст, который нужно преобразовать в таблицу
  
   Set myRange = Selection.Range
   With myRange
   .Find.Execute FindText:="^p^p", ReplaceWith:="^p", Replace:=wdReplaceAll
   .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1
   lang = InputBox("Впечатай язык" & Chr(13) & "en" & Chr(13) & "fr" & Chr(13) & "de" & Chr(13) & "ru")
   If lang = en Then .LanguageID = wdEnglishUK
   If lang = fr Then .LanguageID = wdFrench
   If lang = de Then .LanguageID = wdGerman
   If lang = ru Then .LanguageID = wdRussian
   End With
   Selection.StartOf Unit:=wdColumn
   Selection.InsertRowsAbove 1
   Selection.SelectRow
   Selection.Font.Bold = wdToggle
   Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
   Selection.Rows.HeadingFormat = True
   Select Case lang
   Case "en"
   Selection.TypeText Text:="English"
   Case "fr"
   Selection.TypeText Text:="French"
   Case "de"
   Selection.TypeText Text:="Deutsch"
   Case Else
   Selection.TypeText Text:="Русский"
   Selection.SelectColumn
   Selection.InsertRowsBelow 20
   End Select
   Selection.SelectColumn
   Selection.Columns.PreferredWidth = CentimetersToPoints(8)
   Selection.EndOf (wdColumn)
   End Sub
  
   Текст макроса splitPara
  
   Sub splitPara()
   '
   Dim col1 As Integer
   Dim col2 As Integer
   ' splitPara Макрос
   ' Макрос создан 20.01.04 sokol
   ' Перед запуском макроса нужно поместить курсор не куда-нибудь,
   ' а перед тем предложением, где намечается новый абзац
   ' при этом пробел должон быть перед курсором, а курсор после пробела
  
   Selection.Delete Unit:=wdCharacter, count:=-1
   Selection.TypeParagraph
   Selection.TypeParagraph
   Selection.StartOf Unit:=wdRow
   Selection.InsertRowsAbove 1
   Selection.MoveDown Unit:=wdLine, count:=1
   ActiveDocument.Bookmarks.Add Name:="arret"
   Selection.MoveRight Unit:=wdCell
   Selection.MoveLeft Unit:=wdCell
   Selection.Find.Execute FindText:="^p^p^?", Forward:=True, Wrap:=wdFindStop
   If Selection.Find.Found() = True Then
   Selection.StartOf Unit:=wdRow
   Selection.MoveDown Unit:=wdParagraph, count:=2, Extend:=wdExtend
   Selection.Cut
   Selection.MoveUp Unit:=wdLine, count:=1
   Selection.Paste
   Selection.MoveRight Unit:=wdCell
   ActiveDocument.Bookmarks.Add Name:="table"
   Selection.MoveDown Unit:=wdLine, count:=1
   Selection.EndOf Unit:=wdColumn, Extend:=wdExtend
   Selection.Cut
   Selection.GoTo What:=wdGoToBookmark, Name:="table"
   Selection.Paste
   Else
   Selection.GoTo What:=wdGoToBookmark, Name:="arret"
   Selection.MoveRight Unit:=wdCell
   Selection.MoveLeft Unit:=wdCharacter, count:=1
   Selection.MoveDown Unit:=wdParagraph, count:=2, Extend:=wdExtend
   Selection.Cut
   Selection.MoveUp Unit:=wdLine, count:=1
   Selection.Paste
   Selection.MoveLeft Unit:=wdCell
   ActiveDocument.Bookmarks.Add Name:="table"
   Selection.MoveDown Unit:=wdLine, count:=1
   Selection.EndOf Unit:=wdColumn, Extend:=wdExtend
   Selection.Cut
   Selection.GoTo What:=wdGoToBookmark, Name:="table"
   Selection.Paste
   End If
   Selection.EndOf Unit:=wdColumn
   Selection.EndOf Unit:=wdRow
   Selection.MoveLeft Unit:=wdCell
   col1 = Asc(Selection.Text)
   Selection.MoveRight Unit:=wdCell
   col2 = Asc(Selection.Text)
   If col1 = col2 And col1 = 13 Then
   Selection.Rows.Delete
   Selection.GoTo What:=wdGoToBookmark, Name:="arret"
   Else
   MsgBox ("А ТАМ ЧТО-ТО ЕСТЬ")
   End If
   End Sub
  
   Текст макроса remove_tail
  
   ' Удаляет таблицу начиная с данной строки и до конца
   ' Перед запуском поставить курсор в начало строки, с которой производится удаление
  
   Selection.SelectRow
   Selection.EndKey Unit:=wdColumn, Extend:=wdExtend
   Selection.Rows.Delete
   End Sub
  
   Текст макроса para
  
   Sub Para()
   '
   ' splitPara Макрос
   ' Макрос записан 06.04.04 sokol
   ' Ключ Ctrl+Alt+U
   ' разбив параграфа со значком +
  
   Selection.TypeBackspace
   Selection.TypeParagraph
   Selection.MoveUp Unit:=wdParagraph, Extend:=wdExtend
   Selection.Cut
   col = Selection.Information(wdStartOfRangeColumnNumber)
   Selection.InsertRowsAbove (1)
   Select Case col
   Case 1
   Selection.MoveLeft
   Selection.Paste
   Selection.TypeBackspace
   Selection.MoveDown (wdLine)
   Selection.MoveRight (wdCell)
   Selection.Find.Execute FindText:="+", Forward:=True, Wrap:=wdFindStop
   Selection.TypeBackspace
   Selection.TypeBackspace
   Selection.TypeParagraph
   Selection.MoveUp Unit:=wdParagraph, Extend:=wdExtend
   Selection.Cut
   Selection.MoveUp (wdLine)
   Selection.Paste
   Selection.TypeBackspace
   Case Else
   Selection.MoveLeft
   Selection.MoveRight (wdCell)
   Selection.Paste
   Selection.TypeBackspace
   Selection.MoveDown (wdLine)
   Selection.MoveLeft (wdCell)
   Selection.Find.Execute FindText:="+", Forward:=True, Wrap:=wdFindStop
   Selection.TypeBackspace
   Selection.TypeBackspace
   Selection.TypeParagraph
   Selection.MoveUp Unit:=wdParagraph, Extend:=wdExtend
   Selection.Cut
   Selection.MoveUp (wdLine)
   Selection.Paste
   Selection.TypeBackspace
   End Select
   End Sub
  
   Текст макроса chapter01
  
   Sub Chapter01()
   '
   ' определям, сколько строк в заголовке
  
   lines = InputBox("Сколько строк" & Chr(13) & "1" & Chr(13) & "2" & Chr(13) & "0, не выполнять макрос")
   Select Case lines
   Case "2"
   ' выделяем в отдельную таблицу заголовок
   Selection.SplitTable
   Selection.MoveDown
   Selection.MoveRight (wdCell): Selection.MoveLeft (wdCell)
   Selection.MoveRight
   Selection.MoveDown
   Selection.MoveRight (wdCell): Selection.MoveLeft (wdCell)
   Selection.Cut
   Selection.MoveUp
   Selection.MoveRight (wdCell): Selection.MoveLeft (wdCell)
   Selection.MoveRight
   Selection.TypeText Text:=" "
   Selection.Paste
   Selection.MoveRight (wdCell)
   Selection.MoveRight
   Selection.MoveDown
   Selection.MoveLeft (wdCell): Selection.MoveRight (wdCell)
   Selection.Cut
   Selection.Rows.Delete
   Selection.MoveUp
   Selection.MoveRight (wdCell)
   Selection.MoveRight
   Selection.TypeText Text:=" "
   Selection.Paste
   Selection.MoveDown
   Selection.SplitTable
   ' преобразуем заголовок во внетабличную форму и разделяем
   ' параллельный текст знаком "/"
   Selection.MoveUp
   Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs
   Selection.MoveLeft (wdExtend)
   Selection.Find.Execute FindText:="^p", ReplaceWith:="/", Replace:=wdReplaceOne
   Selection.MoveRight
   Selection.Style = ActiveDocument.Styles("Заголовок 2")
   Case "1"
   ' выделяем в отдельную таблицу заголовок
   Selection.SplitTable
   Selection.MoveDown
   Selection.MoveRight (wdCell): Selection.MoveLeft (wdCell)
   Selection.MoveRight
   Selection.MoveDown
   Selection.SplitTable
   ' преобразуем заголовок во внетабличную форму и разделяем
   ' параллельный текст знаком "/"
   Selection.MoveUp
   Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs
   Selection.MoveLeft (wdExtend)
   Selection.Find.Execute FindText:="^p", ReplaceWith:="/", Replace:=wdReplaceOne
   Selection.MoveRight
   Selection.Style = ActiveDocument.Styles("Заголовок 2")
   Case Else
   Selection.MoveRight
   End Select
   End Sub
  
   Текст макроса sod
  
   Sub sod()
   '
   nazv = InputBox("название главы" & Chr(13) & "0, если нет названия")
   numb = InputBox("с какого номера начинать")
   ' формируем список с соотв. тэгами
   Set myRange = Selection.Range
   With myRange
   pcount = myRange.Paragraphs.count
   .Find.Execute FindText:="^p", ReplaceWith:="^p^p", _
   Replace:=wdReplaceAll
   .Find.Execute FindText:="<p>", ReplaceWith:="^p^p", _
   Replace:=wdReplaceAll
   .Find.Execute FindText:="^p^p", ReplaceWith:="^p^t<li>^p", _
   Replace:=wdReplaceAll
   .Find.Execute FindText:="</p>", ReplaceWith:="</li>", _
   Replace:=wdReplaceAll
   Selection.Cut
   Selection.TypeText Text:=Chr(9) & "<ul>" & Chr(13) & Chr(13) _
   & Chr(9) & "<li>" & Chr(13)
   Selection.Paste
   Selection.TypeText Text:=Chr(13) & Chr(13) & Chr(9) & "</ul>"
   End With
   Selection.HomeKey (wdStory)
   count = numb
   ' расставляем сноски
   If nazv <> 0 Then
   For n = 1 To pcount
   Selection.Find.Execute FindText:="<li>", ReplaceWith:="<li><a href=" _
   & Chr(34) & nazv & Val(count) & ".html" & Chr(34) _
   & ">", Replace:=wdReplaceOne
   Selection.MoveRight
   Selection.Find.Execute FindText:="^p^t", ReplaceWith:="</a>^p^t", _
   Replace:=wdReplaceOne
   Selection.MoveRight
   count = count + 1
   Next
   Else
   For n = 1 To pcount
   Selection.Find.Execute FindText:="<li>", ReplaceWith:="<li><a href=" _
   & Chr(34) & "#" & Val(count) & Chr(34) _
   & ">", Replace:=wdReplaceOne
   Selection.MoveRight
   Selection.Find.Execute FindText:="^p^t", ReplaceWith:="</a>^p^t", _
   Replace:=wdReplaceOne
   Selection.MoveRight
   count = count + 1
   Next
   End If
   End Sub
  
   Текст макроса sod02
  
   Sub sod02()
   count = 1
   numb = InputBox("с какого номера начинать")
   'находим сколько в тексте Заголовков 2
   Selection.HomeKey Unit:=wdStory
   Do
   Selection.Find.Style = ActiveDocument.Styles("Заголовок 2")
   Selection.Find.Execute FindText:="", Forward:=True, _
   Wrap:=wdFindStop
   Selection.MoveRight (wdCharacter)
   count = count + 1
   Loop While Selection.Find.Found = True And count < 100
   ' оформление Заголовков 2 тэгами
   Selection.HomeKey Unit:=wdStory
   For n = 1 To count - 2
   Selection.Find.Style = ActiveDocument.Styles("Заголовок 2")
   Selection.Find.Execute FindText:="", Forward:=True, _
   Wrap:=wdFindStop
   verbum = Selection.Text
   If Right(verbum, 1) = Chr(13) Then Selection.MoveLeft Unit:=wdCharacter,
   Extend:=wdExtend
   Selection.InsertBefore Text:=vbTab & "<h3 align=center><a name=" & Chr(34) & n _
   & Chr(34) & "></a>" & "<font color =" & Chr(34) & "#660000" & Chr(34) & ">" & Chr(13)
   Selection.InsertAfter "</font></h3>"
   Selection.MoveRight (wdCharacter)
   Next
   End Sub
  
   Текст макроса multiTableHTML
  
   Sub multiTableHTML()
   '
   ' multiTableHTML
   ' Макрос создан 06.02.04 sokol
   ' Служит для преобразования таблицы из файла аWord'а в таблицу
   ' в кодировке HTML
  
   Dim numwin, row As Integer, col As Integer, cell As Integer, n As Integer, m As Integer
  
   Selection.Tables(1).Select
   numwin = ActiveDocument.FullName
   row = Selection.Information(wdEndOfRangeRowNumber)
   col = Selection.Information(wdEndOfRangeColumnNumber)
   Selection.Cut
   Selection.TypeParagraph
   Selection.TypeParagraph
   Selection.TypeText Text:=vbTab + "<table>"
   Selection.TypeParagraph
   Selection.TypeParagraph
   ActiveDocument.Bookmarks.Add Name:="table"
   Selection.TypeText Text:=vbTab + "</table>"
   Documents.Add
   Selection.Paste
   Selection.MoveUp Unit:=wdLine
   Selection.StartOf Unit:=wdColumn
   Selection.EndOf Unit:=wdRow
   For n = 1 To row - 1
   Selection.MoveLeft Unit:=wdCell
   Selection.InsertBefore Text:="<tr><td>"
   Selection.InsertAfter ("</td>")
   Selection.MoveRight Unit:=wdCell
   Selection.InsertBefore Text:="<td>"
   Selection.InsertAfter ("</td></tr>")
   Selection.MoveLeft (wdCell): Selection.MoveRight (wdCell)
   Selection.MoveRight (wdCharacter)
   Selection.MoveDown (wdLine)
   Next n
   Selection.MoveLeft Unit:=wdCell
   Selection.InsertBefore Text:="<tr><td>"
   Selection.InsertAfter ("</td>")
   Selection.MoveRight Unit:=wdCell
   Selection.InsertBefore Text:="<td>"
   Selection.InsertAfter ("</td></tr>")
   Selection.Tables(1).Select
   Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs
   Selection.WholeStory
   Set myRange = Selection.Range
   With myRange
   .Find.Execute FindText:="<tr>", ReplaceWith:="^t<tr>^p^p", Replace:=wdReplaceAll
   .Find.Execute FindText:="</tr>", ReplaceWith:="^p^p^t</tr>^p", Replace:=wdReplaceAll
   .Find.Execute FindText:="<td>", ReplaceWith:="^t<td>^p", Replace:=wdReplaceAll
   .Find.Execute FindText:="^p^p^p", ReplaceWith:="^p^p", Replace:=wdReplaceAll
   End With
   Selection.WholeStory
   Selection.Cut
   ActiveWindow.Close (DoNotSaveChanges)
   Documents(numwin).Activate
   Selection.GoTo What:=wdGoToBookmark, Name:="table"
   Selection.Paste
   Selection.MoveRight
   ActiveDocument.Save
   Set dlg = Dialogs(wdDialogEditReplace)
   End Sub
  
 Ваша оценка:
Связаться с программистом сайта.

Новые книги авторов СИ, вышедшие из печати:
О.Болдырева "Крадуш. Чужие души" М.Николаев "Вторжение на Землю"

Как попасть в этoт список

Кожевенное мастерство | Сайт "Художники" | Доска об'явлений "Книги"