Соколов Владимир Дмитриевич. Макросы для распараллеливания текста

Текст макроса 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.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.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.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

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

End If

End Sub

Текст макроса sod02

Sub sod02()

count = 1

numb = InputBox("с какого номера начинать")

'находим сколько в тексте Заголовков 2

Selection.HomeKey Unit:=wdStory

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)

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.TypeText Text:=vbTab + "<table>"

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

Оставить комментарий © Copyright Соколов Владимир Дмитриевич (sokolwlad@narod.ru) Размещен: 14/06/2012, изменен: 14/06/2012. 20k. Статистика. Справочник: Киберпанк		Ваша оценка:
Аннотация: Список макросов: приложение к статье "Создание параллельного текста"

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

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