スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

貸出台帳もどきの雰囲気? 


1.貸し出しの時に、使用者名・所属・TEL・借用日・返却予定日を記入し、借りる備品をリストから選択(この時複数選択する)

2.返却の時に、使用者名を選択すると借用中リストを表示し、返却した備品を一つずつ選択、または一括返却ボタンで一括返却する。

3.貸し出し・返却の履歴を残す。
※備品の破損・紛失の際に、借用者の履歴が分かるようにしたい。

このようなQAを見かけました。
初心者という事なんですが、やりたいものを作る・・・・初心者云々は関係ないように思います。

そこで、1.、2. だけを雰囲気作ってみた。
ただ、、やりたいものと同じなのかはわからないけど・・・

メインとなるフォームは「F1」単票フォームに、サブフォーム2つ組み込み
サブフォームは横に配置して、
左側:貸出中の一覧表示
右側:貸出受付みたいなもの

kEnt211_7.jpg

起動して、顧客を選択していない状態では、左側に貸出中の一覧を表示

kEnt211_5.jpg

顧客を選択すると、左側には選択した顧客に絞った貸出中一覧表示に

kEnt211_6.jpg

返却チェックを入れると「返却」ボタンが表示
返却するのなら、そのままボタンをクリック
新規に貸し出すものがあるのなら、物を選んで「貸出」ボタンクリック
「貸出」ボタンをクリックするまでは、仮押さえっていうイメージで・・・
以下は新規に登録する時の画像になりますが、
左:顧客を選択して、中:貸出するものを選んで、右:「貸出」ボタンクリック後

kEnt211_3.jpg  kEnt211_4.jpg  kEnt211_5.jpg

中の画像で、貸出中のもの・仮押さえのものは選択一覧には表示されない様に・・・
(左画像内の一覧から、仮押さえしたもの以外が表示されていると思います)

選択する部分は、コンボボックスになっています。
顧客選択・受付部分の品物選択の2つは、部分一致で絞り込み表示する様に・・・

左側:「務」を入れてみる 右側:「D」を入れてみる

kEnt211_8.jpg  kEnt211_9.jpg

メイン・サブフォームの連動は、リンク親/子フィールドは使わないで連携してみました。
というのは、顧客を選び直した・・・このタイミングで中の処理を切り替えたかったので・・・

なお、動きを実現するにあたって、hatena さんの記事で紹介されたものをアレンジして使ってます。
非連結のチェックボックスでレコードを選択する とか コンボボックスのリストを入力値で制限する とか・・・
 
まず、これを実現する為に用意したテーブルは4つ

「T品物」
hid、品名、ふりがな

「T所属」
sid、所属

「T顧客」
pid、コード、氏名、ふりがな、sid、TEL
sid は「T所属」をルックアップ

「T貸出」
an、仮、hid、pid、借用日、返却予定日、返却日、更新日時、備考
an はオートナンバ
hid は「T品物」をルックアップ
pid は「T顧客」をルックアップ

※ 仮 は、本登録時 =0、仮押さえ(既定)時 =-1

基本的には、「T貸出」だけで何でもやってしまおう・・・
仮押さえ時、借用日、返却日、更新日時 は未設定
本登録時に、仮=0 と、借用日、更新日時 を設定する
貸出中は、返却日 Is Null で判別

どの品物を誰に貸出したか・・・
誰がどの品物を借りたか・・・
「T貸出」から条件抽出するだけで判るようになってますね・・・

品物の紛失・破損等は、
・「T品物」にフィールドを増やして情報を持たせるか
・別途、紛失・破損等の情報テーブルを追加して、
 そのテーブルに無い品物だけを貸出し対象にするとか・・・
扱いやすい方法で追加していけば良いと思います。


メイン・サブフォームの連携

メインフォームの「顧客選択」「今日の設定」が変更されたタイミングで、サブフォームの処理を切り替えます。
その際、各サブフォームに記述した
Public Sub init(dt As Date, pid As Long)
を呼び出す様に
Public Sub init()
  Dim v As Variant

  For Each v In Array(Me.FSUB1, Me.FSUB2)
    Call v.Form.init(Me.txt1, Nz(Me.cbx1, 0))
  Next
End Sub

FSUB1 が左側のサブフォームコントロール名、FSUB2 が右側・・・となっています。
親フォーム部分も Public になっているのは、
右側サブフォームで「貸出」ボタンで、仮から本登録した際に左側の表示も更新したかったから・・・

左側サブフォーム「F_S1」

「T顧客」内の pid は 1 ~ 採番しているので、init での pid が 0 なら全員分を・・・
この時には、詳細部分に顧客名を表示する様に・・・
pid <> 0 の場合、顧客名はメインに表示されているので、詳細部分の顧客表示は不可視に・・・

表示する際の抽出条件は
・仮=0 AND 返却日 Is Null が基本
・pid <> 0 の時、例えば pid = 1 なら上記に加えて AND pid = 1
表示順は、pid, 返却予定日, hid

返却のチェックボックスは非連結にて・・・
hatenaa さん記事のアレンジで、
・チェックボックスの上に透明のコマンドボタン btn0 を配置
・チェックを付けた(コマンドボタン btn0 のクリック)・・・で覚えるのは、オートナンバの「an」値
 覚える先を Dictionary のキーとして
 「an」を覚えていたのなら情報削除し、覚えていなかったら「an」を覚えて・・・
 覚えたものが1つでもあったら、「返却」ボタンを表示して・・・・
 コントロールソースの解釈をさせるように  Me.Recalc
Private Sub btn0_Click()
  Dim i As Long

  i = Me.an
  If (dic.Exists(i)) Then
    dic.Remove i
  Else
    dic(i) = Null
  End If
  Me.btn2.Visible = dic.Count > 0 ' 返却ボタン
  Me.Painting = False
  Me.Recalc
  Me.Painting = True
End Sub
※ Me.Recalc はチェックを速く表示したかったので・・・
テキストボックスを使うより速くなったので・・・残骸がヘッダに「txt1」・・・これ、未使用
・返却のチェックボックスのコントロールソースを =myCheckMark()
 その関数内では
Private Function myCheckMark() As Boolean
  On Error Resume Next
  With Me.RecordsetClone
    .Bookmark = Me.Bookmark
    myCheckMark = dic.Exists(.Fields("an").Value)
  End With
End Function
Dictionary 内に対象レコードの「an」を覚えていたか・・・

この画面で修正できるのは、返却予定日、備考 の2つ
記述したのは以下になりますが、
  If (Me.Dirty) Then Me.Dirty = False ' ★
この行を追加してください。
現状では、返却予定日、備考 の2つを変更した後、「返却」ボタンをクリックした場合、
反映されないタイミングがあります。

Dim iPid As Long
Dim dtNow As Date
Dim dic As Object

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag <> "") Then Cancel = True
End Sub

Private Sub Form_Load()
  Me.txt1 = 0
  Set dic = CreateObject("Scripting.Dictionary")
  Call init(Date, 0)
  Me.cb1.ControlSource = "=myCheckMark()"
End Sub

Public Sub init(dt As Date, pid As Long)
  Dim sS As String
  Dim i As Long
  Const CSQL As String = "" _
    & "SELECT * FROM T貸出 " _
    & "WHERE 仮=0 AND 返却日 Is Null {%1} " _
    & "ORDER BY pid, 返却予定日, hid;"

  On Error Resume Next
  iPid = pid
  dtNow = dt
  sS = ""
  If (iPid <> 0) Then sS = "AND pid=" & iPid
  Me.RecordSource = Replace(CSQL, "{%1}", sS)
  Me.btn0.SetFocus
  Me.pid.Visible = iPid = 0
  Me.btn1.Visible = Me.Recordset.RecordCount > 0
  Me.btn2.Visible = False
  dic.RemoveAll
  Me.Painting = False
  Me.Recalc
  Me.Painting = True
End Sub

Private Function myCheckMark() As Boolean
  On Error Resume Next
  With Me.RecordsetClone
    .Bookmark = Me.Bookmark
    myCheckMark = dic.Exists(.Fields("an").Value)
  End With
End Function

Private Sub btn0_Click()
  Dim i As Long

  i = Me.an
  If (dic.Exists(i)) Then
    dic.Remove i
  Else
    dic(i) = Null
  End If
  Me.btn2.Visible = dic.Count > 0
  Me.Painting = False
  Me.Recalc
  Me.Painting = True
End Sub

Private Sub btn1_Click()
  On Error Resume Next
  With Me.RecordsetClone
    .MoveFirst
    While (Not .EOF)
      dic(.Fields("an").Value) = Null
      .MoveNext
    Wend
  End With
  Me.btn2.Visible = dic.Count > 0
  Me.Painting = False
  Me.Recalc
  Me.Painting = True
End Sub

Private Sub btn2_Click()
  Dim sSql As String
  Const CSQL As String = "" _
    & "UPDATE T貸出 SET 返却日=#{%1}#, 更新日時=Now() " _
    & "WHERE an IN ({%2});"

  If (Me.Dirty) Then Me.Dirty = False ' ★
  sSql = CSQL
  sSql = Replace(sSql, "{%1}", dtNow)
  sSql = Replace(sSql, "{%2}", Join(dic.Keys, ","))
  CurrentDb.Execute sSql
  Call init(dtNow, iPid)
End Sub

Private Sub 返却予定日_DblClick(Cancel As Integer)
  Dim sArgs As String

  sArgs = Me.借用日 & ","
  DoCmd.OpenForm "F_DATE", acNormal, , , , , sArgs
  Cancel = True
End Sub


Private Sub Form_Close()
  Set dic = Nothing
End Sub

※ 「返却」ボタンをクリックした際に「返却日」に設定される日付は、
メインに表示されている「今日の設定」の日になります。
ただ、「更新日時」には Now() を設定します。
これは、操作者によって(?)、過去に返却した事にしましょうとか・・・
「今日の設定」の設定の仕方によって、色々対応できるかも・・・
でも、レコードとしての更新日時は無条件に 今!!( Now() )
後々、返却日と更新日時の日付が違うデータの抽出等すれば・・・

※ 上記には、まだまだ処理を加えないと、使い物にはならないと思います。
というのは、レコードをいじった際の「更新日時」を設定・・・
現状では、「返却」をクリックした時だけ設定しています。
「返却」せずに「返却予定日」だけ変更したとか・・・「備考」だけ・・・の時には設定・更新されません。


右側サブフォーム「F_S2」

このフォームにも、hatena さんの記事をアレンジしたものを使っています。
それは、品物を選択するコンボボックスへの入力部分・・・
入力したものに沿った一覧表示するというもの。
また、私の過去記事「重ねる」でのコンボボックスを重ねるというもの
入力したものに沿った一覧を表示する入力用のものと、表示するだけ用のコンボボックスを重ねています。
入力用のものを上側に配置して、大きさ・背景色を同じにして、上側の背景スタイルだけ透明に・・・
見ている分には、下側表示用の背景色が見えており、
上側の入力用にフォーカスが入ると、上側の透明は透明でなくなり上側の背景色が・・・

入力中の仮押さえは、
hid、pid、返却予定日 の3つだけ設定します。
仮押さえの「仮」は、既定を -1 を設定していたので・・・・
コンボボックスのリストに表示するのは、
・「仮」の値には着目せずに、「返却日」が Null のものと、品物全部との不一致で・・・
 ただし、仮押さえしたレコードを再度いじる時には、上記不一致+前に設定したもので・・・

「貸出」ボタンがクリックされたら、
・「仮」を本登録 =0 に変更し、足りない情報を設定しますが、
 操作によてコンボボックスの表示を空欄にした場合もあるかも・・・
 ということで、hid が Null のものは、仮押さえしていたレコードを削除することに

・「取消」をクリック、もしくは「貸出」せずに顧客を変更したとか・・・フォームを閉じたとか・・・
 この場合には、仮押さえしていたレコードを削除する様に・・・

「基本返却日」は、「今日の設定」+7 日を設定しています。
ここは、メインの「顧客選択」「今日の設定」に変更あれば設定し直します。
その後は、自由に変更できます。
品物を選び始めると、仮押さえレコードの「返却予定日」としてコピーされます。
その後は、「返却予定日」を個別に変更できます。

Dim iPid As Long
Dim dtNow As Date
Dim bKeyIn As Boolean

Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"
Const CSQL As String = "" _
  & "SELECT * FROM T貸出 " _
  & "WHERE 仮<>0 AND pid={%1};"

Const CCBX1SQL As String = "" _
  & "SELECT Q1.hid, Q1.品名,Q1.ふりがな FROM T品物 AS Q1 LEFT JOIN " _
  & "(SELECT hid FROM T貸出 WHERE 返却日 Is Null) AS Q2 ON Q1.hid=Q2.hid " _
  & "WHERE Q2.hid Is Null OR Q1.hid={%0} " _
  & "ORDER BY 品名;"

Const CCBX1SQLS As String = "" _
  & "SELECT hid, 品名 FROM " _
  & "(SELECT Q1.* FROM T品物 AS Q1 LEFT JOIN " _
  & "(SELECT hid FROM T貸出 WHERE 返却日 Is Null) AS Q2 ON Q1.hid=Q2.hid " _
  & "WHERE Q2.hid Is Null OR Q1.hid={%0}) AS Q3 " _
  & "WHERE 品名 Like '*{%1}*' OR ふりがな Like '*{%1}*' " _
  & "ORDER BY 品名;"


Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag <> "") Then Cancel = True
End Sub

Private Sub Form_Load()
  Call init(Date, 0)
End Sub

Public Sub init(dt As Date, pid As Long)
  Dim sS As String
  Dim i As Long

  On Error Resume Next
  dtNow = dt
  Me.基本返却日 = dtNow + 7
  If (iPid <> pid) Then btn3_Click
  iPid = pid
  Me.RecordSource = Replace(CSQL, "{%1}", iPid)
  Me.btn0.SetFocus
  If (Me.Recordset.RecordCount > 0) Then
    Me.btn2.Visible = True
    Me.btn3.Visible = True
  Else
    Me.btn2.Visible = False
    Me.btn3.Visible = False
  End If
End Sub

Private Sub Form_BeforeInsert(Cancel As Integer)
  If (iPid = 0) Then
    Cancel = True
  Else
    Me.pid = iPid
    Me.返却予定日 = Me.基本返却日
    Me.btn2.Visible = True
    Me.btn3.Visible = True
  End If
End Sub


Private Sub btn2_Click()
  On Error Resume Next
  If (Me.Dirty) Then Me.Dirty = False
  With Me.RecordsetClone
    .MoveFirst
    While (Not .EOF)
      If (IsNull(.Fields("hid"))) Then
        .Delete
      Else
        .Edit
        .Fields("仮") = 0
        .Fields("借用日") = dtNow
        .Fields("更新日時") = Now()
        .Update
      End If
      .MoveNext
    Wend
  End With
  Call Me.Parent.init
End Sub

Private Sub btn3_Click()
  On Error Resume Next
  If (Me.Dirty) Then Me.Dirty = False
  With Me.RecordsetClone
    .MoveFirst
    While (Not .EOF)
      .Delete
      .MoveNext
    Wend
  End With
  Call init(dtNow, iPid)
End Sub

Private Sub cbx1_GotFocus()
  Me.cbx1.RowSource = Replace(CCBX1SQL, "{%0}", Nz(Me.cbx1.OldValue, 0))
  Me.cbx1.Dropdown
End Sub

Private Sub cbx1_KeyDown(KeyCode As Integer, Shift As Integer)
  With Me.cbx1
    Select Case KeyCode
      Case vbKeyDown, vbKeyUp
        .OnChange = ""
      Case vbKeyEscape
        .Undo
        .RowSource = Replace(CCBX1SQL, "{%0}", Nz(Me.cbx1.OldValue, 0))
        .SelStart = 0
        .SelLength = Len(.Text)
        .OnChange = EVENT_PROCEDURE
        KeyCode = 0
      Case Else
        .OnChange = EVENT_PROCEDURE
    End Select
  End With
  bKeyIn = True
End Sub

Private Sub cbx1_Change()
  Dim sSql As String

  If (bKeyIn) Then
    sSql = CCBX1SQLS
    sSql = Replace(sSql, "{%0}", Nz(Me.cbx1.OldValue, 0))
    sSql = Replace(sSql, "{%1}", Me.cbx1.Text)
    Me.cbx1.RowSource = sSql
    Me.cbx1.Dropdown
  End If
End Sub

Private Sub cbx1_Click()
  bKeyIn = False
End Sub


Private Sub 基本返却日_DblClick(Cancel As Integer)
  Dim sArgs As String

  sArgs = dtNow & ","
  DoCmd.OpenForm "F_DATE", acNormal, , , , , sArgs
  Cancel = True
End Sub

Private Sub 返却予定日_DblClick(Cancel As Integer)
  Dim sArgs As String

  sArgs = dtNow & ","
  DoCmd.OpenForm "F_DATE", acNormal, , , , , sArgs
  Cancel = True
End Sub

Private Sub Form_Close()
  Call btn3_Click
End Sub


※ hatena さん記事をアレンジして ESC キーの取り消しを組み込んでみたのですが・・・
ソコソコ良さそうなんだけど、良くない時もあって・・・
      Case vbKeyEscape
        .Undo
        .RowSource = Replace(CCBX1SQL, "{%0}", Nz(Me.cbx1.OldValue, 0))
この部分は、少なくとも以下に変更した方が良いんでしょうね
      Case vbKeyEscape
        .RowSource = Replace(CCBX1SQL, "{%0}", Nz(Me.cbx1.OldValue, 0))
        .Undo


サブフォームとして組み込んだものの記述に
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Me.Parent.Tag <> "") Then Cancel = True
End Sub
がありますが、過去記事で色々書いてましたが、
サブフォームとして組み込まれた使われ方でなければ、起動しない(開かない)記述になります。
今回はこの記述にて・・・

※ このフォームを作ってみて勉強になった事
・Enter と GotFocus の違いを認識できた
 Enter は1度フォーカスを得てしまうと以降発生しないけど、
 GotFocus は何度でもフォーカスを得ると発生するみたい・・・
サブフォーム間をマウスクリックで行き来してみると・・・何となく・・・嘘かも??


メインフォーム「F1」

メインフォームは、「顧客選択」「今日の設定」処理が主
記述は、コンボボックスでの入力に絞ったリスト一覧表示用の処理が大半

Dim bKeyIn As Boolean

Const EVENT_PROCEDURE As String = "[EVENT PROCEDURE]"

Const CCBX1SQL As String = "" _
  & "SELECT Q1.pid, Q1.氏名, Q1.コード, Q2.所属, Q1.TEL FROM " _
  & "T顧客 AS Q1 LEFT JOIN T所属 AS Q2 ON Q1.sid = Q2.sid " _
  & "ORDER BY Q1.ふりがな;"

Const CCBX1SQLS As String = "" _
  & "SELECT Q1.pid, Q1.氏名, Q1.コード, Q2.所属, Q1.TEL FROM " _
  & "T顧客 AS Q1 LEFT JOIN T所属 AS Q2 ON Q1.sid = Q2.sid " _
  & "WHERE Q1.氏名 Like '*{%1}*' OR " _
  & "Q1.コード Like '*{%1}*' OR " _
  & "Q1.ふりがな Like '*{%1}*' OR " _
  & "Q1.TEL Like '*{%1}*' OR " _
  & "Q2.所属 Like '*{%1}*' " _
  & "ORDER BY Q1.ふりがな;"

Private Sub Form_Load()
  Me.txt1 = Date
  Call init
End Sub

Public Sub init()
  Dim v As Variant

  For Each v In Array(Me.FSUB1, Me.FSUB2)
    Call v.Form.init(Me.txt1, Nz(Me.cbx1, 0))
  Next
End Sub


Private Sub cbx1_GotFocus()
  Me.cbx1.RowSource = CCBX1SQL
  Me.cbx1.Dropdown
End Sub

Private Sub cbx1_KeyDown(KeyCode As Integer, Shift As Integer)
  With Me.cbx1
    Select Case KeyCode
      Case vbKeyDown, vbKeyUp
        .OnChange = ""
      Case vbKeyEscape
        .Undo
        .RowSource = CCBX1SQL
        .SelStart = 0
        .SelLength = Len(.Text)
        .OnChange = EVENT_PROCEDURE
        KeyCode = 0
      Case Else
        .OnChange = EVENT_PROCEDURE
    End Select
  End With
  bKeyIn = True
End Sub

Private Sub cbx1_Change()
  If (bKeyIn) Then
    Me.cbx1.RowSource = Replace(CCBX1SQLS, "{%1}", Me.cbx1.Text)
    Me.cbx1.Dropdown
  End If
End Sub

Private Sub cbx1_AfterUpdate()
  Call init
End Sub

Private Sub cbx1_Click()
  bKeyIn = False
End Sub

Private Sub txt1_AfterUpdate()
  Call init
End Sub

Private Sub txt1_DblClick(Cancel As Integer)
  DoCmd.OpenForm "F_DATE", acNormal
  Cancel = True
End Sub


なお、日付部分の所でダブルクリックすると、過去記事にあった「日付入力支援」フォームが開きます。
操作等は、過去記事を参照してください。
(今記述するとしたら、もっと短くできるんだろうなぁ~~)

「今日の設定」では、制限なしで日付を選択する事が出来ますが、
他の部分では、「今日の設定」以前は選べない様になってます。


※ このサンプルは雰囲気でのものになるので・・・・

色々と、処理・タイミング等考慮してください。
「日付入力支援」では選べない様にしていたけど、直入力では自由だとか・・・
この他にも色々あると思います。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt211_2000.zipkEnt211_2003.zipkEnt211_2007.zip
 サイズ 68,97370,50474,310
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2015/03/11

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。