ACCESS 名簿を考えてみる

テーブル

テーブルのフィールド名・データ型です。

copy

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 curReportName       As String
Private curFormName         As String
Private CapRepo             As Dictionary
Private CmdBL               As Variant
Private Const Margin        As Long = 56
'---------------------------------------
'
Public Property Let SetReport(ByVal NewName As String)
    Dim Ret                 As Variant
    On Error Resume Next

    '------表示しているフォーム・レポートを閉じる
    Call ObjClose

    '------新しいレポートを開く
    DoCmd.OpenReport NewName, acViewPreview
    curReportName = NewName

    '------ベースに表示するレポート・フォームの位置とサイズを調整
    Call MWindow

    '------新しいレポートの子ウィンドウを親ウィンドウのフォームに設定
    SetParent Reports(curReportName).hWnd, Me.hWnd
    DoCmd.SelectObject acReport, curReportName

End Property
'---------------------------------------
'
Public Property Get SetReport() As String

    SetReport = curReportName

End Property
'---------------------------------------
'
Public Property Let SetForm(ByVal NewName As String)
    Dim Ret             As Variant
    On Error Resume Next

    '------表示しているフォーム・レポートを閉じる
    Call ObjClose

    '------新しいフォームを開く
    DoCmd.OpenForm NewName, acNormal
    curFormName = NewName

    '------ベースに表示するレポート・フォームの位置とサイズを調整
    Call MWindow

    '------新しいフォームの子ウィンドウを親ウィンドウのフォームに設定
    SetParent Forms(curFormName).hWnd, Me.hWnd
    DoCmd.SelectObject acForm, curFormName

End Property
'---------------------------------------
'
Public Property Get SetForm() As String

    SetForm = curFormName

End Property
'---------------------------------------
'
Private Sub ObjClose()
    Dim Rpt             As Report
    Dim Frm             As Form
    On Error Resume Next

    '------表示しているレポートを閉じる
    If Len(curReportName) > 0 Then
        For Each Rpt In Reports
            If Rpt.Name = curReportName Then
                DoCmd.Close acReport, Rpt.Name
                curReportName = ""
            End If
        Next Rpt
    End If

    '------表示しているフォームを閉じる
    If Len(curFormName) > 0 Then
        For Each Frm In Forms
            If Frm.Name = curFormName Then
                DoCmd.Close acForm, Frm.Name
                curFormName = ""
            End If
        Next Frm
    End If

End Sub
'---------------------------------------
'
Private Sub Form_Load()
    Dim Ret             As Variant
    Dim SetValue        As Long
    Dim OpenObj         As Variant
    Dim I               As Long
    On Error Resume Next

    '------Win32API関数を使ってアクセスを最小化します
    CloseWindow Application.hWndAccessApp

    '------現在の設定値を取得
    SetValue = GetWindowLong(Me.hWnd, GWL_STYLE)

    '------最小化ボタンを無効
    SetValue = SetValue And Not WS_MINIMIZEBOX

    '------設定値をセット
    SetWindowLong Me.hWnd, GWL_STYLE, SetValue

    '------単位変換の変換率の計算
    TP = TwipPixel

    '------ボタンのキャプションリスト
    CmdBL = Array("一覧プレ", "タックシールプレ", "選択フォーム")

    '------ボタンのキャプションをセット
    For I = 0 To UBound(CmdBL)
        Me("bu" & I).Caption = CmdBL(I)
    Next I

    '------ボタンのキャプション名とレポート名・フォーム名の
    '      ハッシュテーブル
    Set CapRepo = New Dictionary
    With CapRepo
        .Add CmdBL(0), "R:レポート1"
        .Add CmdBL(1), "R:レポート2"
        .Add CmdBL(2), "F:フォーム1"
    End With

    '------初期値
    curReportName = ""
    curFormName = ""

    '------子フォームの原点
    X = 0
    Y = Me.bu閉じる.Height + Me.bu閉じる.Top * 2

    '------子フォームの大きさ
    Call ChildFormSize

    '------フォームの OpenArgs プロパティを使用します
    If IsNull(Me.OpenArgs) Then
        Call ChangeObj(CapRepo("選択フォーム"))
    Else
        Call ChangeObj(Me.OpenArgs)
    End If

End Sub
'---------------------------------------
'
Private Sub Form_Close()

    Call ObjClose

    Set CapRepo = Nothing

End Sub
'---------------------------------------
'
Private Sub Form_Resize()
    Dim Ret             As Variant
    On Error Resume Next

    '------リサイズ後のレポート・フォームのサイズ
    Call ChildFormSize

    '------ベースに表示するレポート・フォームの位置とサイズを調整
    Call MWindow

    '------ボタンの配置
    Call BuPosiSet

End Sub
'---------------------------------------
'
Private Sub bu印刷_Click()
    On Error Resume Next

    If Len(curReportName) = 0 Then
        Exit Sub
    End If

    DoCmd.SelectObject acReport, curReportName, False
    DoCmd.RunCommand acCmdPrint

End Sub
'---------------------------------------
'
Private Sub bu閉じる_Click()

    DoCmd.Quit acQuitSaveNone

End Sub
'---------------------------------------
'
Private Sub bu0_Click()

    Call ChangeObj(CapRepo(Me.bu0.Caption))

End Sub
'---------------------------------------
'
Private Sub bu1_Click()

    Call ChangeObj(CapRepo(Me.bu1.Caption))

End Sub
'---------------------------------------
'
Private Sub bu2_Click()

    Call ChangeObj(CapRepo(Me.bu2.Caption))

End Sub
'---------------------------------------
'
Private Sub ChangeObj(ByVal strCap As String)
    Dim OpenObj             As Variant

    OpenObj = Split(strCap, ":")

    If OpenObj(0) = "F" Then
        SetForm = OpenObj(1)
    Else
        SetReport = OpenObj(1)
    End If

End Sub
'---------------------------------------
'
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)

    TwipPixel = CLng(1440 / GetDeviceCaps(nhDc, LOGPIXELSX))

End Function
'---------------------------------------
'
Private Sub MWindow()
    Dim Ret             As Variant

    If Len(curReportName) > 0 Then
        Ret = MoveWindow(Reports(curReportName).hWnd, _
                         X / TP, _
                         Y / TP, _
                         cx / TP, _
                         cy / TP, _
                         SWP_SHOWWINDOW)
    End If

    If Len(curFormName) > 0 Then
        Ret = MoveWindow(Forms(curFormName).hWnd, _
                         X / TP, _
                         Y / TP, _
                         cx / TP, _
                         cy / TP, _
                         SWP_SHOWWINDOW)
    End If

End Sub
'---------------------------------------
'
Private Sub BuPosiSet()
    Dim buStart             As Long
    Dim buAreaLen           As Long
    Dim I                   As Long

    buStart = Me.bu閉じる.Width + _
              Me.bu印刷.Width + _
              Margin * 2

    For I = 0 To UBound(CmdBL)
        buAreaLen = buAreaLen + _
                    Me("bu" & I).Width + Margin
    Next I

    If buStart < (cx - buAreaLen) Then
        Me("bu0").Left = buStart + _
                         ((cx - buStart - buAreaLen) / 2)
    Else
        Me("bu0").Left = buStart
    End If

    For I = 1 To UBound(CmdBL)
        Me("bu" & I).Left = Me("bu" & (I - 1)).Left + _
                            Me("bu" & (I - 1)).Width + Margin
    Next I

End Sub
'---------------------------------------
'
Private Sub ChildFormSize()

    cx = Me.InsideWidth
    cy = Me.InsideHeight - Y

End Sub

標準モジュール「M_API」のコード

API関数を使っています。

結構な数になりました。