Пытался адаптировать известный макрос по извлечению аббревиатур из документа word. При запуске в строке 106:
Цитата
If oRange.Information(wdInContentControl) = True Then
выпрыгивает ошибка "Run-time Error 4608 Значение лежит вне допустимого диапазона", а вот что делать с этим диапазоном я не могу разобраться, интернет мне тоже не помог, надежда как всегда на вас. Как мне подсказать макросу что я от него хочу и чего ему от меня нужно?
Код
Sub ИзвлечьАббревиатуры()
Dim oDoc_Source As Document
Dim oDoc_Target As Document
Dim strListSep As String
Dim strAcronym As String
Dim oTable As Table
Dim oRange As Range
Dim n As Long
Dim strAllFound As String
Dim Title As String
Dim Msg As String
Dim oCC As ContentControl
Title = "Извлечение аббревиатур из документа"
'Show msg - stop if user does not click Yes
Msg = "Этот макрос находит все слова, состоящие из 2 или более " & _
"заглавных букв и извлекает эти слова в таблицу " & _
"в новом документе, где Вы можете добавить определения." & vbCr & vbCr & _
"Вы хотите продолжить?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
Application.ScreenUpdating = False
'Find the list separator from international settings
'May be a comma or semicolon depending on the country
strListSep = Application.International(wdListSeparator)
'Start a string to be used for storing names of acronyms found
strAllFound = "#"
Set oDoc_Source = ActiveDocument
'Create new document for acronyms
Set oDoc_Target = Documents.Add
With oDoc_Target
'Make sure document is empty
.Range = ""
'Insert info in header - change date format as you wish
.PageSetup.TopMargin = CentimetersToPoints(3)
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = _
"Список сокращений составлен из файла: " & oDoc_Source.FullName & vbCr & _
"Составил: " & Application.UserName & vbCr & _
"Дата составления: " & Format(Date, "MMMM d, yyyy")
'Adjust the Normal style and Header style
With .Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 12
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With .Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Insert a table with room for acronym and definition
Set oTable = .Tables.Add(Range:=.Range, numrows:=2, NumColumns:=3)
With oTable
'Format the table a bit
'Insert headings
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.Cell(1, 1).Range.Text = "Аббревиатура"
.Cell(1, 2).Range.Text = "Обозначение"
.Cell(1, 3).Range.Text = "Страница"
'Set row as heading row
.Rows(1).HeadingFormat = True
.Rows(1).Range.Font.Bold = True
.PreferredWidthType = wdPreferredWidthPercent
.Columns(1).PreferredWidth = 20
.Columns(2).PreferredWidth = 65
.Columns(3).PreferredWidth = 15
End With
End With
With oDoc_Source
Set oRange = .Range
n = 1 'used to count below
With oRange.Find
'Use wildcard search to find strings consisting of 3 or more uppercase letters
'Set the search conditions
'NOTE: If you want to find acronyms with e.g. 2 or more letters,
'change 3 to 2 in the line below
.Text = "<[А-ЯЁ;A-Z]{2" & strListSep & "}>"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWildcards = True
'Perform the search
Do While .Execute
'Skip content controls with placeholder text
If oRange.Information(wdInContentControl) = True Then
Set oCC = oRange.ParentContentControl
If oCC.ShowingPlaceholderText = True Then
oRange.End = oCC.Range.End + 1
oRange.Collapse wdCollapseEnd
GoTo SkipCC
End If
End If
'Continue while found
strAcronym = oRange.Text
'Insert in target doc
'If strAcronym is already in strAllFound, do not add again
If InStr(1, strAllFound, "#" & strAcronym & "#") = 0 Then
'Add new row in table from second acronym
If n > 1 Then oTable.Rows.Add
'Was not found before
strAllFound = strAllFound & strAcronym & "#"
'Insert in column 1 in oTable
'Compensate for heading row
With oTable
.Cell(n + 1, 1).Range.Text = strAcronym
'Insert page number in column 3
.Cell(n + 1, 3).Range.Text = oRange.Information(wdActiveEndPageNumber)
End With
n = n + 1
End If
SkipCC:
Loop
End With
End With
'Sort the acronyms alphabetically - skip if only 1 found
If n > 2 Then
With Selection
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
'Go to start of document
.HomeKey (wdStory)
End With
End If
Application.ScreenUpdating = True
'If no acronyms found, show msg and close new document without saving
'Else keep open
If n = 1 Then
Msg = "No acronyms found."
oDoc_Target.Close savechanges:=wdDoNotSaveChanges
Else
Msg = "Finished extracting " & n - 1 & " acronymn(s) to a new document."
End If
MsgBox Msg, vbOKOnly, Title
'Clean up
Set oRange = Nothing
Set oDoc_Source = Nothing
Set oDoc_Target = Nothing
Set oTable = Nothing
Set oCC = Nothing
End Sub