[求助]下面针对段落边框底纹的VBA代码为何有一半不起作用？

ssq1109

想在文档中段落边框和段落底纹的前后加首尾标记，以下为代码，对段落边框作用是正确的，但对段落底纹不起作用，百思不解？请赐教。谢谢！

Sub BKDW()

    Dim a As Paragraph, TempRange As Range
    Application.ScreenUpdating = False
        For Each a In ActiveDocument.Paragraphs  '在段落中循环
            With a.Range
                Set TempRange = ActiveDocument.Range(.Start, .End - 1) '使其不含段落标记
                '判断是否有段落边框
                If .Borders.OutsideLineStyle > 0 Then
                        TempRange.InsertBefore "[BK(]"
                        TempRange.InsertAfter "[BK)]"  '插入结束标记
                '判断是否有段落底纹
                ElseIf .Shading.Texture <> wdTextureNone Then
                        TempRange.InsertBefore "[DW(]"  '加上起始底纹标记
                        TempRange.InsertAfter "[DW)]"   '插入结束标记
                End If
            End With
        Next
    Application.ScreenUpdating = True
End Sub

ETcd5K3T.rar (2.2 KB, 下载次数: 13)

2007-5-24 11:29 上传

点击文件名下载附件
[求助]下面针对段落边框底纹的VBA代码为何有一半不起作用？

sylun

文档部分段落实为有色无纹，即
.Shading.Texture = wdTextureNone And .Shading.BackgroundPatternColor <> wdColorAutomatic

ssq1109

QUOTE:

以下是引用sylun在2007-5-24 13:26:24的发言：
文档部分段落实为有色无纹，即
.Shading.Texture = wdTextureNone And .Shading.BackgroundPatternColor <> wdColorAutomatic

谢谢sylun兄！您分析的很对。

还一新问题，像下面的附件中如果是2个或2个以上的段落只在我多个段落的首尾加一个边框或底纹的标记，中间有段落标记处不加标记（仍保留段落标记），那又该如何处理？因为按上面的代码处理附件中的文档时，每一段都加了标记。

XAFYWF36.rar (2.46 KB, 下载次数: 10)

2007-5-24 14:42 上传

点击文件名下载附件
[求助]下面针对段落边框底纹的VBA代码为何有一半不起作用？

sylun

QUOTE:

以下是引用ssq1109在2007-5-24 14:47:09的发言：

谢谢sylun兄！您分析的很对。

还一新问题，像下面的附件中如果是2个或2个以上的段落只在我多个段落的首尾加一个边框或底纹的标记，中间有段落标记处不加标记（仍保留段落标记），那又该如何处理？因为按上面的代码处理附件中的文档时，每一段都加了标记。

其实我的分析只是大概感觉，并不严密。对增加的限制条件，如下改动不知是否合适：
Sub BKDW2()

    Dim i As Integer, p As Integer, TempRange As Range
    Application.ScreenUpdating = False
    For i = 1 To 2
        p = IIf(i = 1, 1, ActiveDocument.Paragraphs.Count)
        With ActiveDocument.Paragraphs(p).Range
            Set TempRange = ActiveDocument.Range(.Start, .End - 1) '使其不含段落标记
             '判断是否有段落边框
            If .Borders.OutsideLineStyle > 0 Then
                TempRange.InsertBefore "[BK(]"
                TempRange.InsertAfter "[BK)]"  '插入结束标记
            '判断是否有段落底纹
            ElseIf .Shading.BackgroundPatternColor <> wdColorWhite Then
                TempRange.InsertBefore "[DW(]"  '加上起始底纹标记
                TempRange.InsertAfter "[DW)]"   '插入结束标记
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2007-5-24 16:50:39编辑过]

sylun

现在想来我前面理解错了ssq1109兄的意思。再看看如下改动是否符合要求：
Sub BKDW()

    Dim a As Paragraph, TempRange As Range
    On Error Resume Next
    Application.ScreenUpdating = False
        For Each a In ActiveDocument.Paragraphs  '在段落中循环
            With a.Range
                Set TempRange = ActiveDocument.Range(.Start, .End - 1) '使其不含段落标记
                '判断是否有段落边框
                If .Borders.OutsideLineStyle > 0 Then
                    If .Previous(wdParagraph).Borders.OutsideLineStyle < 1 Then
                        TempRange.InsertBefore "[BK(]"
                    End If
                    If .Next(wdParagraph).Borders.OutsideLineStyle < 1 Then
                        TempRange.InsertAfter "[BK)]"  '插入结束标记
                    End If
                '判断是否有段落底纹
                ElseIf .Shading.BackgroundPatternColor <> wdColorAutomatic Then
                    If .Previous(wdParagraph).Shading.BackgroundPatternColor = wdColorAutomatic Then
                        TempRange.InsertBefore "[DW(]"  '加上起始底纹标记
                    End If
                    If .Next(wdParagraph).Shading.BackgroundPatternColor = wdColorAutomatic Then
                        TempRange.InsertAfter "[DW)]"   '插入结束标记
                    End If
                End If
            End With
        Next
    Application.ScreenUpdating = True
End Sub