Option Compare Database
Option Explicit
'------------------------------------------------------------
Private TP As Long
Private X As Long
Private Y As Long
Private cx As Long
Private cy As Long
Private memReportName As String
'------------------------------------------------------------
'
Public Property Let ReportName(ByVal NewName As String)
Dim Ret As Variant
Dim Rpt As Report
Dim OldName As String
On Error Resume Next
OldName = memReportName
If OldName <> NewName Then
'表示しているレポートを閉じる
Then Rpt In Reports
If Rpt.Name = OldName Then
DoCmd.Close acReport, OldName
Exit For
End If
Next Rpt
'新しいレポートを開く
DoCmd.OpenReport NewName, acViewPreview
memReportName = NewName
Ret = MoveWindow(Reports(memReportName).hwnd, X / TP, Y / TP, cx / TP, cy / TP, 1)
'新しいレポートの子ウィンドウを親ウィンドウのフォームに設定
SetParent Reports(memReportName).hwnd, Me.hwnd
End If
End Property
'------------------------------------------------------------
Public Property Get ReportName() As String
ReportName = memReportName
End Property
'------------------------------------------------------------
Private Sub Form_Load()
Dim Ret As Variant
On Error Resume Next
Me.btnDummy.SetFocus
TP = TwipPixel
'フォームに表示するレポートの位置とサイズを調整します
X = 0
Y = Me.フォームヘッダー.Height 'Y = Me.コマンド0.Heightでもよい
cx = Me.InsideWidth
cy = Me.InsideHeight - Me.フォームヘッダー.Height
'Win32API関数を使ってアクセスを最小化します
CloseWindow Application.hWndAccessApp
'フォームの OpenArgs プロパティを使用します
If Len(memReportName) = 0 Then
Exit Sub
Else
memReportName = Me.OpenArgs
End If
'レポートをプレビューします
DoCmd.OpenReport ReportName, acViewPreview
Ret = MoveWindow(Reports(ReportName).hwnd, X / TP, Y / TP, cx / TP, cy / TP, 1)
'レポートの子ウィンドウを親ウィンドウのフォームに設定
SetParent Reports(ReportName).hwnd, Me.hwnd
End Sub
'------------------------------------------------------------
Private Sub Form_Resize()
Dim Ret As Variant
On Error Resume Next
'フォームに表示するレポートの位置とサイズを調整します
X = 0
Y = Me.フォームヘッダー.Height 'Y = Me.コマンド0.Heightでもよい
cx = Me.InsideWidth
cy = Me.InsideHeight - Me.フォームヘッダー.Height
Ret = MoveWindow(Reports(ReportName).hwnd, X / TP, Y / TP, cx / TP, cy / TP, 1)
End Sub
'------------------------------------------------------------
Private Sub コマンド0_Click()
Me.btnDummy.SetFocus
DoCmd.SelectObject acReport, ReportName, False
DoCmd.RunCommand acCmdPrint
End Sub
'------------------------------------------------------------
Private Sub コマンド1_Click()
Me.btnDummy.SetFocus
DoCmd.Close acReport, ReportName
DoCmd.Close acForm, Me.Name
End Sub
'------------------------------------------------------------
Private Sub コマンド2_Click()
Me.btnDummy.SetFocus
ComForeColor "コマンド2"
If コマンド2.ForeColor = vbRed Then
ChangeReport コマンド2.Caption
End If
End Sub
'------------------------------------------------------------
Private Sub コマンド3_Click()
Me.btnDummy.SetFocus
ComForeColor "コマンド3"
If コマンド3.ForeColor = vbRed Then
ChangeReport コマンド3.Caption
End If
End Sub
'------------------------------------------------------------
Private Sub ComForeColor(ByVal strName As String)
Dim Ctrl As Control
Then Ctrl In Me.Controls
If Ctrl.Name = strName Then
Ctrl.ForeColor = vbRed
Else
If Ctrl.ForeColor <> Me.コマンド0.ForeColor Then
Ctrl.ForeColor = Me.コマンド0.ForeColor
End If
End If
Next Ctrl
End Sub
'-------------------------------------------------------------------
Private Sub ChangeReport(ByVal strCap As String)
Dim BUF As String
Select Case strCap
Case "帳票"
BUF = "レポート1"
Case "タックシール"
BUF = "レポート2"
End Select
ReportName = BUF
End Sub
Option Compare Database
Option Explicit
'パラメータ
'hWnd ウィンドウへのハンドル､および間接的に､ウィンドウが属するクラス
'nIndex 取得する値へのゼロベースのオフセット
Public Const GWL_EXSTYLE = -20 '拡張ウィンドウスタイルを取得します
Public Const GWL_STYLE = -16 'ウィンドウスタイルを取得します
Public Const GWL_HWNDPARENT = -8 '親ウィンドウあれば、そのハンドルを取得します
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
'パラメータ
'hWnd ウィンドウへのハンドル､および間接的に､ウィンドウが属するクラス
'nIndex 取得する値へのゼロベースのオフセット
'dwNewLong 置換値
'GetWindowLongAで得られた値(Val) に対して、最小化ボタンを無効にする場合[dwNewLong = Val And Not WS_MINIMIZEBOX]とする
Public Const WS_OVERLAPPED = &H0 'オーバーラップウィンドウ
Public Const WS_MAXIMIZEBOX = &H10000 '最大化ボタン
Public Const WS_MINIMIZEBOX = &H20000 '最小化ボタン
Public Const WS_SIZEBOX = &H40000 'サイズ変更境界
Public Const WS_THICKFRAME = &H40000 'サイズ変更境界
Public Const WS_SYSMENU = &H80000 'ウィンドウメニュー WS_CAPTIONスタイルも指定する必要があります
Public Const WS_CAPTION = &HC00000 'タイトルバー
Public Const WS_HSCROLL = &H100000 '水平スクロールバー
Public Const WS_VSCROLL = &H200000 '垂直スクロールバー
Public Const WS_BORDER = &H800000 '境界線
Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
'----------------------------------------------------------------------
'パラメータ
'hWndChild 子ウィンドウへのハンドル
'hWndNewParent 新しい親ウィンドウへのハンドル
Public Declare PtrSafe Function SetParent Lib "user32" ( _
ByVal hWndChild As Long, _
ByVal hWndNewParent As Long) As Long
'----------------------------------------------------------------------
'パラメータ
'hwnd ウィンドウへのハンドル
'X ウィンドウの左側の新しい位置 (ピクセル単位)
'Y ウィンドウの上部の新しい位置 (ピクセル単位)
'nWidth ウィンドウの新しい幅 (ピクセル単位)
'nHeight ウィンドウの新しい高さ (ピクセル単位)
'bRepaintウィンドウを再描画するかどうかを示します（1:再描画 0:再描画しない）
Public Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
'----------------------------------------------------------------------
'パラメータ
'hWnd ウィンドウへのハンドル
'hWndInsertAfter Zオーダーで配置されたウィンドウの前にあるウィンドウのハンドル このパラメーターは､ウィンドウハンドルまたは次の値のいずれかでなければなりません
Public Const HWND_TOP = &H0 'ウィンドウをZオーダーの一番上に配置します
Public Const HWND_TOPMOST = -1 'ウィンドウを最上位以外のすべてのウィンドウの上に配置します
'X クライアント座標での､ウィンドウの左側の新しい位置 (ピクセル単位)
'Y クライアント座標でのウィンドウ上部の新しい位置 (ピクセル単位)
'cx ウィンドウの新しい幅 (ピクセル単位)
'cy ウィンドウの新しい高さ (ピクセル単位)
'uFlags ウィンドウのサイズ変更および配置フラグ このパラメーターは､以下の値の組み合わせにすることができます
Public Const SWP_NOMOVE = &H2 '現在の位置を保持します（ XおよびYパラメーターを無視します）
Public Const SWP_NOSIZE = &H1 '現在のサイズを保持します（ cxおよびcyパラメーターを無視します）
Public Const SWP_SHOWWINDOW = &H40 'ウィンドウを表示します
Public Declare PtrSafe Function SetWindowPos Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal hWndInsetAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal uFlags As Long _
) As Long
'----------------------------------------------------------------------
Private Const HORZRES As Long = 8 '画面の幅 (ピクセル単位)
Private Const VERTRES As Long = 10 '画面の高さ (ピクセル単位)
Private Const BITSPIXEL As Long = 12 '各ピクセルの隣接するカラービットの数
Private Const LOGPIXELSX As Long = 88 '画面の幅方向の論理インチあたりのピクセル数
Private Const LOGPIXELSY As Long = 90 '画面の高方向の論理インチあたりのピクセル数
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long
'----------------------------------------------------------------------
Public Function TwipPixel() As Long
Dim DskhWnd As Long
Dim nhDc As Long
Dim Bit As Long
Dim nWidth As Long
Dim nHeight As Long
'デスクトップのハンドル
DskhWnd = GetDesktopWindow
'デスクトップのデバイスコンテキストハンドル
nhDc = GetDC(DskhWnd)
'画面の横幅
nWidth = GetDeviceCaps(nhDc, HORZRES)
'画面の縦幅
nHeight = GetDeviceCaps(nhDc, VERTRES)
'ピクセル当たりのビット数
Bit = GetDeviceCaps(nhDc, BITSPIXEL)
'1インチ＝1440Twips
TwipPixel = CLng(1440 / GetDeviceCaps(nhDc, LOGPIXELSX))
End Function