Microsoft Word:

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

Rambler's Top100


Counter CO.KZ

    [1] [2]

  1. Как определить количество вложенных подпапок и перебрать их в цикле ? 20.02.2012
  2. Как отобразить диалоговое окно, позволяющее выбрать нужную папку ? 20.02.2012
  3. Как определить размер свободного места на указанном диске ? 21.02.2012
  4. Как определить существует или нет закладка с определённым именем - в активном документе ? 21.02.2012
  5. Как программно вычислить формулу и получить результат, с помощью об'екта Word.Range ? 21.02.2012
  6. Как вычислить формулу и получить результат, но без использования об'екта Word.Range ? 21.02.2012
  7. Как определить разрешение экрана ? 21.02.2012
  8. Как определить операционную систему и её версию ? 21.02.2012
  9. Как отсортировать таблицу в Word'е ? 21.02.2012
  10. Как отсортировать массив в Word'е, но без применения(сортировки) таблиц ? 21.02.2012
  11. Как получить массив отсортированных (по возрастанию) доступных в Word'е шрифтов ? 21.02.2012
  12. Как получить список всех модулей шаблона Normal.dot ? 23.02.2012
  13. Как перебрать все таблицы в активном документе ? 25.02.2012
  14. Как перебрать все ячейки конкретной таблицы ? 25.02.2012
  15. Как изменить цвет заливки всей таблицы, столбца, строки или отдельной ячейки ? 25.02.2012
  16. Как программно изменить размеры формул Equation в Word'е ? 01.03.2012
  17. Как определить наличие колонтитулов в нужном документе ? 01.03.2012
  18. Как найти все документы, находящиеся в определённой папке и содержащие колонтитул, и сохранить имена этих документов в текстовый файл ? 01.03.2012
  19. Как программно открыть документ без автоматического запуска макросов, например, AutoOpen, Document_Open ? 03.03.2012
  20. Как перед печатью выводить диалоговое окно с подтвержением или отменой печати ?
    Как можно "перехватить" попытку распечатать документ Word ? 03.03.2012
  21. Как изменить автора у всех примечаний, находящихся в активном документе ? 06.03.2012
  22. Как перебрать все примечания активного документа и получить их индекс(номер) и текст ? 06.03.2012
  23. Как удалить все примечания в активном документе ? 19.04.2012
  24. Как преобразовать первую букву каждого слова в прописную, а все остальные в строчные (Word) ? 06.03.2012
  25. Как преобразовать все буквы в прописные [ВЕРХНИЙ РЕГИСТР] (Word) ? 06.03.2012
  26. Как преобразовать все буквы в строчные [нижний регистр] (Word) ? 06.03.2012
  27. Как удалить все непечатаемые символы из текста (Word) ? 07.03.2012
  28. Как удалить все лишние пробелы из строковой переменной (Word) ? 19.05.2013
  29. Как по истечении указанного времени закрыть все открытые документы, причём с сохранением изменений, а также приложение ? 07.03.2012
  30. Как в активном документе найти все слова с орфографическими ошибками, и сохранить их в текстовый файл ? 08.03.2012
  31. Как найти текст и получить номер страницы, на которой этот текст расположен ? 09.03.2012
  32. Как в документе найти текст и отправить на печать все страницы, на которых находится искомый текст ?
    Как найти абзацы, где наличествует текст, выделенный жирным шрифтом и добавить в начало этого абзаца знак + ? 07.12.2014
    [1] [2]


  • Ответ :

    Для того, чтобы узнать сколько вложенных подпапок находится в конкретной папке, причём без цикла, можно использовать следующий вариант :
  • iFolder = "C:\"
    iCountSubFolders = WordBasic.CountDirectories(iFolder)
    
    А для получения списка (в данном примере, массива) этих подпапок, причём без перебора остальных элементов папки, можно использовать процедуру getSubFolders, естественно, указав свою папку.
    Private Sub getSubFolders()
        Dim iCount&, iFolder$, iSubFolders$()
        
        iFolder = "C:\Windows" '"C:\Windows\"
        ChDrive Left(iFolder, 2): ChDir iFolder
        With WordBasic
             iCount = .CountDirectories(iFolder)
             ReDim iSubFolders(1 To iCount)
             For iCount = 1 To iCount
                 iSubFolders(iCount) = .GetDirectory(iCount)
             Next
        End With
    End Sub
    Обратите внимание, если :
    - в папке не окажется вложенных подпапок
    - или если Вы неправильно укажите диск/папку
    то получите ошибку, которую можно избежать, если добавить небольшую проверку, а именно :
    Private Sub getSubFolders()
        Dim iCount&, iFolder$, iSubFolders$()
        
        iFolder = "C:\Windows7\" '"C:\Windows7"
        iCount = WordBasic.CountDirectories(iFolder)
        If iCount > 0 Then
           ChDrive Left(iFolder, 2): ChDir iFolder
           ReDim iSubFolders(1 To iCount)
           For iCount = 1 To iCount
               iSubFolders(iCount) = WordBasic.GetDirectory(iCount)
           Next
        Else
           MsgBox Switch( _
           iCount = -1, "Папка/диск не существует", _
           iCount = 0, "Нет вложенных подпапок"), , ""
        End If
    End Sub
    Private Sub getSubFolders()
        Dim iCount&, iFolder$, iSubFolders$()
        
        iFolder = "C:\Windows7" '"C:\Windows7\"
        iCount = WordBasic.CountDirectories(iFolder)
        If iCount > 0 Then
           ChDrive Left(iFolder, 2): ChDir iFolder
           ReDim iSubFolders(1 To iCount)
           For iCount = 1 To iCount
               iSubFolders(iCount) = WordBasic.GetDirectory(iCount)
           Next
        Else
           MsgBox IIf(iCount, "Папка/диск не существует", "Нет вложенных подпапок")
        End If
    End Sub
    Private Sub getSubFoldersV2()
        Dim iCount&, iFolder$, iSubFolders$()
        
        iFolder = "E:\Windows" '"E:\Windows\"
        With WordBasic
             iCount = .CountDirectories(iFolder)
             Select Case iCount
                 Case -1
                    MsgBox "Папка/диск не существует", , ""
                 Case 0
                    MsgBox "Нет вложенных подпапок", , ""
                 Case Else
                    .ChDir iFolder
                    ReDim iSubFolders(1 To iCount)
                    For iCount = 1 To iCount
                        iSubFolders(iCount) = .GetDirectory(iCount)
                    Next
             End Select
        End With
    End Sub

  • Ответ :

    Для того, что отобразить диалоговое окно, с помощью которого можно выбрать необходимую папку и получить полный путь к этой папке, можно использовать об'ект FileDialog, который впервые появился в MS Office XP.

    Если же Вы работаете с другими версиями 97, 2000, то в этом случае можно воспользоваться следующим советом :
  • With Dialogs(wdDialogCopyFile)
         '.Directory = ThisDocument.Path
         If .Display = -1 Then
            iFolder = .Directory
            MsgBox "Вы выбрали папку " & iFolder, , ""
         Else
            MsgBox "Вы не выбрали папку", , ""
         End If
    End With

  • Ответ :

    Для того, что определить размер свободного места на конкретном диске, можно использовать свойство FreeDiskSpace об'екта System, предварительно изменив текущий диск на указанный (см. функцию getFreeDiskSpace)
  • Private Function getFreeDiskSpace&(iDrive$)
        ChDrive iDrive
        getFreeDiskSpace = System.FreeDiskSpace
    End Function
    
    Private Sub CallMacro()
        Dim iDrive$, iFreeDiskSpace&
        
        iDrive = "C" '"C:" '"C:\"
        iFreeDiskSpace = getFreeDiskSpace(iDrive)
        
        MsgBox _
        "На диске " & iDrive & _
        " свободно : " & vbCrLf & _
        iFreeDiskSpace & " байт" & vbCrLf & _
        iFreeDiskSpace \ 1024 & " Кб" & vbCrLf & _
        iFreeDiskSpace \ 1048576 & " Мб"
    End Sub

  • Ответ :

    Для того, что определить существует или нет, закладка с конкретным именем в активном документе, достаточно использовать метод Exists семейства Bookmarks
  • iSearchName = "XXX" 'укажите необходимоё имя
    
    If ActiveDocument.Bookmarks.Exists(iSearchName) = True Then
       MsgBox "Закладка существует", , ""
    Else
       MsgBox "Закладки не существует", , ""
    End If

  • Ответ :

    Для того, чтобы вычислить формулу, которая присутствует в документе и получить результат вычислений, можно воспользоваться методом Calculate об'екта Range
  • iFormula = "2012-1997" '"=2012-1997"
    Selection.Text = iFormula
    iResult = Selection.Calculate
    
    MsgBox _
    "Формула: " & iFormula & vbCrLf & _
    "Pезультат: " & iResult, vbExclamation, ""
    
    Если же необходимо просто заменить формулу на её значение, то :
    iFormula = "=2012-1997" '"2012-1997"
    Selection.Text = iFormula
    Selection.Text = Selection.Calculate
    
    Комментарий : Обратите внимание, если Вы укажите формулу, которую Word не сможет вычислить, то в таком случае Calculate возвратит 0
  • Ответ :

    Для того, чтобы вычислить формулу, но без применения об'екта Range, можно использовать метод ToolsCalculate об'екта WordBasic
  • iFormula = "2012-1997" '"=2012-1997"
    iResult = WordBasic.ToolsCalculate(iFormula)
    
    MsgBox _
    "Формула: " & iFormula & vbCrLf & _
    "Pезультат: " & iResult, vbExclamation, ""
    
    Комментарий : Обратите внимание, если Вы укажите формулу, которую Word не сможет вычислить, то в этом случае возникнет ошибка.

    Автор : Пётр Каньковски
    Источник : http://kankowski.narod.ru/dev/wordbasic.htm
  • Ответ :

    Для того, что определить разрешение экрана, можно использовать свойства HorizontalResolution и VerticalResolution об'екта System
  • Private Sub Word_GetSystemScreen()
        Dim iX&, iY&
    
        iX = System.VerticalResolution
        iY = System.HorizontalResolution
    
        MsgBox "Ваш экран имеет разрешение : " & _
        iX & "x" & iY, vbExclamation, "Информация"
    End Sub

  • Ответ :

    Для того, что определить операционную систему, а также её версию можно использовать свойства OperatingSystem и Version об'екта System
  • Private Sub Word_GetOperatingSystem()
        Dim iOS$, iOSVersion$
        
        iOS = System.OperatingSystem
        iOSVersion = System.Version
    
        MsgBox "Операционная система : " & vbCrLf & _
        iOS & " версия " & iOSVersion, , "Информация"
    End Sub
    Если необходимо определить ОС & " " & версию, то вместо об'единения, допускается такой вариант :
    MsgBox WordBasic.AppInfo(1)
    

  • Ответ :

    Для того, что отсортировать таблицу в Word'е (по возрастанию и убыванию) можно использовать методы SortAscending и SortDescending об'екта Table , например :
  • ActiveDocument.Tables(1).SortAscending
    
    ActiveDocument.Tables(2).SortDescending
    
    Комментарий : Обратите внимание, что применение данных методов приведёт к тому, что данные первой строки не сортируются, т.к. первая строка считается заголовком таблицы. Если такой расклад Вас не устраивает, то сортируйте с помощью метода Sort [ExcludeHeader], [FieldNumber], [SortFieldType], [SortOrder], [FieldNumber2], [SortFieldType2], [SortOrder2], [FieldNumber3], [SortFieldType3], [SortOrder3], [CaseSensitive], [LanguageID]
    ActiveDocument.Tables(1).Sort _
    ExcludeHeader:=False, _
    SortOrder:=wdSortOrderAscending, _
    SortFieldType:=wdSortFieldAlphanumeric

  • Ответ :

    Для того, что отсортировать одномерный или двухмерный массив типа String, но без применения Word'их таблиц, можно использовать инструкцию SortArray , которая осталась нам в наследство от WordBasic
  • Private Sub Test_SortStringArray()
        Dim iArrFamily$(1 To 5), iCount%
        
        iArrFamily(1) = "Иванов"
        iArrFamily(2) = "Петрова"
        iArrFamily(3) = "Яковлев"
        iArrFamily(4) = "Климов"
        iArrFamily(5) = "Воробьева"
        
        WordBasic.SortArray iArrFamily ', 0 'по возрастанию
        'WordBasic.SortArray iArrFamily, 1 'по убыванию
        
        For iCount = 1 To 5
            MsgBox iArrFamily(iCount), , ""
        Next
    End Sub
    Автор : Пётр Каньковски
    Источник : http://kankowski.narod.ru/dev/wordbasic.htm
  • Ответ :

    Для того, что получить массив отсортированных (по возрастанию) доступных в Word'е шрифтов, достаточно использовать процедуру getSortArrayFonts
  • Private Sub getSortArrayFonts()
        Dim iArrFonts$(), iCount&
        ReDim iArrFonts(1 To FontNames.Count)
        For iCount = 1 To UBound(iArrFonts) 'FontNames.Count
            iArrFonts(iCount) = FontNames(iCount)
        Next
        WordBasic.SortArray iArrFonts
    End Sub
    Private Sub getSortArrayFonts2()
        Dim iArrFonts$(), iCount&
        With WordBasic
             ReDim iArrFonts(1 To .CountFonts)
             For iCount = 1 To UBound(iArrFonts)
                 iArrFonts(iCount) = FontNames(iCount)
             Next
             .SortArray iArrFonts
        End With
    End Sub

  • Ответ :

    Для того, чтобы получить перечень всех модулей, которые находятся в шаблоне "Normal.dot", причём, без обращения к об'екту VBE, можно использовать процедуру getAllModulesNormaldot
  • Private Sub getAllModulesNormaldot()
        Dim iCount&, iModules$()
    
        iCount = WordBasic.CountMacros(0)
        ReDim iModules(1 To iCount)
        For iCount = 1 To iCount
            iModules(iCount) = WordBasic.MacroName(iCount)
        Next
    End Sub
    Private Sub getAllModulesNormaldot()
        Dim iCount&, iModules$()
    
        With WordBasic
             iCount = .CountMacros(0)
             ReDim iModules(1 To iCount)
             For iCount = 1 To iCount
                 iModules(iCount) = .MacroName(iCount)
             Next
        End With
    End Sub
    Если же массив не нужен, то :
    Private Sub getAllModulesNormaldot3()
        For iCount& = 1 To WordBasic.CountMacros(0)
            iModule$ = WordBasic.MacroName(iCount&)
            MsgBox iModule$, , "Normal.dot" 'для наглядности
        Next
    End Sub

  • Ответ :

    Для того, чтобы перебрать все таблицы активного документа, а также определить количество строк и столбцов, которые они содержат, можно использовать любой из двух нижеопубликованных вариантов.
  • Private Sub CycleAllTables()
        Dim objTable As Word.Table
        For Each objTable In ActiveDocument.Tables
            MsgBox _
            "Кол-во строк =" & objTable.Rows.Count & vbCrLf & _
            "Кол-во столбцов =" & objTable.Columns.Count, , ""
        Next
    End Sub
    Private Sub CycleAllTables2()
        With ActiveDocument.Tables
             For iCount& = 1 To .Count
                 MsgBox _
                 "Кол-во строк =" & .Item(iCount&).Rows.Count & vbCrLf & _
                 "Кол-во столбцов =" & .Item(iCount&).Columns.Count, , ""
             Next
        End With
    End Sub
    Примечание : Активный документ (ActiveDocument), разумеется, используется исключительно в качестве примера, и может быть заменён на любой другой открытый документ.
  • Ответ :

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

    Вариант I, II.
  • Dim objCell As Word.Cell
    For Each objCell In ActiveDocument.Tables(1).Range.Cells
        MsgBox objCell '.Range.Text
    Next
    Dim objTable As Word.Table, objCells As Word.Cells, iCount&
    Set objTable = ActiveDocument.Tables(1)
    Set objCells = objTable.Range.Cells
    
    For iCount = 1 To objCells.Count
        MsgBox objCells(iCount)
    Next
    Вариант III, IV, V. (только для таблиц, где нет об'единённых ячеек)
    Dim objTable As Word.Table, iRow&, iColumn&
    Set objTable = ActiveDocument.Tables(1)
    
    For iRow = 1 To objTable.Rows.Count
        For iColumn = 1 To objTable.Columns.Count
            MsgBox objTable.Cell(iRow, iColumn)
        Next
    Next
    Dim objTable As Word.Table, objRow As Word.Row, objCell As Word.Cell
    Set objTable = ActiveDocument.Tables(1)
    
    For Each objRow In objTable.Rows
        For Each objCell In objRow.Cells
            MsgBox objCell '.Range.Text
        Next
    Next
    Dim objTable As Word.Table, objColumn As Word.Column, objCell As Word.Cell
    Set objTable = ActiveDocument.Tables(1)
    
    For Each objColumn In objTable.Columns
        For Each objCell In objColumn.Cells
            MsgBox objCell '.Range.Text
        Next
    Next

  • Ответ :

    Для того, чтобы изменить цвет заливки всей таблицы, конкретной строки, столбца, или отдельной ячейки, можно использовать свойство BackgroundPatternColorIndex об'екта Shading.
  • With ActiveDocument.Tables(1)
         .Shading.BackgroundPatternColorIndex = wdRed
    
         .Rows(1).Shading.BackgroundPatternColorIndex = wdYellow
    
         .Columns(1).Shading.BackgroundPatternColorIndex = wdViolet
    
         .Cell(2, 2).Shading.BackgroundPatternColorIndex = wdGreen
    End With

  • Ответ :

    Для того, чтобы в активном документе, изменить размер всех формул Equation, можно использовать макрос Resize_Equation, где, исключительно для в качестве примера, формулы увеличиваются в 2 раза.
  • Private Sub Resize_Equation()
         Dim objInlineShape As Word.InlineShape
         For Each objInlineShape In ActiveDocument.InlineShapes
             With objInlineShape
                  If .OLEFormat.ProgID Like "Equation*" Then
                     .Height = .Height * 2
                     .Width = .Width * 2
                  End If
             End With
         Next
     End Sub

  • Ответ :

    Для того, чтобы определить есть или нет в конкретном документе, хотя бы один верхний или нижний колонтитул, можно использовать функцию getExistHeaderFooter, которая возвратит логическое значение True(Истина) в случае наличия колонтитула(ов) и, соответственно, False(Ложь) при их отсутствии.
  • Function getExistHeaderFooter(objDoc As Word.Document) As Boolean
        Dim objSection As Word.Section, objHeaderFooter As Word.HeaderFooter
        For Each objSection In objDoc.Sections
            For Each objHeaderFooter In objSection.Headers
                If objHeaderFooter.Range.Text <> vbCr Then
                   getExistHeaderFooter = True
                   Exit Function
                End If
            Next
            For Each objHeaderFooter In objSection.Footers
                If objHeaderFooter.Range.Text <> vbCr Then
                   getExistHeaderFooter = True
                   Exit Function
                End If
            Next
        Next
    End Function
    Function getExistHeaderFooter(objDoc As Word.Document) As Boolean
        Dim objSection As Word.Section
        Dim objHeaders As Word.HeadersFooters
        Dim objHeaderFooter As Word.HeaderFooter, iCount%
        
        For Each objSection In objDoc.Sections
            For iCount = 1 To 2
                Set objHeaders = Choose(iCount, objSection.Headers, objSection.Footers)
                For Each objHeaderFooter In objHeaders
                    If Len(objHeaderFooter.Range.Text) > 1 Then _
                    getExistHeaderFooter = True: Exit Function
                Next
            Next
        Next
    End Function

  • Ответ :

    Для того, чтобы найти все документы *.doc , находящиеся в определённой папке и содержащие колонтитул, и сохранить имена этих документов в текстовый файл, можно воспользоваться одним из двух нижеприведённых вариантов :

    Вариант I.
  • Private Sub CreateListDoc()
        Dim objDoc As Word.Document, iPath$, iFileName$
        
        iPath = "C:\Мои документы\" 'укажите или выберите свою папку
        iFileName = Dir(iPath & "*.doc", vbHidden + vbReadOnly)
        If iFileName <> "" Then
           Application.ScreenUpdating = False
           Open iPath & "HeaderFooterDocs.txt" For Output As #1
           Do
               Set objDoc = Documents.Open(FileName:=iPath & iFileName)
               If getExistHeaderFooter(objDoc) = True Then _
               Print #1, iFileName, iPath & iFileName
               objDoc.Close saveChanges:=False
               iFileName = Dir
           Loop While iFileName <> ""
           Close #1
           Application.ScreenUpdating = True
        End If    
    End Sub
    
    Function getExistHeaderFooter(objDoc As Word.Document) As Boolean
        Dim objSection As Word.Section, objHeaderFooter As Word.HeaderFooter
        For Each objSection In objDoc.Sections
            For Each objHeaderFooter In objSection.Headers
                If iHeaderFooter.Range.Text <> vbCr Then
                   getExistHeaderFooter = True
                   Exit Function
                End If
            Next
            For Each objHeaderFooter In objSection.Footers
                If objHeaderFooter.Range.Text <> vbCr Then
                   getExistHeaderFooter = True
                   Exit Function
                End If
            Next
        Next
    End Function
    Вариант II. (Word 2000 или старше)
    Private Sub CreateListDoc()
        Dim objDoc As Word.Document, iPath$, iFileName$
        
        iPath = "C:\Мои документы\" 'укажите или выберите свою папку
        iFileName = Dir(iPath & "*.doc", vbHidden + vbReadOnly)
        If iFileName <> "" Then
           Open iPath & "HeaderFooterDocs.txt" For Output As #1
           Do
               Set objDoc = Documents.Open(FileName:=iPath & iFileName, Visible:=False)
               If getExistHeaderFooter(objDoc) = True Then _
               Print #1, iFileName, iPath & iFileName
               objDoc.Close saveChanges:=False
               iFileName = Dir
           Loop While iFileName <> ""
           Close #1       
        End If
    End Sub
    
    Function getExistHeaderFooter(objDoc As Word.Document) As Boolean
        Dim objSection As Word.Section
        Dim objHeaders As Word.HeadersFooters
        Dim objHeaderFooter As Word.HeaderFooter, iCount%
        
        For Each objSection In objDoc.Sections
            For iCount = 1 To 2
                Set objHeaders = Choose(iCount, objSection.Headers, objSection.Footers)
                For Each objHeaderFooter In objHeaders
                    If Len(objHeaderFooter.Range.Text) > 1 Then _
                    getExistHeaderFooter = True: Exit Function
                Next
            Next
        Next
    End Function
    Комментарий : Если в документах могут находиться макросы, которые будут выполняться при открытии документа, например, AutoOpen, Document_Open , то имеет смысл заблокировать их выполнение, использовав следующий [FAQ19]
  • Ответ :

    Для того, чтобы программно открыть документ без автоматического запуска макросов можно использовать инструкцию DisableAutoMacros, которая также осталась нам в наследство от WordBasic и которая блокирует автоматический запуск следующих макросов AutoOpen, AutoClose, AutoNew, AutoExit, а также событий, типа, Document_Open
  • WordBasic.DisableAutoMacros '1
    'Здесь Вы можете открыть свой документ
    WordBasic.DisableAutoMacros 0

  • Ответ : Актуально для MS Word 2000, XP

    Если Вам необходимо отслеживать вывод на печать любого открытого документа, то скопируйте в модуль ThisDocument шаблона Normal.dot следующий код и сохраните изменения. Теперь, при следующем запуске Word (и выполнении события Document_Open), Вы сможете контролировать печать.
  • Private WithEvents objWordApp As Word.Application
    
    Private Sub Document_Open()
        Set objWordApp = Word.Application
    End Sub
    
    Private Sub objWordApp_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
        If MsgBox("Вы хотите осуществить печать ?", vbYesNo) = vbNo Then 
           Cancel = True 
        End If 
    End Sub
    Если же контролировать процесс печати нужно только в определённом документе, например, необходимо запретить печать документа с именем Архив_платежей.doc, то, либо просто добавьте небольшую проверку :
    Private Sub objWordApp_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
        If LCase(Doc.Name) = "архив_платежей.doc" Then Cancel = True
    End Sub
    Либо разместите нижеприведённый код в модуле ThisDocument документа Архив_платежей.doc и сохраните изменения.
    Private WithEvents objWordApp As Word.Application
    
    Private Sub Document_Open()
        Set objWordApp = Word.Application
    End Sub
    
    Private Sub objWordApp_DocumentBeforePrint(ByVal Doc As Document, Cancel As Boolean)
        If Doc Is ThisDocument Then 'If Doc Is Me Then
           Cancel = True
        End If
    End Sub
    Примечание : Разумеется, Вы можете использовать это событие и в других целях, например, проверять правильность заполнения бланков перед печатью, создавать колонтитулы, или добавить номера страниц и многое другое.
  • Ответ :

    Если Вам необходимо изменить автора всех примечаний, находящихся в активном документе, то используйте процедуру setNewCommentAuthor, естественно, указав нужного автора (рецензента)
  • Private Sub setNewCommentAuthor()
        Dim objComment As Word.Comment
        For Each objComment In ActiveDocument.Comments
            objComment.Author = "pashulka"
        Next
    End Sub

  • Ответ :

    Для того, чтобы перебрать все примечания активного документа и получить их индекс(номер), а также текст, можно использовать любой из нижеопубликованных вариантов :
  • Dim objComment As Word.Comment
    For Each objComment In ActiveDocument.Comments
        MsgBox "Примечание #" & _
        objComment.Index & vbCrLf & objComment.Range.Text
    Next
    Dim objComments As Word.Comments, iCount&
    Set objComments = ActiveDocument.Comments
    For iCount = 1 To objComments.Count
        MsgBox "Примечание #" & _
        iCount & vbCrLf & objComments(iCount).Range.Text
    Next
    With ActiveDocument.Comments
         For iCount& = 1 To .Count
             MsgBox "Примечание #" & _
             iCount& & vbCrLf & .Item(iCount&).Range.Text
         Next
    End With

  • Ответ :

    Для того, чтобы удалить все примечания из активного документа, можно использовать любой из нижеопубликованных вариантов :
  • Private Sub RemoveAllComments()
        Dim objComment As Word.Comment
        For Each objComment In ActiveDocument.Comments
            objComment.Delete
        Next
    End Sub
    Private Sub RemoveAllComments2()
        With ActiveDocument.Comments
             For iCount& = .Count To 1 Step -1
                 .Item(iCount&).Delete
             Next
        End With
    End Sub
    Актуально для MS Word XP
    Private Sub RemoveAllCommentsXP()
        ActiveDocument.DeleteAllComments
    End Sub

  • Ответ :

    Для того, чтобы преобразовать первую букву каждого слова в прописную, а все остальные в строчные, можно воспользоваться свойством Case об'екта Range и константой wdTitleWord , пример с выделенным текстом и первой страницей, прилагается :
  • Selection.Range.Case = wdTitleWord 'Начинать С Прописных
    ActiveDocument.Sections(1).Range.Case = wdTitleWord 'Начинать С Прописных
    
    Примечание : Для решения поставленной задачи Вы можете также использовать и VB функцию StrConv(Text, vbProperCase), однако, при этом формат всего текста будет установлен, исходя из формата самого первого символа, что, вряд ли, приемлемо.
  • Ответ :

    Для того, чтобы преобразовать все буквы в прописные, можно воспользоваться свойством Case об'екта Range и константой wdUpperCase , пример с выделенным текстом и первой страницей, прилагается :
  • Selection.Range.Case = wdUpperCase 'ВСЕ ПРОПИСНЫЕ
    ActiveDocument.Sections(1).Range.Case = wdUpperCase 'ВСЕ ПРОПИСНЫЕ
    

  • Ответ :

    Для того, чтобы преобразовать все буквы в строчные, можно воспользоваться свойством Case об'екта Range и константой wdLowerCase , пример с выделенным текстом и первой страницей, прилагается :
  • Selection.Range.Case = wdLowerCase 'все строчные
    ActiveDocument.Sections(1).Range.Case = wdLowerCase 'все строчные
    

  • Ответ :

    Для того, чтобы удалить из текста все непечатаемые символы, например, символы табуляции, символы абзацев, пробелы и прочие, можно воспользоваться методом CleanString (см. пример), который, на самом деле, удаляет лишь символы с кодом 7, 31, 172, 183, а следующие символы 0-6, 8-12, 14-30, 160, 182 просто заменяет на символ с кодом 32, проще говоря, пробел.
  • Private Sub Example_WordCleanString()
        Dim iText$, iCleanText$, iCount%
        
        iText = Space(256)
        For iCount = 0 To 255
            Mid(iText, iCount + 1, 1) = Chr(iCount)
        Next
        'iCleanText = CleanString(iText)
        iCleanText = Application.CleanString(iText)
        
        'Исключительно для демонстрации
        With Application.Documents.Add
             With .Tables.Add(.Sections(1).Range, 2, 1)
                  .Cell(1, 1).Range.Text = iText
                  .Cell(2, 1).Range.Text = iCleanText
    
                  .Borders.InsideLineStyle = wdLineStyleSingle  'Word 2000
                  .Borders.OutsideLineStyle = wdLineStyleSingle 'Word 2000
             End With
             .ActiveWindow.ActivePane.View.ShowAll = True 'CTRL + *
        End With
    End Sub

  • Ответ :

    Для того, чтобы удалить из текста все пробелы, за исключением одиночных пробелов между словами, в MS Excel существует стандартная функция рабочего листа СЖПРОБЕЛЫ. В MS Word такой функции нет, однако, Вы можете воспользоваться собственной функцией, например, WordTrimString (см. пример)
  • Function WordTrimString$(Source$) 'Word 2000(и старше)
        WordTrimString = Trim(Source)
        Do While InStr(WordTrimString, "  ")
           WordTrimString = Replace(WordTrimString, "  ", " ")
        Loop
    End Function
    Пример вызова вышеопубликованной функции :
    Private Sub Example_WordTrimString()
        MsgBox WordTrimString(" Просто     строка, содержащая      пробелы,  и текст    ")
    End Sub

  • Ответ :

    Для того, чтобы по истечении указанного времени, например, после окончания рабочего дня, т.е. 18:00 , закрыть все открытые документы с сохранением всех изменений, а затем закрыть и приложение Word, скопируйте весь нижеприведённый код в любой стандартный модуль шаблона Normal.dot
  • Public Sub AutoOpen()
        Application.OnTime DateAdd("h", 18, Date), "FinishFuckingJob"
        'Application.OnTime Date + TimeValue("18:00:00"), "FinishFuckingJob"
    End Sub
    
    Public Sub FinishFuckingJob()
        MsgBox "Чувак, пора сваливать домой !!!", vbInformation, ""
        Dim objDoc As Word.Document
        For Each objDoc In Application.Documents
            objDoc.Close saveChanges:=wdSaveChanges
        Next
        Application.Quit saveChanges:=wdSaveChanges
    End Sub
    Примечание : Вместо макроса AutoOpen можно использовать событие Document_Open, которое обязательно должно располагаться в модуле документа ThisDocument

    Комментарий :
  • Для полной автоматизации процесса закрытия, следует закомментировать/удалить строку с функцией MsgBox
  • К сожалению, в Word'е есть возможность воспрепятствовать закрытию книг, в т.ч. и программному, например, с помощью события приложения objWordApp_DocumentBeforeClose (Word 2000 и старше)
  • Ответ :

    Для того, чтобы в активном документе найти все слова с орфографическими ошибками (текст, который Word подчёркивает красным цветом) и сохранить их в текстовый файл, можно использовать процедуру CreateList_WordsWithSpellingErrors
  • Private Sub CreateList_WordsWithSpellingErrors()
        Dim objDoc As Word.Document, objWordError As Word.Range
    
        Set objDoc = ActiveDocument
        objDoc.SpellingChecked = False
    
        Open objDoc.Path & "\SpellingErrors.txt" For Output As #1
             For Each objWordError In objDoc.SpellingErrors
                 Print #1, objWordError.Text
             Next
        Close #1
    End Sub
    Private Sub CreateList_WordsWithSpellingErrors2()
        Dim objDoc As Word.Document
        Dim objWordError As Word.Range, iFileName$
        Dim objListError As Word.ProofreadingErrors
    
        Set objDoc = ActiveDocument
        objDoc.SpellingChecked = False
    
        Set objListError = objDoc.SpellingErrors    
        If objListError.Count = 0 Then
           MsgBox "Орфографических ошибок не наблюдается ..."
           Exit Sub
        End If
    
        iFileName = objDoc.Path & "\SpellingErrors.txt"
        'Application.ScreenUpdating = False
        Open iFileName For Output As #1
             For Each objWordError In objDoc.SpellingErrors
                 Print #1, objWordError.Text
             Next
        Close #1
        'Application.ScreenUpdating = True
        objDoc.FollowHyperlink iFileName
    End Sub
    Комментарий : На мой взгляд, не стоит всецело полагаться на программную проверку орфографии, и полученный список имеет смысл, что называется, перепроверить.
  • Ответ :

    Для того, чтобы найти необходимый текст и получить номер самой первой страницы, на которой этот текст находится, можно использовать об'ект Find и свойство Information вкупе с константой wdActiveEndPageNumber
  • Private Sub FindTextInDocument()
        With ActiveDocument.Content.Find
             .ClearFormatting
             .Execute FindText:="Иванов", Forward:=True
             If .Found = True Then
                MsgBox .Parent.Information(wdActiveEndPageNumber), , ""
             Else
                MsgBox "Ни одного Иванова замечено не было ...", , ""
             End If
        End With
    End Sub
    Если же текст, нужно искать "относительно" выделенного, и при этом, необходимо ещё и выделить найденный текст, то :
    Private Sub FindTextInSelection()
        If Selection.Find.Execute( _
           FindText:="Петров", Wrap:=wdFindContinue) = True Then
           MsgBox Selection.Information(wdActiveEndPageNumber), , ""
        Else
           MsgBox "Ни одного Петрова замечено не было ...", , ""
        End If
    End Sub
    Примечание : Если же Вам необходимо найти все страницы, содержащие искомый текст, то смотрите следующий [FAQ30]
  • Ответ :

    Для того, чтобы в активном документе найти указанный текст и отправить на печать все страницы, на которых находится искомый текст (учитывая, что текст может встречаться на одной странице более одного раза, а распечатывать страницу нужно, естественно, только один раз), можно использовать макрос FindTextAndPrintPage
  • Private Sub FindTextAndPrintPage()
        Dim objDoc As Word.Document, iText$, iPagePrint&, iPreviousPage&
        Set objDoc = ActiveDocument 'можно указать и другой документ
    
        iText = "Microsoft Word" 'InputBox("Введите искомый текст", "")
    
        With objDoc.Content
             .Find.ClearFormatting
             Do While .Find.Execute(FindText:=iText, Forward:=True) = True
                iPagePrint = .Information(wdActiveEndPageNumber)
                If iPreviousPage < iPagePrint Then
                   iPreviousPage = iPagePrint
                   objDoc.PrintOut Range:=wdPrintRangeOfPages, Pages:=CStr(iPagePrint)
                End If
             Loop
        End With
    End Sub

  • Ответ :

    Для того, чтобы в активном документе найти все абзацы, в которых присутствует текст, выделенный полужирным шрифтом, и добавить в начало этих абзацев знак плюс +, можно использовать макрос FindFontBoldAndInsert
  • Private Sub FindFontBoldAndInsert()
        With ActiveDocument.Content.Find
             .ClearFormatting: .Font.Bold = True
             Do While .Execute(Format:=True, Forward:=True)
                 With .Parent.Paragraphs(1).Range
                      If Asc(.Text) <> 43 Then .InsertBefore "+"
                 End With
             Loop
        End With
    End Sub
    Примечание : + используется исключительно в качестве примера, и его можно заменить на любой другой символ, только не забудьте указать в макросе его код (функция Asc, AscW)

    И, разумеется, префиксом может являться текст, состоящий из нескольких символов, смотрите следующий пример :
    Private Sub FindFontBoldAndInsert2()
        Const Prefix = "[+] ": iLenght& = Len(Prefix)
    
        With ActiveDocument.Content.Find
             .ClearFormatting: .Font.Bold = True
             Do While .Execute(Format:=True, Forward:=True)
                 With .Parent.Paragraphs(1).Range
                      If Left(.Text, iLenght&) <> Prefix Then .InsertBefore Prefix
                 End With
             Loop
        End With
    End Sub

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