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

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