VBA Word编程求助

lingongzhe

如图，我的VBA程序想做到检查RTF文档里是否有三线表跨页显示的情况。目前只是做到了检查每一个文档里页码数和表格数的比对，但是无法定位到具体是哪一页出现了跨页情况，测试文档和我的VBA程序已经上传，求大神帮忙看下，万分感谢！
1.

2.


3. 我的代码

1. Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
   
2. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
3. Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
   
4. Private Const GWL_STYLE = (-16)
   
5. Private Const WS_THICKFRAME As Long = &H40000 '(恢复大小)
   
6. Private Const WS_MINIMIZEBOX As Long = &H20000 '(最小化)
   
7. Private Const WS_MAXIMIZEBOX As Long = &H10000 '(最大化)
   
8. 
   
9. 
   
10. Private Sub UserForm_Initialize()
    
11.    Dim hWndForm As Long
    
12.    Dim IStyle As Long
    
13.    hWndForm = FindWindow("ThunderDFrame", Me.Caption)
    
14.    IStyle = GetWindowLong(hWndForm, GWL_STYLE)
    
15.    IStyle = IStyle Or WS_THICKFRAME '还原
    
16.    IStyle = IStyle Or WS_MINIMIZEBOX '最小化
    
17.    IStyle = IStyle Or WS_MAXIMIZEBOX '最大化
    
18.    SetWindowLong hWndForm, GWL_STYLE, IStyle
    
19. End Sub
    
20. 
    
21. 
    
22. Private Sub CommandButton1_Click()
    
23.     Application.ScreenUpdating = True
    
24.     Application.DisplayAlerts = False
    
25.     Selection.WholeStory
    
26.     Selection.Delete Unit:=wdCharacter, Count:=1
    
27. 
    
28.     rtfPath = TextBox1.Value
    
29.     FName = Dir(rtfPath & "" & "*.rtf")
    
30.     n = 0
    
31.     For Each f In CreateObject("scripting.FileSystemObject").GetFolder(rtfPath).Files
    
32.         fSuff = Split(f.Name, ".")(1)
    
33.         If fSuff = "rtf" Then n = n + 1
    
34.     Next
    
35.    
    
36.     'ThisDocument.Tables(1).Delete
    
37. '插入表格
    
38.     Set myTable = ThisDocument.Tables.Add(Range:=ThisDocument.Range(Start:=0, End:=0), NumRows:=n + 1, NumColumns:=4)
    
39.    
    
40.     With ThisDocument.Tables(1)
    
41.         .Borders.InsideLineStyle = wdLineStyleSingle
    
42.         .Borders.OutsideLineStyle = wdLineStyleSingle
    
43.     End With
    
44.    
    
45.     With ThisDocument.Tables(1)
    
46.         .Cell(Row:=1, Column:=1).Range.InsertAfter Text:="RTF"
    
47.         .Cell(Row:=1, Column:=2).Range.InsertAfter Text:="表格数"
    
48.         .Cell(Row:=1, Column:=3).Range.InsertAfter Text:="页码数"
    
49.         .Cell(Row:=1, Column:=4).Range.InsertAfter Text:="标记"
    
50.     End With
    
51.    
    
52. '实例化word对象
    
53.     On Error Resume Next
    
54.     Set docApp = CreateObject("Word.Application")
    
55.    
    
56.     i = 3
    
57.     If Len(FName) > 0 Then
    
58. '        Dim oDoc As Document
    
59. '        Set oDoc = Word.ActiveDocument
    
60. '        Dim oT As Table
    
61.         docApp.Documents.Open (rtfPath & "" & FName)
    
62.         With ThisDocument.Tables(1)
    
63.             .Cell(Row:=2, Column:=1).Range.InsertAfter Text:=FName
    
64.             .Cell(Row:=2, Column:=2).Range.InsertAfter Text:=docApp.ActiveDocument.Tables.Count
    
65.             .Cell(Row:=2, Column:=3).Range.InsertAfter Text:=docApp.Selection.Information(wdNumberOfPagesInDocument)
    
66.         End With
    
67.         If docApp.ActiveDocument.Tables.Count <> docApp.Selection.Information(wdNumberOfPagesInDocument) Then
    
68.             With ThisDocument.Tables(1)
    
69.                 .Cell(Row:=2, Column:=4).Range.InsertAfter Text:="Y"
    
70.             End With
    
71.             With ThisDocument.Tables(1)
    
72.                 .Cell(Row:=2, Column:=1).Range.Font.ColorIndex = wdRed
    
73.                 .Cell(Row:=2, Column:=2).Range.Font.ColorIndex = wdRed
    
74.                 .Cell(Row:=2, Column:=3).Range.Font.ColorIndex = wdRed
    
75.                 .Cell(Row:=2, Column:=4).Range.Font.ColorIndex = wdRed
    
76.             End With
    
77.         End If
    
78.         pctDone = Format(1 / n, "0.0%")
    
79.         With UserForm1
    
80.             .Label2.Caption = 0
    
81.             .Label2.Caption = pctDone
    
82.         End With
    
83.         docApp.ActiveDocument.Close False
    
84.         Do
    
85.         FName = Dir
    
86.             If FName <> "" Then
    
87.                 docApp.Documents.Open (rtfPath & "" & FName)
    
88.                 With ThisDocument.Tables(1)
    
89.                     .Cell(Row:=i, Column:=1).Range.InsertAfter Text:=FName
    
90.                     .Cell(Row:=i, Column:=2).Range.InsertAfter Text:=docApp.ActiveDocument.Tables.Count
    
91.                     .Cell(Row:=i, Column:=3).Range.InsertAfter Text:=docApp.Selection.Information(wdNumberOfPagesInDocument)
    
92.                 End With
    
93.                 If docApp.ActiveDocument.Tables.Count <> docApp.Selection.Information(wdNumberOfPagesInDocument) Then
    
94.                     With ThisDocument.Tables(1)
    
95.                         .Cell(Row:=i, Column:=4).Range.InsertAfter Text:="Y"
    
96.                     End With
    
97.                     With ThisDocument.Tables(1)
    
98.                         .Cell(Row:=i, Column:=1).Range.Font.ColorIndex = wdRed
    
99.                         .Cell(Row:=i, Column:=2).Range.Font.ColorIndex = wdRed
    
100.                         .Cell(Row:=i, Column:=3).Range.Font.ColorIndex = wdRed
     
101.                         .Cell(Row:=i, Column:=4).Range.Font.ColorIndex = wdRed
     
102.                     End With
     
103.                 End If
     
104.                 pctDone = Format(i / n, "0.0%")
     
105.                 With UserForm1
     
106.                     .Label2.Caption = 0
     
107.                     .Label2.Caption = pctDone
     
108.                 End With
     
109.                 i = i + 1
     
110.                 docApp.ActiveDocument.Close False
     
111.             End If
     
112.         Loop Until Len(FName) = 0
     
113.     End If
     
114.     With UserForm1
     
115.         .Label2.Caption = 100
     
116.     End With
     
117.     Set docApp = Nothing
     
118.     Application.DisplayAlerts = True
     
119.     MsgBox "Finished!", 64, " "
     
120. End Sub
     
121. 
     
122. Private Sub CommandButton2_Click()
     
123.     Set objshell = CreateObject("wscript.shell")
     
124.     Set DosExec = objshell.Exec("cmd.exe /c " & "taskkill /f /t /im WINWORD.exe")
     
125.     Set DosExec = Nothing
     
126.     Set objshell = Nothing
     
127. End Sub
     

复制代码

lingongzhe

有大佬来帮忙解答下吗，目前就是想做到，分别查每一页是否有三线表装不下，并且跨页到了下一页的情况

413191246se

* 请 楼主 试用下面的宏，跨页的表格会变为红色（跨页的单元格第1字符和最后字符不在一页）：

1. Sub aaaa_Test_Tables_Cross_Page()
   
2.     Dim t As Table, c As Cell
   
3.     For Each t In ActiveDocument.Tables
   
4.         For Each c In t.Range.Cells
   
5.             With c.Range
   
6.                 If Len(.Text) > 2 Then
   
7.                     If .Characters.First.Information(wdActiveEndPageNumber) <> _
   
8.                         .Characters.Last.Information(wdActiveEndPageNumber) Then
   
9.                         t.Range.Font.ColorIndex = wdRed
   
10.                     End If
    
11.                 End If
    
12.             End With
    
13.         Next
    
14.     Next
    
15. End Sub

复制代码

lingongzhe

413191246se 发表于 2021-2-4 23:52
* 请 楼主 试用下面的宏，跨页的表格会变为红色（跨页的单元格第1字符和最后字符不在一页）：

感谢回复，我把您的这段程序插到了我程序里红色的部分，但是跑完之后没有变化。我调试了下，层主的意思应该是取表格中第一个字符和最后一个字符，但是代码做到的是取了表格中每一个字符的第一个字符和最后一个字符，所以失败了，如何能够取到表格中的第一个和最后一个字符呢？

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = True
    Application.DisplayAlerts = False
    Dim Pstart As Integer, PEnd As Integer, myRange As Range
    Dim t As Table, c As Cell
    Selection.WholeStory
    Selection.Delete unit:=wdCharacter, Count:=1
    rtfPath = TextBox1.Value
    FName = Dir(rtfPath & "\" & "*.rtf")
    n = 0
    For Each f In CreateObject("scripting.FileSystemObject").GetFolder(rtfPath).Files
        If f.Name Like "*.rtf" Then n = n + 1
    Next
   
    'ThisDocument.Tables(1).Delete
'插入表格
    Set myTable = ThisDocument.Tables.Add(Range:=ThisDocument.Range(Start:=0, End:=0), NumRows:=n + 1, NumColumns:=4)
   
    With ThisDocument.Tables(1)
        .Borders.InsideLineStyle = wdLineStyleSingle
        .Borders.OutsideLineStyle = wdLineStyleSingle
    End With
   
    With ThisDocument.Tables(1)
        .Cell(Row:=1, Column:=1).Range.InsertAfter Text:="RTF"
        .Cell(Row:=1, Column:=2).Range.InsertAfter Text:="表格数"
        .Cell(Row:=1, Column:=3).Range.InsertAfter Text:="页码数"
        .Cell(Row:=1, Column:=4).Range.InsertAfter Text:="标记"
    End With
   
'实例化word对象
    On Error Resume Next
    Set docApp = CreateObject("Word.Application")
   
    i = 3
    If Len(FName) > 0 Then
'        Dim oDoc As Document
'        Set oDoc = Word.ActiveDocument
'        Dim oT As Table
        docApp.Documents.Open (rtfPath & "\" & FName)
        tabCount = docApp.ActiveDocument.Tables.Count
        pageCount = docApp.Selection.Information(wdNumberOfPagesInDocument)


        With ThisDocument.Tables(1)
            .Cell(Row:=2, Column:=1).Range.InsertAfter Text:=FName
            .Cell(Row:=2, Column:=2).Range.InsertAfter Text:=tabCount
            .Cell(Row:=2, Column:=3).Range.InsertAfter Text:=pageCount
        End With
        If tabCount <> pageCount Then
            With ThisDocument.Tables(1)
                .Cell(Row:=2, Column:=4).Range.InsertAfter Text:="Y-"
            End With
            With ThisDocument.Tables(1)
                .Cell(Row:=2, Column:=1).Range.Font.ColorIndex = wdRed
                .Cell(Row:=2, Column:=2).Range.Font.ColorIndex = wdRed
                .Cell(Row:=2, Column:=3).Range.Font.ColorIndex = wdRed
                .Cell(Row:=2, Column:=4).Range.Font.ColorIndex = wdRed
            End With
        End If
        '检查跨页
        For Each t In ActiveDocument.Tables
            For Each c In t.Range.Cells
                With c.Range
                    If Len(.Text) > 2 Then
                        If .Characters.First.Information(wdActiveEndPageNumber) <> _
                            .Characters.Last.Information(wdActiveEndPageNumber) Then
                            t.Range.Font.ColorIndex = wdRed
                            MsgBox .Characters.First.Information(wdActiveEndPageNumber)
                            ThisDocument.Tables(1).Cell(Row:=2, Column:=4).Range.InsertAfter Text:=.Characters.First.Information(wdActiveEndPageNumber) & ", "
                        End If
                    End If
                End With
            Next
        Next
        pctDone = Format(1 / n, "0.0%")
        With UserForm1
            .Label2.Caption = 0
            .Label2.Caption = pctDone
        End With
        docApp.ActiveDocument.Close True
        Do
        FName = Dir
            If FName <> "" Then
                docApp.Documents.Open (rtfPath & "\" & FName)
                tabCount = docApp.ActiveDocument.Tables.Count
                pageCount = docApp.Selection.Information(wdNumberOfPagesInDocument)
                With ThisDocument.Tables(1)
                    .Cell(Row:=i, Column:=1).Range.InsertAfter Text:=FName
                    .Cell(Row:=i, Column:=2).Range.InsertAfter Text:=tabCount
                    .Cell(Row:=i, Column:=3).Range.InsertAfter Text:=pageCount
                End With
                If tabCount <> pageCount Then
                    With ThisDocument.Tables(1)
                        .Cell(Row:=i, Column:=4).Range.InsertAfter Text:="Y-"
                    End With
                    With ThisDocument.Tables(1)
                        .Cell(Row:=i, Column:=1).Range.Font.ColorIndex = wdRed
                        .Cell(Row:=i, Column:=2).Range.Font.ColorIndex = wdRed
                        .Cell(Row:=i, Column:=3).Range.Font.ColorIndex = wdRed
                        .Cell(Row:=i, Column:=4).Range.Font.ColorIndex = wdRed
                    End With
                End If
                '检查跨页
                For Each t In ActiveDocument.Tables
                    For Each c In t.Range.Cells
                        With c.Range
                            If Len(.Text) > 2 Then
                                If .Characters.First.Information(wdActiveEndPageNumber) <> _
                                    .Characters.Last.Information(wdActiveEndPageNumber) Then
                                    t.Range.Font.ColorIndex = wdRed
                                    MsgBox .Characters.First.Information(wdActiveEndPageNumber)
                                    ThisDocument.Tables(1).Cell(Row:=2, Column:=4).Range.InsertAfter Text:=.Characters.First.Information(wdActiveEndPageNumber) & ", "
                                End If
                            End If
                        End With
                    Next
                Next
                pctDone = Format(i / n, "0.0%")
                With UserForm1
                    .Label2.Caption = 0
                    .Label2.Caption = pctDone
                End With
                i = i + 1
                docApp.ActiveDocument.Close True
            End If
        Loop Until Len(FName) = 0
    End If
    With UserForm1
        .Label2.Caption = 100
    End With
    Set docApp = Nothing
    Application.DisplayAlerts = True
    MsgBox "Finished!", 64, " "
End Sub

lingongzhe

@413191246se ， 大佬帮我看看，我这个代码为啥放到循环里就实现不了呀，太奇怪了趴！

1.                 For currentPage = 1 To pageCount
   
2.                     Pstart = Selection.GoTo(what:=wdGoToPage, Which:=wdGoToNext, Name:=1).Start
   
3.                     PEnd = Selection.GoTo(what:=wdGoToPage, Which:=wdGoToNext, Name:=currentPage).End
   
4.                     Set myRange = ActiveDocument.Range(Pstart, PEnd)
   
5.                     nowTabcount = myRange.Tables.Count
   
6.                     MsgBox "当前页数：" & currentPage
   
7.                     MsgBox "截至当前页的表格数：" & nowTabcount
   
8.                 Next

复制代码

lingongzhe

413191246se 发表于 2021-2-4 23:52
* 请 楼主 试用下面的宏，跨页的表格会变为红色（跨页的单元格第1字符和最后字符不在一页）：

哈哈谢谢大佬，虽然你的宏没跑出来，但是已经用的思路解决了这个问题，万分感谢万分感谢！！！！