Option Compare Database
Option Explicit

'プレビューから現在のページを印刷する関数(Access97専用)

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal cchClassName As Long) As Long

Private Declare Function GetFocus Lib "user32" () As Long

Private Declare Function GetWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal uCmd As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
    ByVal hwnd As Long, _
    ByVal lpsz As String, _
    ByVal cch As Long) As Long

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const VK_F5 = &H74
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101

Public Function PrintCurrentPage() As Long
    Dim hwnd As Long
    Dim hwnd2 As Long
    Dim sBuffer As String
    Dim dtTimeOut As Date
    Dim bSuccess As Boolean
    Dim iRet As Long
    Dim iErr As Long
    Dim iPage As Long

    On Error Resume Next
    hwnd = Screen.ActiveReport.hwnd
    iErr = Err
    On Error GoTo 0
    If iErr <> 0 Then
        On Error Resume Next
        hwnd = Screen.ActiveForm.hwnd
        iErr = Err
        On Error GoTo 0
        If iErr <> 0 Then
            On Error Resume Next
            hwnd = Screen.ActiveControl.Parent.hwnd
            iErr = Err
            On Error GoTo 0
            If iErr <> 0 Then
                MsgBox "プレビューウィンドウがアクティブではありません。", vbExclamation
                Exit Function
            End If
        End If
    End If

    hwnd2 = FindChildWindow(hwnd, "OPrtPrevPage")
    If hwnd2 = 0 Then
        MsgBox "プレビューウィンドウがアクティブではありません。", vbExclamation
        Exit Function
    End If

    hwnd2 = FindChildWindow(hwnd, "OSUI")
    If hwnd2 = 0 Then
        MsgBox "プレビューウィンドウがアクティブではありません。", vbExclamation
        Exit Function
    End If

    hwnd = GetFocus()
    iRet = PostMessage(hwnd, WM_KEYDOWN, VK_F5, 0)
    iRet = PostMessage(hwnd, WM_KEYUP, VK_F5, 0)

    bSuccess = False
    dtTimeOut = Now() + 10 / (24# * 60 * 60)
    Do
        DoEvents
        sBuffer = String$(255, Chr$(0))
        hwnd = GetFocus()
        iRet = GetClassName(hwnd, sBuffer, Len(sBuffer))
        sBuffer = Left$(sBuffer, InStr(1, sBuffer, Chr$(0), 0) - 1)
        If StrComp(sBuffer, "OKttbx", 0) = 0 Then
            bSuccess = True
            Exit Do
        End If
    Loop Until Now() > dtTimeOut

    If Not bSuccess Then
        MsgBox "ページ番号ボックスをアクティブにできませんでした。", vbExclamation
        Exit Function
    End If

    bSuccess = False
    dtTimeOut = Now() + 10 / (24# * 60 * 60)
    Do
        DoEvents
        sBuffer = String$(255, Chr$(0))
        iRet = GetWindowText(hwnd, sBuffer, Len(sBuffer))
        sBuffer = Left$(sBuffer, InStr(1, sBuffer, Chr$(0), 0) - 1)
        If sBuffer <> "" Then
            On Error Resume Next
            iPage = CLng(sBuffer)
            iErr = Err
            On Error GoTo 0
            bSuccess = (iErr = 0)
            Exit Do
        End If
    Loop Until Now() > dtTimeOut

    If Not bSuccess Then
        MsgBox "ページ番号の取得に失敗しました。", vbExclamation
        Exit Function
    End If

    iRet = MsgBox(CStr(iPage) & " ページを印刷します。", vbOKCancel Or vbExclamation)
    If iRet <> vbOK Then Exit Function

    DoCmd.PrintOut acPages, iPage, iPage
End Function


Private Function FindChildWindow(ByVal hwnd As Long, _
        ByVal sClassName As String) As Long
    Dim hwnd2 As Long
    Dim sBuffer As String
    Dim iRet As Long

    FindChildWindow = 0
    hwnd2 = GetWindow(hwnd, GW_CHILD)
    If hwnd2 = 0 Then
        Exit Function
    End If
    Do
        sBuffer = String$(255, Chr$(0))
        iRet = GetClassName(hwnd2, sBuffer, Len(sBuffer))
        sBuffer = Left$(sBuffer, InStr(1, sBuffer, Chr$(0), 0) - 1)
        If StrComp(sBuffer, sClassName, 0) = 0 Then
            FindChildWindow = hwnd2
            Exit Do
        End If
        hwnd2 = GetWindow(hwnd2, GW_HWNDNEXT)
    Loop Until hwnd2 = 0
End Function