ACCESS 名簿を考えてみる 2

2022年12月10日

何かと年を感じるなと思っている柴犬です。

今回の概要

レコードを選択できるようにしました。

レコードの選択はレコードセレクターをクリックします。

するとチェックボックスにチェックが入ります。

ボタン「一覧プレ」をクリックしてプレビューを表示しました。

つづいて、ボタン「タックシールプレ」をクリックしてプレビューを表示しました。

表題の「全選択」をクリックしてみます。

すると、全レコードのチェックボックスにチェックが入り選択状態になります。

また、表題の「全選択」は「選択解除」になります。

表題の「選択解除」をクリックしてみます。

すると、全レコードのチェックボックスにチェックが外れ未選択状態になります。

また、表題の「選択解除」は「全選択」になります。

ACCESSのフォームの修正

テキストボックスなどオブジェクトの配置

テキストボックス「selected」「ID」とチェックボックス「チェック1」を配置します。

「チェック1」のプロパティ

「チェック1」のプロパティを変更します。

コントロールソースに式を書く加えます。

規定値を False にします。

コントロールソースがちょっと見にくいため、次にコードを載せました。

=IIf(InStr(selected.Value & ",","," & ID.Value & ",")>0,True,False)

テキストボックス「selected」のプロパティ

テキストボックス「selected」のプロパティの可視を「いいえ」にします。

テキストボックス「ID」のプロパティ

テキストボックス「ID」のプロパティの可視を「いいえ」にします。

コントロールソースを「ID」にします。

コード

フォーム「フォーム1 」

すべて新しく追加しています。

説明は、後で自分が困らない程度にコードの中で行っています。

copy

Option Compare Database
Option Explicit

Private myList              As String
Private myParent            As String
Private AllList             As String
Private TargetList          As String
'---------------------------------------
'
Private Sub Form_Open(Cancel As Integer)
    Dim UF                  As Object

    '------親フォーム名
    myParent = Me.OpenArgs

    '------親フォームを探査します。
    For Each UF In Forms
        With UF
            If .Name = myParent Then
                '------全IDのリストを取得します。
                AllList = .AllList
                TargetList = .TargetList
            End If
        End With
    Next UF

End Sub
'---------------------------------------
'
Private Sub Form_Load()

    '------TargetList に既選択がある場合
    If TargetList <> "" Then
        Me.selected.Value = "," & TargetList
    End If

End Sub
'---------------------------------------
'
Private Sub Form_Click()
    Dim BUF                 As String
    Dim UF                  As Object
    Dim AddFLG              As Long

    If Me.SelHeight > 0 Then

        If InStr(Me.selected.Value & ",", _
                 "," & Me.ID.Value & ",") = 0 Then
            '------クリックしたレコードのIDを追加します。
            Me.selected.Value = Me.selected.Value & "," & Me.ID.Value
            '------選択のフラッグ
            AddFLG = 1
        Else
            '------検索文字列の調整
            BUF = Me.selected.Value & ","
            '------クリックしたレコードのIDを削除します。
            BUF = Replace(BUF, _
                          "," & Me.ID.Value & ",", _
                          ",")
            '------最後尾のカンマを削除します。
            Me.selected.Value = Left(BUF, Len(BUF) - 1)
            '------削除のフラッグ
            AddFLG = -1
        End If

        Me.Recalc

        For Each UF In Forms
            If UF.Name = myParent Then
                '------先頭のカンマを削除します。
                TargetList = Mid(Me.selected.Value, 2)
                UF.TargetList = TargetList
            End If
        Next UF

        '------全選択・選択解除のキャプション
        Call AllCheck(AddFLG)

    End If

End Sub
'---------------------------------------
'
Private Sub AllCheck(ByVal AddFLG As Long)
    Dim TargetDict          As Dictionary
    Dim ArrayBUF            As Variant
    Dim I                   As Long
    Dim Check               As Boolean

    '------選択がない状態
    If TargetList = "" Then
        Me.ラベル選択.Caption = "全選択"
        Exit Sub
    End If

    '------初期値
    Check = True

    '------選択がある ID ハッシュテーブルを作成します。
    ArrayBUF = Split(TargetList, ",")
    Set TargetDict = New Dictionary
    With TargetDict
        For I = 0 To UBound(ArrayBUF)
            If Not TargetDict.Exists(ArrayBUF(I)) And ArrayBUF(I) <> "" Then
                .Add ArrayBUF(I), 1
            End If
        Next I
    End With

    '------全 ID とハッシュテーブルと照合します。
    ArrayBUF = Split(AllList, ",")
    For I = 0 To UBound(ArrayBUF)
        If Not TargetDict.Exists(ArrayBUF(I)) Then
            '------全て選択されていない。
            Check = False
            I = UBound(ArrayBUF)
        End If
    Next I

    '------全て選択されていれば選択解除とします。
    If Check Then
        Me.ラベル選択.Caption = "選択解除"

    '------一部が選択されている。
    Else
        Select Case AddFLG
        Case 1
            '------選択を追加した場合
            Me.ラベル選択.Caption = "全選択"
        Case -1
            '------選択を削除した場合
            Me.ラベル選択.Caption = "選択解除"
        End Select
    End If

End Sub
'---------------------------------------
'
Private Sub ラベル選択_Click()
    Dim UF                  As Object

    Select Case Me.ラベル選択.Caption
    Case "全選択"
        Me.ラベル選択.Caption = "選択解除"
        Me.selected.Value = "," & AllList
        TargetList = AllList
    Case "選択解除"
        Me.ラベル選択.Caption = "全選択"
        Me.selected.Value = ""
        TargetList = ""
    End Select

    Me.Recalc

    For Each UF In Forms
        If UF.Name = myParent Then
            UF.TargetList = TargetList
        End If
    Next UF

End Sub

レポート「レポート1 」「レポート2 」

レポート1・レポート2とも同じです。

copy

Option Compare Database
Option Explicit

Private myList              As String
Private myParent            As String

Private Sub Report_Open(Cancel As Integer)
    Dim UF                  As Object
    Dim mySQL               As String

    myParent = Me.OpenArgs

    For Each UF In Forms
        If UF.Name = myParent Then
            myList = UF.TargetList
        End If
    Next UF

    mySQL = "SELECT * "
    mySQL = mySQL & "FROM テーブル1 AS A "
    mySQL = mySQL & "WHERE A.ID IN (" & myList & ");"
    
    Me.RecordSource = ""
    Me.RecordSource = mySQL

End Sub

フォーム「ベース」

修正・追加は次の3カ所あります。

レポートから参照するためのプロパティを新しく追加しました。

Private memTargetList       As String
Private memAllList          As String
'---------------------------------------
'
Public Property Let TargetList(ByVal myList As String)
    memTargetList = myList
End Property

Public Property Get TargetList() As String
    TargetList = memTargetList
End Property

Public Property Let AllList(ByVal myAllList As String)
    memAllList = myAllList
End Property

Public Property Get AllList() As String
    AllList = memAllList
End Property

プロシージャ「 ChangeObj 」の修正

全「 ID 」を取得した分を作成する「 Call getAllList 」の実行を追加します。

また、選択がない場合レポートを開かないようにIf文「If TargetList = “” Then」を追加します。

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

    OpenObj = Split(strCap, ":")

    If OpenObj(0) = "F" Then

        '------全レコードのIDを取得します。（追加）
        Call getAllList

        SetForm = OpenObj(1)
    Else

        '------選択がない場合レポートを開かないようにしています。（追加）
        If TargetList = "" Then
            MsgBox "選択がありません。"
            Exit Sub
        End If

        SetReport = OpenObj(1)
    End If

End Sub

getAllList プロシージャを新規に作成

プロシージャ「 ChangeObj 」から使っています。

このプロシージャの仕事は、名簿の「テーブル1」のフィール「 ID 」をカンマ区切りの一つの文を作成します。

そして、作成した文をプロパティ「 AllList 」を経由して変数「memAllList」に代入します。

Private Sub getAllList()
    Dim Db                  As DAO.Database
    Dim Rs                  As DAO.Recordset

    Set Db = CurrentDb()

    Set Rs = Db.OpenRecordset("SELECT A.ID FROM テーブル1 AS A;", _
                              dbOpenSnapshot)
    
    If Not Rs.EOF Then
        Do Until Rs.EOF
            If AllList = "" Then
                AllList = Rs.Fields("ID")
            Else
                AllList = AllList & "," & Rs.Fields("ID")
            End If
            Rs.MoveNext
        Loop
    End If

    Rs.Close
    Db.Close

End Sub

まとめ

最後なりましたので、フォーム「ベース」のすべてのコードを記載しています。

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
Private memTargetList       As String
Private memAllList          As String
'---------------------------------------
'
Public Property Let TargetList(ByVal myList As String)
    memTargetList = myList
End Property

Public Property Get TargetList() As String
    TargetList = memTargetList
End Property

Public Property Let AllList(ByVal myAllList As String)
    memAllList = myAllList
End Property

Public Property Get AllList() As String
    AllList = memAllList
End Property
'---------------------------------------
'
Public Property Let SetReport(ByVal NewName As String)
    Dim Ret                 As Variant
    On Error Resume Next

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

    '------新しいレポートを開く
    DoCmd.OpenReport NewName, acViewPreview, OpenArgs:=Me.Name
    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, OpenArgs:=Me.Name
    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 = ""
    TargetList = ""
    AllList = ""

    '------子フォームの原点
    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

        '------全レコードのIDを取得します。（追加）
        Call getAllList

        SetForm = OpenObj(1)
    Else

        '------選択がない場合レポートを開かないようにしています。（追加）
        If TargetList = "" Then
            MsgBox "選択がありません。"
            Exit Sub
        End If

        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
'---------------------------------------
'
Private Sub getAllList()
    Dim Db                  As DAO.Database
    Dim Rs                  As DAO.Recordset

    Set Db = CurrentDb()

    Set Rs = Db.OpenRecordset("SELECT A.ID FROM テーブル1 AS A;", _
                              dbOpenSnapshot)
    
    If Not Rs.EOF Then
        Do Until Rs.EOF
            If AllList = "" Then
                AllList = Rs.Fields("ID")
            Else
                AllList = AllList & "," & Rs.Fields("ID")
            End If
            Rs.MoveNext
        Loop
    End If

    Rs.Close
    Db.Close

End Sub

ACCESS 名簿を考えてみる 2

今回の概要

ACCESSのフォームの修正

テキストボックスなどオブジェクトの配置

「チェック1」のプロパティ

テキストボックス「selected」のプロパティ

テキストボックス「ID」のプロパティ

コード

フォーム「 フォーム1 」

レポート「 レポート1 」「 レポート2 」

フォーム「 ベース 」

プロシージャ「 ChangeObj 」の修正

getAllList プロシージャを新規に作成

まとめ

フォーム「フォーム1 」

レポート「レポート1 」「レポート2 」

フォーム「ベース」