Microsoft Word:

  Visual Basic for Application.
  Вопросы и Ответы. Советы.
Меню Word | F.A.Q. | Макросы (VBA)

Rambler's Top100


Counter CO.KZ

    [1] [2]

  1. Как отключить обновление экрана? 17.04.2012
  2. Как принудительно обновить экран в Word'е ? 17.04.2012
  3. Как программно "назначить" клавишам свой собственный макрос ? (горячие клавиши для макроса) 17.04.2012
  4. Как программно определить нажата ли клавиша CAPS LOCK и NUM LOCK ? 17.04.2012
  5. Как программно сменить раскладку клавиатуры ? 25.11.2014
  6. Как программно отключить вывод предупреждающего сообщения о наличии макросах в Word 97 ? 18.04.2012
  7. Как определить удалён или нет об'ект, который был создан программно ? 19.04.2012
  8. Как определить версию приложения ? 19.04.2012
  9. Как изменить внешний вид курсора мышки ? 19.04.2012
  10. Как с помощью Word'их функций вычислить сумму, количество, а также среднее, минимальное и максимальное значение - выделенных ячеек таблицы ? 21.04.2012
  11. Как в Word'е можно сохранить необходимые данные (в т.ч. и значения переменных) даже после закрытия документа ? 26.04.2014
  12. Как открыть документ так, чтобы он был невидим на экране ? 13.11.2014
  13. Как проверить открыт ли документ ? NEW 03.08.2016
  14. Как импортировать всю графику из папки в новый документ ? NEW 30.11.2015
  15. Как проверить запущено ли нужное приложение, например, Excel или Калькулятор ? NEW 06.07.2016
  16. Как получить список главных окон всех запущенных приложений ? NEW 07.07.2016
    [1] [2]


  • Ответ :

    Для того, чтобы в Word/Excel отключить обновление экрана, достаточно использовать свойство ScreenUpdating, т.е.
  • Application.ScreenUpdating = False
    'Здесь должен быть код Вашей программы.
    Application.ScreenUpdating = True
    причём в Word, в отличии от Excel, допустим и такой вариант :
    ScreenUpdating = False
    'Здесь должен быть код Вашей программы.
    ScreenUpdating = True

  • Ответ :

    Если на время выполнения макроса, Вы отключаете обновление экрана (см. выше), но у Вас возникла необходимость в принудительном обновлении экрана, то используйте метод ScreenRefresh об'екта Application, т.е.
  • Application.ScreenRefresh

  • Ответ :

    Для того, чтобы в Word'е программно "назначить" клавишам свой собственный макрос, можно использовать нижеопубликованный вариант, разумеется, указав имя своего макроса, а также коды необходимых клавиш.

    Предположим, что в неком документе, в стандартном модуле, существует макрос HotKeyMacro и нам необходимо, чтобы после открытия этого документа, нажатие клавиш CTRL + R приводило к его вызову, а после закрытия, всё возвращалось на круги своя, то откройте этот документ, скопируйте в стандартный модуль весь нижеопубликованный код, а затем, сохраните изменения.
  • Public Sub AutoOpen()
        KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyControl, wdKeyR), KeyCategory:=wdKeyCategoryMacro, Command:="HotKeyMacro"
    End Sub

    Public Sub AutoClose()
        KeyBindings.Key(KeyCode:=BuildKeyCode(wdKeyControl, wdKeyR)).Clear
    End Sub

    Public Sub HotKeyMacro()
        MsgBox "Это просто тест", vbInformation
    End Sub
    или так :
    Sub AutoOpen()
        KeyBindings.Add wdKeyCategoryMacro, "HotKeyMacro", (wdKeyControl + wdKeyR)
    End Sub

    Sub AutoClose()
        KeyBindings.Key(wdKeyControl + wdKeyR).Clear
    End Sub

    Sub HotKeyMacro()
        MsgBox "Это просто тест2", vbInformation
    End Sub

  • Ответ :

    Для того, чтобы с помощью VBA, определить нажата ли клавиша CAPS LOCK и NUM LOCK можно использовать свойства CapsLock и NumLock об'екта Application
  • If Application.CapsLock = True Then
       MsgBox "Клавиша CAPS LOCK нажата"
    Else
       MsgBox "Клавиша не нажата"
    End If
    If Application.NumLock = True Then
       MsgBox "Клавиша NUM LOCK нажата"
    Else
       MsgBox "Клавиша не нажата"
    End If

  • Ответ :

    Для того, чтобы с помощью VBA, сменить раскладку клавиатуры, достаточно воспользоваться методом Keyboard об'екта Application и указать ID необходимого языка, например :
  • Application.Keyboard wdRussian
    
    Application.Keyboard wdEnglishUS
    Если же Вам потребуется определить текущую раскладку, только для Русск. и Английск., то :
    If (Application.Keyboard And wdRussian) = wdRussian Then
        MsgBox "RU"
    Else
        MsgBox "EN"
    End If
    Для других языков, разумеется необходимо указать их константы, полный перечень которых Вам предоставит Word.WdLanguageID
  • Ответ : Актуально для MS Word 97

    Для того, чтобы в Word 97 отключить вывод предупреждающего сообщения о наличии макросах, достаточно в меню Сервис выбрать команду Параметры, выделить закладку Общие и снять "флажок" Защита от вирусов в макросах.

    Если тоже самое нужно осуществить с помощью VBA, то :
  • Options.VirusProtection = False

  • Ответ :

    Для того, чтобы определить был ли удалён об'ект (вручную или программно), созданный с помощью VBA, достаточно использовать свойство IsObjectValid
  • Public objTable As Word.Table

    Public Sub CreateWordObject()
        Set objTable = ThisDocument.Tables.Add(Range:= _
        ThisDocument.Sections.Add.Range, NumRows:=10, NumColumns:=3)

        objTable.Select 'исключительно для примера
        'objTable.Delete
    End Sub
    Предположим, что после создания таблицы (см. макрос CreateWordObject), эта таблица могла быть удалена (вручную или программно) и нам необходимо проверить существует этот об'ект или нет :
    Public Sub IsWordObjectValid()
        If IsObjectValid(objTable) = True Then
           MsgBox "Об'ект существует", vbInformation
        Else
           MsgBox "Об'ект удалён", vbCritical
        End If
    End Sub
    Комментарий : В данном примере, таблица, разумеется, используется только в демонстрационных целях.
  • Ответ :

    Для того, чтобы в Word/Excel определить версию приложения, достаточно использовать свойство Version об'екта Application
  • Select Case Val(Application.Version)
        Case 8:    iVersion = "97"
        Case 9:    iVersion = "2000"
        Case 10:   iVersion = "XP"
        Case 11:   iVersion = "2003"
        Case 12:   iVersion = "2007"
        Case 14:   iVersion = "2010"
        Case 15:   iVersion = "2013"
        Case Else: iVersion = "Неизвестно ..."
    End Select
    MsgBox "Работа идёт в Microsoft Word " & iVersion
    Dim iVersion As Variant
    iVersion = Choose(Val(Application.Version) - 7, "97", "2000", "XP", "2003", "2007", "2010", "2013")

    If Not IsNull(iVersion) Then
       MsgBox "Работа идёт в Microsoft Word " & iVersion
    Else
       MsgBox "Неизвестная науке версия Word"
    End If

  • Ответ :

    Для того, чтобы в Word'е изменить курсор мышки, можно использовать свойство Cursor об'екта System

  • System.Cursor = wdCursorWait 'wdCursorNorthWestArrow 'wdCursorIBeam
    For iCount = 1 To 100000
        StatusBar = "Счётчик " & iCount
        'Application.StatusBar = "Счётчик " & iCount
    Next
    'System.Cursor = wdCursorNormal 'по умолчанию

  • Ответ :

    Для того, чтобы с помощью Word'их функций вычислить сумму, количество чисел, а также среднее, минимальное и максимальное значение - выделенных ячеек таблицы, можно использовать следующий код, разумеется, предварительно выделив нужные ячейки таблицы (или всю таблицу целиком)
  • Public Sub CreateInformationInTable()
    
        Dim objDoc As Word.Document
        Dim objSel As Word.Selection
        Dim objBookmark As Word.Bookmark
        Dim objTable As Word.Table, iAddress$
    
        Set objSel = Selection 'Application.Selection
    
        If objSel.Information(wdWithInTable) = True Then
           Application.ScreenUpdating = False
    
           Set objDoc = ActiveDocument
           Set objBookmark = objDoc.Bookmarks.Add("ТаблицаX", objSel)
           Set objTable = objDoc.Tables.Add(objDoc.Sections.Add.Range, 5, 2)
    
           iAddress = "ТаблицаX " & getTableAddress(objSel)
    
           objTable.Cell(1, 1).Range.Text = "Сумма :"
           objTable.Cell(1, 2).Formula "=SUM(" & iAddress & ")"
    
           objTable.Cell(2, 1).Range.Text = "Количество :"
           objTable.Cell(2, 2).Formula "=COUNT(" & iAddress & ")"
    
           objTable.Cell(3, 1).Range.Text = "Минимум :"
           objTable.Cell(3, 2).Formula "=MIN(" & iAddress & ")"
    
           objTable.Cell(4, 1).Range.Text = "Максимум :"
           objTable.Cell(4, 2).Formula "=MAX(" & iAddress & ")"
    
           objTable.Cell(5, 1).Range.Text = "Среднее :"
           objTable.Cell(5, 2).Formula "=AVERAGE(" & iAddress & ")"
    
           objBookmark.Delete: objTable.Select 'необязательно
    
           Application.ScreenUpdating = True
        Else
    
           MsgBox "Выделите таблицу или часть таблицы ... но не более"
        End If
    
    End Sub
    
    Private Function getTableAddress$(objSel As Word.Selection)
    
        getTableAddress = Chr( _
        objSel.Columns.First.Index + 64) & _
        objSel.Rows.First.Index & ":" & Chr( _
        objSel.Columns.Last.Index + 64) & _
        objSel.Rows.Last.Index
    
    End Function
    Комментарий :
  • Обратите внимание на то, что все функции игнорируют "числа", начинающиеся со знака + , например, +123
  • Если существует вероятность, что Ваша таблица может насчитывать более 26 столбцов, то функцию getTableAddress необходимо немного подкорректировать.
  • Ответ :

    Если Вам необходимо хранить некие данные (в т.ч. это могут быть значения переменных) в течении жизни всего документа, и при этом, нужно избегать их непосредственного ввода в "тело" документа, то в таком случае можно воспользоваться коллекцией Variables об'екта Document
  • Private Sub SetTimeOpenDoc() 'Создание
        ThisDocument.Variables.Add Name:="Время открытия", Value:=Time
    End Sub

    Private Sub GetTimeOpenDoc() 'Изменение
        MsgBox "Сей документ открыли в : " & ThisDocument.Variables("Время открытия")
    End Sub

    Private Sub DeleteTimeOpenDoc() 'Удаление
        ThisDocument.Variables("Время открытия").Delete
    End Sub
    Комментарий :
  • SetTimeOpenDoc - имя переменной должно быть уникально, т.к. в противном случае, Вы получите ошибку (в чём, кстати, можно воочию убедиться, если попытаться повторно выполнить этот макрос) и которую можно избежать, если перед применением метода Add, проверить нет ли в коллекции переменной с таким именем.
  • GetTimeOpenDoc, DeleteTimeOpenDoc - переменная с указанным именем должна существовать, ибо иначе Вы получите ошибку.
  • Как видите, при работе с коллекцией Variables неплохо иметь "инструмент", позволяющий определять наличие/отсутствие нужной переменной. К сожалению, разработчики Word'а не предоставили нам такой возможности(метода), однако Вы можете воспользоваться нижеопубликованной функцией VariableIsExist, которую лучше всего разместить в стандартном модуле шаблона Normal.dot.
  • Public Function VariableIsExist( _
                    iVarName$, Optional objDoc As Word.Document) As Boolean
    '**********************************************************************'
    ' Дата создания 25/04/2014
    ' Автор Климов Павел Юрьевич
    ' http://www.msoffice.nm.ru
    '**********************************************************************'
        If objDoc Is Nothing Then Set objDoc = ActiveDocument

        Dim objVariable As Word.Variable
        For Each objVariable In objDoc.Variables
            If StrComp(objVariable.Name, iVarName$, vbTextCompare) = 0 Then
               VariableIsExist = True
               Exit Function
            End If
        Next
        VariableIsExist = False
    End Function
    Затем, по мере необходимости, просто вызывать эту функцию, следующим образом (см. код Test_VariableIsExist) указав [1] обязательный аргумент - имя искомой переменной (регистр не важен), [2] необязательный - ссылка на документ ( можно не использовать, если поиск необходимо осуществить в активном документе, т.е. в ActiveDocument )
    Private Sub Test_VariableIsExist()
        Dim objDoc As Word.Document, iVarName$
        Set objDoc = ThisDocument: iVarName = "Время запуска"

        If Not Normal.VariableIsExist(iVarName, objDoc) Then
           objDoc.Variables.Add iVarName, Time
        Else
           objDoc.Variables(iVarName).Value = Time
           'objDoc.Variables(iVarName).Delete
        End If
    End Sub

  • Ответ :

    Если Вам необходимо открыть существующий документ, причём так, чтобы, во время работы макроса, он не мелькал перед глазами пользователя, проще говоря, был невидим на экране, то Вы можете использовать любой из нескольких нижеопубликованных вариантов.
  • Private Sub OpenUnvisibleDocument()
        Dim iFileName$, objDoc As Word.Document
        
        iFileName = "C:\Имя_документа.doc"
        Set objDoc = GetObject(iFileName) ', "Word.Document")
        
        'Здесь Вы можете работать с невидимым (на экране) документом
        
        objDoc.Close saveChanges:=wdSaveChanges
        'wdDoNotSaveChanges - закрыть без изменений
    End Sub
    Private Sub OpenUnvisibleDocument2() 'Word 2000(и старше)
        Dim iFileName$, objDoc As Word.Document
        
        iFileName = "C:\Имя_документа.doc"
        Set objDoc = Documents.Open(FileName:=iFileName, Visible:=False)
        
        'Здесь Вы можете работать с невидимым (на экране) документом
        
        objDoc.Close saveChanges:=wdSaveChanges
        'wdDoNotSaveChanges - закрыть без изменений
    End Sub
    Private Sub OpenUnvisibleDocument3()
        Dim iFileName$: iFileName = "C:\Имя_документа.doc"
        
        Application.ScreenUpdating = False
        With Documents.Open(FileName:=iFileName)
             'Здесь Вы можете работать с этим доком
             .Close saveChanges:=wdDoNotSaveChanges
             'wdSaveChanges сохранить все изменения
        End With
        Application.ScreenUpdating = True
    End Sub

  • Ответ :

    Если существует вероятность, что на компьютере может быть запущено несколько приложений Word и Вам необходимо узнать открыт ли вполне определённый документ, то для этого можно использовать функцию FileLocked из нижеприведённой статьи : WD2000: VBA Function to Check Whether File or Document Is Open

    Комментарий : Если эта проверка нужна только для того, чтобы не пытаться открыть уже открытый документ, то можно сразу (т.е. без проверки) использовать самый первый вариант из предыдущего совета.
  • Ответ :

    Если Вам необходимо импортировать всю графику из конкретной папки в новый документ, то Вы можете использовать следующий вариант. Важно : если в папке, кроме графических файлов могут присутствовать и другие, то раскомментируйте (удалите апостроф) в строке 'On Error Resume Next
  • Private Sub ImportGraphicOutFolder()
        Dim iPath$, iFileName$
        Dim objDoc As Word.Document, objAnchor As Word.Range
       
        iPath = "C:\Pictures\" 'Укажите свою папку с завершающим слэшем
        iFileName = Dir(iPath)
       
        If iFileName <> "" Then
           'On Error Resume Next       
           Set objDoc = Documents.Add: Set objAnchor = objDoc.Range(0)
           Do
                objDoc.InlineShapes.AddPicture iPath & iFileName, False, True, objAnchor
                Set objAnchor = objDoc.Range(objDoc.Range.End - 1)
                iFileName = Dir
           Loop Until iFileName = ""
           'Kill iPath & "*"
        Else
           MsgBox "Импорт невозможен", vbCritical, ""
        End If
    End Sub

  • Ответ :

    Для того, чтобы определить запущено или нет нужное приложение, можно воспользоваться об'ектом Tasks и его методом Exists. Пример, для Microsoft Excel прилагается :
  • Private Sub FindWindowCaption()
        If Not Tasks.Exists("Microsoft Excel") Then
           Shell "Excel.exe", vbNormalFocus
        Else
           With Tasks("Microsoft Excel")
                .Activate
                .WindowState = wdWindowStateMaximize
           End With
        End If
    End Sub
    Комментарий : На самом деле, в этом примере осуществляется поиск окна, где в заголовке присутствует текст "Microsoft Excel", поэтому, если этот текст будет изменён (а это возможно), то приложение будет запущено повторно. Чтобы этого не происходило, используйте более надёжный способ.
    Private Sub ExampleRunExcel()
        On Error Resume Next
        Dim objXL As Object
        Set objXL = GetObject(, "Excel.Application")
        
        If objXL Is Nothing Then
           Shell "Excel.exe", vbNormalFocus
        Else
           objXL.WindowState = -4137 'xlMaximized
           AppActivate objXL.Caption
        End If
    End Sub
    Для поиска запущенного калькулятора также можно использовать вышеупомянутый об'ект, только не забывайте, что текст на кириллице, а именно Калькулятор - это только для руссифицированной OC.
    Private Sub FindWindowCaption2()
        If Not Tasks.Exists("Калькулятор") Then
           Shell "Calc.exe", vbNormalFocus
        Else
           Tasks("Калькулятор").Activate
        End If
    End Sub
    И напоследок, поиск всех текстовых файлов, открытых в Блокноте с последующим их сохранением и закрытием.
    Private Sub FindOpenTextFileAndClose()
        Dim objTask As Word.Task
        For Each objTask In Tasks
            If InStr(objTask.Name, "Блокнот") > 0 Then
               objTask.SendWindowMessage 273&, 3&, 0&
               objTask.Close
            End If
        Next
    End Sub
    Второй вариант также позволяет осуществить задуманное, причём, без обязательной руссификации OC, однако, он будет игнорировать все файлы не имеющие расширения .txt , в т.ч. .ini и .log , хотя это тоже текстовые файлы.
    Private Sub FindOpenTextFileAndClose2()
        Dim objTask As Word.Task
        For Each objTask In Tasks
            If LCase(objTask.Name) Like "*.txt*" Then
               objTask.SendWindowMessage 273&, 3&, 0&
               objTask.Close
            End If
        Next
    End Sub
  • Ответ :
  • Private Sub CreateListTasks()
        Dim objAnchor As Word.Range
        Dim objTask As Word.Task, iRow%: iRow = 1
        
        Set objAnchor = Documents.Add.Range
        With objAnchor.Tables.Add(objAnchor, Tasks.Count + 1, 3, wdWord9TableBehavior)
             '.Style = wdStyleTableColorfulList 'Word 2007
             .Rows(iRow).Range.Bold = True
             .Cell(iRow, 1).Range = "#"
             .Cell(iRow, 2).Range = "Task Name"
             .Cell(iRow, 3).Range = "Visible"
             
             For Each objTask In Tasks
                 iRow = iRow + 1
                 .Cell(iRow, 1).Range = iRow - 1
                 .Cell(iRow, 2).Range = objTask.Name
                 .Cell(iRow, 3).Range = objTask.Visible
             Next
             .Columns.AutoFit
        End With
    End Sub

    Воспроизведение любых опубликованных здесь материалов возможно только с письменного разрешения автора : Microsoft Word 97, 2000, XP
    © 2004-2016 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff