Макрос для копирования текста word - Word и Excel - помощь в работе с программами

Вот так можно поместить содержимое определённых страниц из одного документа в другой (в данном случае помещается всё содержимое первой страницы одного документа в другой):

Visual Basic

Sub P2()
With ActiveDocument
    Documents(1).Range = .Range(Start:=.ActiveWindow.Panes(1).Pages(1).Breaks(1).Range.Start, _
        End:=.ActiveWindow.Panes(1).Pages(2).Breaks(1).Range.Start - 1)
End With
End Sub

Есть 2 вида разрывов страниц:

вставленный вручную (Word 2003: Вставка — Разрыв… — новую страницу или новую колонку);
устанавливаемый программой Word (его видно между страницами в режиме просмотра документа Обычный режим).

Каждая страница в документе Word всегда имеет Разрыв страницы: если ручной не установлен, то есть естественный разрыв страницы, если ручной установлен, то ручной есть.
Этот Разрыв страницы в VBA всегда занимает положение в начале страницы (хотя визуально в программе Word разрыв страницы, естественно, находится в самом конце страницы).
Основываясь на том, что Разрыв страницы по подсчётам VBA всегда находится вначале страницы и имеет свойство Range, можно определить диапазон, находящийся на страницах.

ActiveWindow — чтобы понять, что это такое, нужно сделать следующее:

Word 2003

— Окно — Новое. В результате на Панели задач Windows (в самом низу монитора) появится ещё одна кнопка документа: т.е. один и тот же документ может быть открыт несколько раз. Зачем это надо? Я этим никогда не пользовался за всё время работы с Word. Могу предположить, зачем это надо, — чтобы просматривать документ в разных местах одновременно: т.е. в одном окне можем смотреть начало документа, а в другом окне — конец документа и сравнивать что-то в них.

Panes — чтобы понять что такое Panes:

Word 2003

— вставьте сноску (Вставка — Ссылка — Сноска… — Вставить). В результате в документ будет вставлена сноска. Далее: Вид — Обычный — Вид — Сноски. В результате внизу появилось что-то — это и есть Pane: т.е. в данной ситуации у нас два Pane: первый Pane — это собственно документ, а второй Pane — это что-то, связанное со сносками.
У документа всегда есть один Pane — это собственно сам документ. И этот Pane имеет порядковый номер всегда 1 (Panes(1)).

Итак строку кода:

Visual Basic

1 2	With ActiveDocument .ActiveWindow.Panes(1).Pages(1).Breaks(1).Range.Start

можно прочитать так:
Активный документ — Активное окно — первая Pane — первая страница — первый разрыв на странице (кроме разрыва страницы на странице может быть ещё разрыв раздела) — место в документе, занимаемое этим разрывом страницы (или порядковый номер символа, находящегося вначале страницы. Порядковый номер считается сначала документа) — Start — начало разрыва страницы (начало и конец у разрыва страницы равны).

Источник

I have a macro that I use to past text into letters that I write which looks like this:

Sub CT1()

Dim myText As String

'Insert text with custom font
myText = "Revisions are necessary"
Selection.Font.Name = "Times New Roman"
Selection.Font.Size = 12
Selection.Font.Bold = False
Selection.TypeText (myText)

The problem I have is that when I have a long text string, this method gets ugly because I have a very long string that is difficult to read in VBA.

What I want to do is create a form with text boxes to hold my text and I want the macro to get the text from the text box and past it the same way it would using the above macro. This will make it easier for me to edit the text, however I don’t know how to execute my vision.

Please help me write this macro.

0m3r

12.2k15 gold badges33 silver badges70 bronze badges

asked May 15, 2015 at 21:13

You will need to use a Userform.

You will need to insert a UserForm into your Project and then add two CommandButtons and a TextBox. See below;

What you can do then is press «F7» to get to the code and place the following there:

Private Sub CommandButton1_Click()
'This is the Insert Button
Dim myText As String

'Assigning the Text in the Text box
myText = UserForm1.TextBox1.Text

'Use a With Statement to reduce repetitive typing
With Selection
    .Font.Name = "Times New Roman"
    .Font.Size = 12
    .Font.Bold = False
    .TypeText (myText)
End With

End Sub

Private Sub CommandButton2_Click()
'This is the Exit Button

'Ends the Process
End
End Sub

The Text will be inserted at your current cursor position.

What you then do is Call UserForm1 from your CT1 Sub:

 Sub CT1()
 UserForm1.Show

answered Nov 17, 2015 at 10:40

Источник

Sub Процедура1()
Dim Начало As Long, Конец As Long
Dim Источник As Word.Document, Назначение As Word.Document
Const ПутьДокумента As String = "C:Documents and SettingsПользовательРабочий столНазначение.doc"
Set Источник = ActiveDocument
With Источник.Content.Find
    .Text = "В С Т А Н О В И В:"
    .MatchPrefix = True
    .MatchSuffix = True
    If .Execute = True Then
        Начало = .Parent.End + 1
        With Источник.Content.Find
            .Text = "а.м."
            .MatchPrefix = True
            .MatchSuffix = True
            If .Execute = True Then
                Конец = .Parent.Start - 1
            Else
                MsgBox "Слова: а.м. нет в документе.", vbCritical
                Exit Sub
            End If
        End With
    Else
        MsgBox "Слова: В С Т А Н О В И В: нет в документе.", vbCritical
        Exit Sub
    End If
End With
Set Назначение = Documents.Open(FileName:=ПутьДокумента)
Назначение.Range(Start:=0, End:=0) = Источник.Range(Start:=Начало, End:=Конец)
End Sub

Источник

This tutorial explains how you can copy content from one word document and paste it to another word document with VBA. This is one of the most common ask from stakeholder when you need to create a new MS word document daily or weekly which is a subset of the master document. If you do it manually, it’s a tedious task and chances of having error would be high. In the automated world we aim to automate our repetitive tasks as much as possible. As a request it looks easy but it’s a bit complex as you need to handle MS word from Excel and need to give instructions to system via VBA about the changes and interactivity you want to implement.

Table of Contents

Copy all headings to another document

The program below copies each text which is formatted in Heading 1 style and paste to a new word document. You need to make changes in the lines of code highlighted in red.

Sub CopyfromWord()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest" 
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord As String
    Dim result As String
    FindWord = ""
    
    'Style
    mystyle = "Heading 1"
    
    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
    ' Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
    End With
    
    ' Execute find method
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    ' Store Selected text
    result = wrdDoc.ActiveWindow.Selection.Text
    
    ' Check if result contains non-blank text
    If Len(result) > 1 Then
    
    ' -------------------------------------------------------------
    ' Loop through multiple find content (Find All functionality)
    ' -------------------------------------------------------------

    While wrdDoc.ActiveWindow.Selection.Find.Found
    wrdDoc.ActiveWindow.Selection.Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
   Wend
   
   ' If style not found
    Else
        MsgBox "Text Not Found"
    End If
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
End Sub

How to use the above program

Open Excel Workbook
Press ALT + F11 shortcut key to open visual basic editor (VBE)
To insert a module, go to Insert > Module
Paste the complete VBA script below
Specify the path of folder in myPath variable. It is the folder location where your input word document file is stored. Make sure to mention backward slash at the end.
myPath = "C:UsersDELLDocumentsTest"
Specify file name of your input MS Word document
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
File name you wish to have in your output file. New word doc will be saved with this name.
myPath1 = myPath & "newdoc1.docx"
Type word(s) you want to seach in Find box. Keep it blank if you want to search by style only. FindWord = "".
Specify style specific to your word document in mystyle = "Heading 1".

How this program works

In this section we broken down the code into multiple snippets to make you understand how it works.

1. First we are closing word documents if any of them is already opened. It is to avoid conflict interacting Excel with Word. This is a useful technique in terms of error handling in the code as sometimes code may crash because of multiple word documents being opened at the same time.

    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If

2. In this section of code we are opening the input word document.

    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")

3. Here we are adding a new word document in which we want to copy the content.

    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

4. User need to mention the word or style he/she wants MS Word to look for.

    ' Text you want to search
    Dim FindWord As String
    Dim result As String
    FindWord = ""
    
    'Style
    mystyle = "Heading 1"

5. This part of the VBA code refers to Find feature in MS Word. Many of us enable this functionality by hitting CTRL + F shortcut key. While ... Wend is an alternative of Do While Loop. Here it is used to find all the words which are formatted as ‘Heading 1’ style. It is to find all the searched results in iterative manner. After copying the text it goes to the last filled content in the output doc and then paste the content after that.

    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
    End With
    
    ' Execute find method selects the found text if found
    wrdDoc.ActiveWindow.Selection.Find.Execute
    
    While wrdDoc.ActiveWindow.Selection.Find.Found
    wrdDoc.ActiveWindow.Selection.Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
   Wend

6. Last thing which is extremely important is to save the files and close MS Word application. We are closing the input file without saving any changes but the output file is saved with all the changes we made.

    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0

Copy text from one word document to already created word document

Suppose you don’t want to create a new word document. Instead you wish to save it in the existing word doc you have. Assuming name of the output file is newdoc1.docx.

Replace this line of code Set newwrdDoc = wrdApp.Documents.Add with the code below.

    Set newwrdDoc = wrdApp.Documents.Open(myPath & "newdoc1.docx")

If you wish to save the file with the new name you can change in this line of code.

myPath1 = myPath & "newdoc1_updated.docx"

Find specific text and then copy the next 3 words or characters

Specify the word(s) you want to find in FindWord = "Text you wish to search" and make style blank in
mystyle = ""

Replace this line of code wrdDoc.ActiveWindow.Selection.Copy with the code below.

Next 3 words

    lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=3, Extend:=wdExtend
    wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
    lngEnd = wrdDoc.ActiveWindow.Selection.Start
    wrdDoc.Range(lngStart, lngEnd).Copy
    wrdDoc.ActiveWindow.Selection.EndOf

Next 3 Characters

   lngStart = wrdDoc.ActiveWindow.Selection.End
    wrdDoc.Range(lngStart, lngStart + 3).Copy

If there are some spaces you may find the code extracts only 2 characters (or words) rather than 3 so you can increase the number from 3 to 4 in the code above

Copy text between two words

Suppose you wish to pull all the text between two words (or headings). In the code below you can specify the words in FindWord1 and FindWord2 variables.

Sub CopyBetweenTexts()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String
    FindWord1 = "Steps : PD Calibration"
    FindWord2 = "Test2 Steps : PD Calibration"
    
    'Style
    mystyle = ""

    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
     ' Move your cursor to the start of the document
    wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory

    'Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
             If .Execute = False Then
            MsgBox "'Text' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Locate after the ending paragraph mark (beginning of the next paragraph)
        ' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
        
        ' Starting character position of a selection
        lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
        .Text = FindWord2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Style = mystyle
        If .Execute = False Then
            MsgBox "'Text2' not found.", vbExclamation
            Exit Sub
        End If
        lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
    End With
    
  'Copy Selection
  wrdDoc.Range(lngStart, lngEnd).Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
   
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
    
End Sub

Find multiple different texts and copy in loop

If you wish to extract content between a couple of texts in iterative manner and then copy them one by one in another word document.
Here we assume texts are stored in column B starting from cell B3. See the image below.

Sub CopyBetweenTexts2()
    
   ' Objects
    Dim wrdApp, objWord As Object
    Dim wrdDoc, newwrdDoc As Object
    Dim myPath As String, myPath1 As String
    Dim numberStart As Long
    Dim Rng, srchRng As Word.Range

   ' Close MS Word if it's already opened
    On Error Resume Next
     Set objWord = GetObject(, "Word.Application")
     If Not objWord Is Nothing Then
            objWord.Quit SaveChanges:=0
            Set objWord = Nothing
    End If
    
    'Open MS Word
    Set wrdApp = CreateObject("Word.Application")
        wrdApp.Visible = True
        
    ' Folder Location
    myPath = "C:UsersDELLDocumentsTest"
    
    ' Input File
    Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
    
    ' Output File
    Set newwrdDoc = wrdApp.Documents.Add
    myPath1 = myPath & "newdoc1.docx"

    ' Text you want to search
    Dim FindWord1, FindWord2 As String
    Dim result As String
    
    ' Find last used cell in column B
    Dim last As Double
    With ActiveSheet
        last = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    ' Loop through column B
    j = last - 2
    For i = 1 To j
    
    FindWord1 = Cells(2 + i, 2).Value
    FindWord2 = Cells(3 + i, 2).Value
    
    'Style
    mystyle = ""

    'Defines selection for Word's find function
    wrdDoc.SelectAllEditableRanges
    
     ' Move your cursor to the start of the document
    wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory

    'Find Functionality in MS Word
    With wrdDoc.ActiveWindow.Selection.Find
        .Text = FindWord1
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If mystyle <> "" Then
        .Style = mystyle
        End If
             If .Execute = False Then
            MsgBox "'Text' not found.", vbExclamation
            Exit Sub
        End If
        
        ' Locate after the ending paragraph mark (beginning of the next paragraph)
        ' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
        
        ' Starting character position of a selection
        lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
        .Text = FindWord2
        .Replacement.Text = ""
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Style = mystyle
        If .Execute = False Then
            MsgBox "'Text2' not found.", vbExclamation
            Exit Sub
        End If
        lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
    End With
    
  If (i = j) Then
  wrdDoc.ActiveWindow.Selection.EndOf
  wrdDoc.ActiveWindow.Selection.EndKey unit:=wdStory
  lngEnd = wrdDoc.ActiveWindow.Selection.End
  End If
    
  'Copy Selection
  wrdDoc.Range(lngStart, lngEnd).Copy
    
    'Activate the new document
    newwrdDoc.Activate
    
    'New Word Doc
    Set Rng = newwrdDoc.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.Paste
    Next i
    
   'Word Document
   wrdDoc.Activate
   wrdDoc.ActiveWindow.Selection.Find.Execute
   
    'Close and don't save application
    wrdDoc.Close SaveChanges:=False
    
    'Save As New Word Document
    newwrdDoc.SaveAs myPath1
    newwrdDoc.Close SaveChanges:=False
    
    'Close all word documents
    wrdApp.Quit SaveChanges:=0
    
    'Message when done
    MsgBox "Task Accomplished"
    
End Sub

Find Text and Replace All

Suppose you want to find a specific text and replace it with some text. If a text has more than 1 occurence, it should be dealt with. In other words, Replace All functionality should be enabled. Here we are replacing it in the output document after copying from input word document. Add the code below after line Next i . Specify text in .Text = and .Replacement.Text =

   'Replace All Name
    newwrdDoc.Activate
    With newwrdDoc.ActiveWindow.Selection.Find
        .Text = "Text 1"
        .Replacement.Text = "Text 2"
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    newwrdDoc.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll

About Author:

Deepanshu founded ListenData with a simple objective — Make analytics easy to understand and follow. He has over 10 years of experience in data science. During his tenure, he has worked with global clients in various domains like Banking, Insurance, Private Equity, Telecom and Human Resource.

Источник

Аннотация: Примеры работы с текстовыми документами: работа с буфером, трансляция символов, работа с текстовыми базами данных.

Программная работа с документами Word

Текстовый документ — один из основных видов документов, наиболее привычный для обычного пользователя. Стандартные возможности Word при работе с такими документами многогранны, тем не менее, в каждой конкретной ситуации возникает необходимость выполнять специфические операции над тем или иным документом. Программная работа с документами Word хотя и проста, но требует некоторых навыков. Приведу фразу из письма одного из читателей, обратившегося на днях ко мне с просьбой помочь ему в решении задачи, возникшей перед ним при работе с документом Word. Он пишет:

Ни по одной книжке по VBA я даже близко не могу понять, как писать макросы для обработки текстовых документов

Конечно, опытные программисты не примут эту фразу всерьез.

Примеры работы с текстовыми документами

Чтобы эффективно работать с текстовыми документами, необходимо хорошо знать объекты Word, описанные в предыдущей лекции. Без знания основных коллекций, задающих структуру документа, — абзацев, предложений, слов, символов, без знания объектов Range и Selection, не обойтись. С другой стороны необходимо владение встроенными функциями VBA для работы со строковыми переменными. Умение работы с объектами Word и функциями VBA позволяет достаточно просто решать самые разнообразные задачи, возникающие в ходе работы с текстовыми документами. В предыдущей лекции, где я рассматривал объекты Word, я приводил большое число примеров, иллюстрирующих работу с теми или иными объектами. Но там рассмотрение шло от «объектов», теперь же я хочу идти от «задач», которые могут возникать при работе с текстовыми документами. Давайте перейдем к рассмотрению некоторых примеров.

Вариации на тему «буфера»

Я начну с самой простой задачи — написания собственных макросов, реализующих известные функции Word «Copy» и «Paste». Пожалуй, при создании любого из документов Word кнопки, реализующие эти функции, нажимаются чаще всего. Всегда полезно понимать, как реализованы стандартные функции, а, кроме того, иногда желательно иметь собственную реализацию, отличающуюся от стандартной. В разумности такого подхода можно будет убедиться даже на этом простом примере.

Копирование текста

Вначале рассмотрим совсем простой случай и напишем два макроса, первый из которых запоминает выделенный текст в буфере, а второй — вставляет текст из буфера в точку вставки, заданную курсором. Для решения задачи необходимо понимать три вещи:

как представить буфер,
как запомнить в буфере выделенный текст,
как текст из буфера переносится в точку вставки.

Каждая из этих задач решается в одну строчку. Поэтому давайте взглянем на программный текст, а затем я приведу краткий комментарий:

'Текстовый буфер задается обычной строкой
Public TextBuffer As String

Public Sub CopyText()
	'Этот макрос копирует выделенный текст в буфер
	TextBuffer = Selection.Text
End Sub

Public Sub PasteText()
	'Этот макрос выполняет операцию, обратную копированию
	'Текст из буфера вставляется в точку, заданную курсором
	Selection.Text = TextBuffer
End Sub

Листинг
2.1.

Как видите, буфер задается обычной текстовой переменной VBA. Выделенный текст задается свойством Text объекта Selection. Точка вставки, заданная курсором, также представляется объектом Selection.

Несмотря на простоту этих макросов, я часто использую их наряду со стандартными реализациями Copy — Paste. Дело в том, что при вставке скопированного текста в новое местоположение всегда возникает вопрос, как должен быть отформатирован вставляемый текст (шрифт, размер, курсив и другие свойства), — должно ли использоваться форматирование копируемого текста или форматирование, определяемое контекстом точки вставки. В стандартной реализации при вставке используется форматирование копируемого текста, но во многих случаях предпочтительным является контекст точки вставки. В тех ситуациях, когда необходимо вставлять только текст, сохраняя особенности стиля точки вставки, наши простые макросы предпочтительнее стандартной реализации.

Копирование текста и шрифта

Я рассмотрю сейчас, как можно копировать в буфер не только текст, но и его шрифт. Макросы, которые будут построены, вряд ли стоит использовать на практике, но с учебной точки зрения их рассмотрение представляется полезным. Если необходимо сохранить в буфере не только текст, но и характеристики шрифта, которым этот текст записан, то буфер уже не может быть представлен простой строковой переменной. В подобных случаях, когда необходимо запоминать разнообразные характеристики выделенной области текстового документа, зачастую полезно определить пользовательский тип, задающий требуемые характеристики. Эти общим приемом я и воспользуюсь в данной достаточно простой ситуации. Вот как выглядит теперь определение буфера:

'Буфер, сохраняющий текст и шрифт
Public Type TextAndFont
	 BufText As String
	 BufFont As Font
End Type

Public TaFBuffer As TextAndFont

Листинг
2.2.

Как видите, вначале дано определение пользовательского типа, содержащего два поля для хранения текста и объекта класса Font. Сам буфер описывается переменной введенного типа TextAndFont.

Чуть усложняются и тексты макросов, решающие задачу копирования и вставки:

Public Sub CopyTextAndFont()
	'Этот макрос копирует выделенный текст и шрифт в буфер
	Set TaFBuffer.BufFont = Selection.Font
	TaFBuffer.BufText = Selection.Text
End Sub

Public Sub PasteTextAndFont()
	'Этот макрос выполняет операцию, обратную копированию
	
		'К сожалению, такое присваивание свойства Font
		'для объекта Selection не проходит?!
		'Selection.Font = TaFBuffer.BufFont
	'Но можно присвоить свойства объекту Font
	Selection.Font.Name = TaFBuffer.BufFont.Name
	Selection.Font.Bold = TaFBuffer.BufFont.Bold
	Selection.Font.Italic = TaFBuffer.BufFont.Italic
	Selection.Font.Size = TaFBuffer.BufFont.Size
	'Текст из буфера с указанными параметрами шрифта	
	'вставляется в точку, заданную курсором.
	Selection.Text = TaFBuffer.BufText
End Sub

Листинг
2.3.

Первый из этих макросов не нуждается в особых комментариях. Объект Selection имеет наряду со свойством Text и свойство Font, возвращающее объект данного класса. Эти свойства и передаются в поля переменной, определяющей наш буфер. Казалось бы, что второй макрос должен быть симметричным, поскольку необходимо выполнить такое же присваивание, но в другую сторону. Однако объекты Range и Selection обладают одной особенностью, — их свойству Font нельзя присвоить объект класса Font. Можно, однако, задать характеристики этого объекта, чем я и воспользовался.

Повторяю, этот пример интересен скорее, как программистский прием. Практического значения он не имеет, так как стандартная реализация Copy — Paste решает эту же задачу, обладая при этом дополнительными преимуществами. Заметьте, что эта пара макросов неявно предполагает, что выделенный текст записан одним шрифтом, параметры которого постоянны для всего текста. Если же это не так, то будут использованы параметры конечного участка текста. В то же время стандартная реализация при вставке текста будет сохранять все изменения шрифта выделенного участка текста, что, конечно, представляется более разумным.

Копирование объекта

До сих пор я говорил о копировании выделенного текста. И делал я это потому, что копирование текста это наиболее типичная задача, возникающая при работе с документом Word. Однако понятно, что реально в документе Word выделяется не текст, а некоторая область документа, — объект Range, если говорить в терминах объектов. Я напомню, что объект Range может быть устроен столь же сложно, как и сам документ, и, наряду с текстом, содержать самые разные компоненты, например, рисунки. Стандартная реализация Copy — Paste фактически работает именно с объектом Range. Давайте напишем и мы такую же реализацию. Вот как задается буфер и макросы в подобной реализации:

'Буфер, позволяющий сохранять объект
Public ObjectBuffer As Range

Public Sub CopyObject()
	'Этот макрос копирует выделенный объект в буфер
	Set ObjectBuffer = Selection.Range
End Sub

Public Sub PasteObject()
	'Этот макрос выполняет операцию, обратную копированию.
	'Объект из буфера вставляется в точку, заданную курсором.
	'Поскольку объект может быть сложным и содержать, например,
	'рисунки, то используется техника копирования через стандартный буфер!
	 ObjectBuffer.Copy
	 Selection.PasteSpecial
	 
End Sub

Листинг
2.4.

Реализация макросов в этом случае даже более проста, чем в предыдущем случае. Однако, заметьте, она построена на использовании возможностей стандартного буфера и таких мощных методов работы с ним, как методы Copy и PasteSpecial. Стоит обратить внимание на то, что побочным эффектом этой реализации является изменение содержимого буфера. Конечно, можно было бы запоминать и восстанавливать его содержимое, но вряд ли стоит этим заниматься, поскольку данная реализация вряд ли имеет преимущества по сравнению со стандартной реализацией. Так что из трех пар приведенных макросов, практическую пользу может иметь самая первая и самая простая пара макросов, работающих с простым текстом.

Источник