Текст макроса 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:="", ReplaceWith:="^p^p", _
Replace:=wdReplaceAll
.Find.Execute FindText:="^p^p", ReplaceWith:="^p^t^p", _
Replace:=wdReplaceAll
.Find.Execute FindText:="", ReplaceWith:="", _
Replace:=wdReplaceAll
Selection.Cut
Selection.TypeText Text:=Chr(9) & "" & Chr(13) & Chr(13) _
& Chr(9) & "" & Chr(13)
Selection.Paste
Selection.TypeText Text:=Chr(13) & Chr(13) & Chr(9) & ""
End With
Selection.HomeKey (wdStory)
count = numb
' расставляем сноски
If nazv <> 0 Then
For n = 1 To pcount
Selection.Find.Execute FindText:="", ReplaceWith:=" & ">", Replace:=wdReplaceOne
Selection.MoveRight
Selection.Find.Execute FindText:="^p^t", ReplaceWith:="^p^t", _
Replace:=wdReplaceOne
Selection.MoveRight
count = count + 1
Next
Else
For n = 1 To pcount
Selection.Find.Execute FindText:="", ReplaceWith:=" & ">", Replace:=wdReplaceOne
Selection.MoveRight
Selection.Find.Execute FindText:="^p^t", ReplaceWith:="^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 & "" & "" & Chr(13)
Selection.InsertAfter "
"
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 + ""
Selection.TypeParagraph
Selection.TypeParagraph
ActiveDocument.Bookmarks.Add Name:="table"
Selection.TypeText Text:=vbTab + ""
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:=""
Selection.InsertAfter ("")
Selection.MoveRight Unit:=wdCell
Selection.InsertBefore Text:=""
Selection.InsertAfter ("")
Selection.MoveLeft (wdCell): Selection.MoveRight (wdCell)
Selection.MoveRight (wdCharacter)
Selection.MoveDown (wdLine)
Next n
Selection.MoveLeft Unit:=wdCell
Selection.InsertBefore Text:=""
Selection.InsertAfter ("")
Selection.MoveRight Unit:=wdCell
Selection.InsertBefore Text:=""
Selection.InsertAfter ("")
Selection.Tables(1).Select
Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs
Selection.WholeStory
Set myRange = Selection.Range
With myRange
.Find.Execute FindText:="", ReplaceWith:="^t^p^p", Replace:=wdReplaceAll
.Find.Execute FindText:="", ReplaceWith:="^p^p^t^p", Replace:=wdReplaceAll
.Find.Execute FindText:="", ReplaceWith:="^t^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
xxx7>