Sub colorize() Dim p As Paragraph, prev&, b As Boolean Application.ScreenUpdating = 0 With CreateObject("vbscript.regexp") .Global = False: .Pattern = "^\d+\.\d+\s" For Each p In ThisDocument.Paragraphs If .test(p.Range.Text) Then If prev > 0 Then p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If prev = p.Range.Start + 1 b = Not b ElseIf p.Next Is Nothing Then p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If Next End With Application.ScreenUpdating = 1 End Sub
[/vba]
Здравствуйте. [vba]
Код
Sub colorize() Dim p As Paragraph, prev&, b As Boolean Application.ScreenUpdating = 0 With CreateObject("vbscript.regexp") .Global = False: .Pattern = "^\d+\.\d+\s" For Each p In ThisDocument.Paragraphs If .test(p.Range.Text) Then If prev > 0 Then p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If prev = p.Range.Start + 1 b = Not b ElseIf p.Next Is Nothing Then p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If Next End With Application.ScreenUpdating = 1 End Sub
krosav4ig, вот этот код применительно к данному файлу: [vba]
Код
Sub colorize() Dim p As Paragraph, prev&, b As Boolean Application.ScreenUpdating = 0 With CreateObject("vbscript.regexp") .Global = False: .Pattern = "^\d+\.\d+\s" For Each p In ThisDocument.Paragraphs If .test(p.Range.Text) Then If prev > 0 Then p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If prev = p.Range.Start + 1 b = Not b ElseIf p.Next Is Nothing Then p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If Next End With Application.ScreenUpdating = 1 End Sub
[/vba]
Не работает.
Выдает ошибку: Run-time error 4608: Значение лежит вне допустимого диапазона.
krosav4ig, вот этот код применительно к данному файлу: [vba]
Код
Sub colorize() Dim p As Paragraph, prev&, b As Boolean Application.ScreenUpdating = 0 With CreateObject("vbscript.regexp") .Global = False: .Pattern = "^\d+\.\d+\s" For Each p In ThisDocument.Paragraphs If .test(p.Range.Text) Then If prev > 0 Then p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If prev = p.Range.Start + 1 b = Not b ElseIf p.Next Is Nothing Then p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) End If Next End With Application.ScreenUpdating = 1 End Sub
[/vba]
Не работает.
Выдает ошибку: Run-time error 4608: Значение лежит вне допустимого диапазона.
у меня в word 2003, 2007, 2010, 2013 отрабатывает без ошибок раскрашенные файлы прилагаю
upd. немного переписал код пробуйте так [vba]
Код
Sub colorize() Dim p As Paragraph, prev&, b As Boolean 1 On Error GoTo colorize_Error
11 Application.ScreenUpdating = 0 21 With CreateObject("vbscript.regexp") 31 .Global = False: .Pattern = "^\d+\.\d+\s" 41 For Each p In ThisDocument.Paragraphs 51 If p.Next Is Nothing Then 61 If .test(p.Range.Text) Then 71 p.Range.HighlightColorIndex = IIf(b, 3, 7) 81 ElseIf prev > 0 Then 91 p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) 101 End If 111 ElseIf .test(p.Range.Text) Then 121 If prev > 0 Then 131 p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) 141 End If 151 b = Not b 161 prev = p.Range.Start + 1 171 End If 181 Next 191 End With 201 Application.ScreenUpdating = 1 211 On Error GoTo 0 221 Exit Sub colorize_Error: 231 MsgBox "Error " & Err.Number & " (" & Err.Description & _ ") in procedure colorize of VBA Document ThisDocument on line " & Erl & vbLf & _ "paragraphs.count: " & Paragraphs.Count & ", current paragraph: " & Range(0, _ p.Range.End).Paragraphs.Count End Sub
[/vba]
у меня в word 2003, 2007, 2010, 2013 отрабатывает без ошибок раскрашенные файлы прилагаю
upd. немного переписал код пробуйте так [vba]
Код
Sub colorize() Dim p As Paragraph, prev&, b As Boolean 1 On Error GoTo colorize_Error
11 Application.ScreenUpdating = 0 21 With CreateObject("vbscript.regexp") 31 .Global = False: .Pattern = "^\d+\.\d+\s" 41 For Each p In ThisDocument.Paragraphs 51 If p.Next Is Nothing Then 61 If .test(p.Range.Text) Then 71 p.Range.HighlightColorIndex = IIf(b, 3, 7) 81 ElseIf prev > 0 Then 91 p.Parent.Range(prev - 1, p.Range.End).HighlightColorIndex = IIf(b, 3, 7) 101 End If 111 ElseIf .test(p.Range.Text) Then 121 If prev > 0 Then 131 p.Parent.Range(prev - 1, p.Previous.Range.End).HighlightColorIndex = IIf(b, 3, 7) 141 End If 151 b = Not b 161 prev = p.Range.Start + 1 171 End If 181 Next 191 End With 201 Application.ScreenUpdating = 1 211 On Error GoTo 0 221 Exit Sub colorize_Error: 231 MsgBox "Error " & Err.Number & " (" & Err.Description & _ ") in procedure colorize of VBA Document ThisDocument on line " & Erl & vbLf & _ "paragraphs.count: " & Paragraphs.Count & ", current paragraph: " & Range(0, _ p.Range.End).Paragraphs.Count End Sub