Question

如何用VBA获取当前页页码

Answer 1

如下：

Sub test()
    p = ExecuteExcel4Macro("Get.Document(50)")
    MsgBox "目前是第" & ThisPage & "页" & Chr(10) & _
           "共" & p & "页"
End Sub
Function ThisPage() As Integer
    Dim sAddr As String, PA As Range
    Dim R0 As Long, C0 As Long
    Dim PAHeight As Long, PAWidth As Long
    Dim Down As Long, Across As Long
    Dim Outside As Long
    Dim NumPage As Long
    If ExecuteExcel4Macro("Get.Document(50)") = 0 Then
        NumPage = ""
        Exit Function
    End If
    If ExecuteExcel4Macro("Get.Document(50)") = 1 Then
        NumPage = 1
        Exit Function
    End If
    sAddr = ExecuteExcel4Macro("GET.DOCUMENT(81)")    '印表区域
    If sAddr <> "" Then    '如果有设定列表区域
        Set PA = Range(sAddr)
    Else
        With ActiveSheet.UsedRange
            Set PA = Range(Cells(1, 1), .Cells(.Cells.Count))    '设定列表区域
        End With
    End If
    If Intersect(ActiveCell, PA) Is Nothing Then
        MsgBox "目前储存格不在列印范围中!"
        NumPage = ""
        Exit Function
    End If
    R0 = PA.Row
    aaa = PA.Address
    PAHeight = GetRowBreaks(R0 + PA.Rows.Count - 1) + 1
    Down = GetRowBreaks(ActiveCell.Row) + 1
    If R0 > 1 Then
        Outside = GetRowBreaks(R0)
        PAHeight = PAHeight - Outside
        Down = Down - Outside
    End If
    C0 = PA.Column
    PAWidth = GetColBreaks(C0 + PA.Columns.Count - 1) + 1
    Across = GetColBreaks(ActiveCell.Column) + 1
    If C0 > 1 Then
        Outside = GetColBreaks(C0)
        PAWidth = PAWidth - Outside
        Across = Across - Outside
    End If
    If ExecuteExcel4Macro("GET.DOCUMENT(61)") = 1 Then    '1 = 先列后行,2 = 先行后列
        '1 = down then over, 2 = over then down
        NumPage = PAHeight * (Across - 1) + Down
    Else
        NumPage = PAWidth * (Down - 1) + Across
    End If
    ThisPage = NumPage
End Function
Private Function GetColBreaks(ColNum As Long) As Long
    Dim sTemp As String
    aa = ExecuteExcel4Macro("GET.DOCUMENT(65)")
    sTemp = Replace("MATCH(#,GET.DOCUMENT(65),1)", "#", ColNum)
    On Error Resume Next
    '取得指定栏位所在的垂直分页线
    GetColBreaks = ExecuteExcel4Macro(sTemp)
End Function
Private Function GetRowBreaks(RowNum As Long) As Long
    Dim sTemp As String
    sTemp = Replace("MATCH(#,GET.DOCUMENT(64),1)", "#", RowNum)
    On Error Resume Next
    '取得指定列位所在的水平分页线
    GetRowBreaks = ExecuteExcel4Macro(sTemp)
End Function