FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

十択問題までサポートする選択問題用サンプル 


旧記事掲載:2010/01/03

過去、知恵袋の方で回答した
「Access VBAを使って4択問題を出すプログラムを作りたい」を発展させたサンプルになります。

Web検索しても同様のものはヒットしないので(私の検索がヘタ?)
回答そのもののフォーム/テーブル(名前は変更しました)/VBA記述を使用したサンプルと
十択問題までサポートする選択問題用サンプルになります。

主要なテーブルとフォームの関係は以下の様になります。

kSample91_Table      kSample91_Form

また、以下の機能も組み込んでみました。

1)社員選択&パスワード認証
2)処理以外でフォームを起動できなくする
3)連結フォームでの削除操作をフラグ操作に置き換える
4)親子リンクで親が確定していない時に子で編集できないようにする
5)サブフォーム処理中は親を閉じれないようにする

フォームのプロパティをいじる他は、すべてVBA記述になってます。

なお、上記1)2)は、Excelへ色付き簡易カレンダーを出力する を流用しています。
詳しくはそちらで。
また、今回2)については、サブフォームでの記述を追加しています。
 
回答時のサンプルは以下で構成されてます。
フォーム: F1
テーブル: T_問題、T_解答
クエリ: Q1

詳細な内容は、回答を見るか、実物を見てください。
動きとしては、
初期表示は、構成しているものそのものが表示されます。
問題ボタンで、問題番号=1のものをオプショングループに表示し、解答ボタンを非表示に。
選択することで、解答ボタンが表示されます。
解答ボタンをクリックすることで、内容がテーブルに保存されます。
(解答ボタンをクリックすればクリックした分だけ保存)
結果は、クエリ「Q1」を開いて確認します。


十択問題までサポートする選択問題用サンプルは以下の様になります。
記述順として、
・標準モジュールへの記述内容
・各フォームでの機能/動きと記述内容


【標準モジュールへの記述】

' 解答用オプショングループの最大値
Public Const AnsOptValueMax = 10

' 操作者
Public snoSaved As Long

' 解答用問題番号
Public iQNums() As Long

' 起動メニューフォーム名
Const CHKFORM = "F_起動M"



' 起動時判別(各フォーム Form_Open で Cancel = CheckOpen とする)
Public Function CheckOpen() As Integer
  If (snoSaved = 0) Then
    CheckOpen = True
  Else
    CheckOpen = False
  End If
End Function

' ログイン認証後に起動するフォーム名を返す
Public Function WakeUpFormName() As String
  Dim sFormName As String

  sFormName = "F_分岐"
  If (CurrentProject.AllForms(CHKFORM).IsLoaded) Then
    With Forms(CHKFORM)
      If (Len(Nz(.Tag)) > 0) Then sFormName = .Tag
    End With
  End If
  WakeUpFormName = sFormName
End Function

' ログイン認証後に起動されたフォームが閉じる時に呼ばれる
' 起動メニューを再表示する
Public Sub ReWakeUpMenu()
  snoSaved = 0
  If (CurrentProject.AllForms(CHKFORM).IsLoaded) Then
    Forms(CHKFORM).Visible = True
  Else
    DoCmd.OpenForm CHKFORM
  End If
  Call Forms(CHKFORM).Init
End Sub

' 乱数設定用
Public Function RndInit() As Boolean
  Randomize
  RndInit = True
End Function

Public Function myRnd(v As Variant) As Single
  myRnd = Rnd
End Function

 

【各フォームでの機能/動きと記述内容】

主要フォームの関係は以下の様になっています。

kSample91_Form

「F_起動M」

kSample91_1

今回、起動すると「F_起動M」が自動的に表示されるようになっています。
問題設定用のフォームを起動できるようにメニューを構成していますが、
通常運用になれば、一般者には問題設定部分は不要になるので、
ログイン画面「F_ログイン」から起動します。
但し、この時先のフォーム「F_問題」「F_分岐」終了時に「F_起動M」を再表示させるために
標準モジュールに記述した ReWakeUpMenu を呼び出しているので、
ReWakeUpMenu 内を書き換えて再表示させないようにする必要があります。
今回は起動すべきフォームの格納場所に、自フォームの Tag を使いましたが、
グローバル変数に持った方が楽です。
それにより今回用意した関数も要らなくなります。
(参照先が変わるだけで関数自体は存続しても・・・)

「F_起動M」での記述
' オプショングループを未選択状態に
Public Sub Init()
  Me.op1 = 0
End Sub

Private Sub Form_Load()
  Call Init
End Sub

' ボタンがクリックされたら、回答した内容フォームを起動
' 起動されていたら1度閉じてから
Private Sub btn1_Click()
  Const F1 = "F1"

  If (CurrentProject.AllForms(F1).IsLoaded) Then
    DoCmd.Close acForm, F1, acSaveNo
  End If
  DoCmd.OpenForm F1
End Sub

' オプショングループが起動されたら、ログイン認証後に起動するフォーム名を
' 自フォームの Tag へ設定後、非表示にし、F_ログインを起動
' この Tag を参照する関数を標準モジュールに用意
Private Sub op1_Click()
  Select Case Me.op1
    Case 1
      Me.Tag = "F_問題"
    Case 2
      Me.Tag = "F_分岐"
  End Select
  Me.Visible = False
  DoCmd.OpenForm "F_ログイン"
End Sub

 

「F_ログイン」

kSample91_2

Excelへ色付き簡易カレンダーを出力する を流用したもので、
フォームを起動する部分の1行を以下に変更しています。
    DoCmd.OpenForm WakeUpFormName

 
「F_問題」と「F_問題SUB」

kSample91_3

設問と選択肢を登録管理する帳票フォームにサブフォームを組み込んだフォームになります。
親フォームのレコードソースは、
SELECT T問題.* FROM T問題 WHERE (((T問題.use)=True));
子フォームのレコードソースは、
SELECT T選択.* FROM T選択 WHERE (((T選択.use)=True)) ORDER BY T選択.選択肢番号;
サブフォームコントロールに設定するリンク親/子フィールドは、問題番号。

T問題/T選択/T解答テーブルは、問題番号、選択肢番号で結び付けますが、
この番号2つを意識させないように内部処理に統一しています。
各番号は、現在の最大値+1で採番するようにしています。
レコードセレクタを使って、削除操作された場合、
本当に削除してしまうと過去に解答したデータから辿れなくなるので、
今は無効なデータである(use = False)フラグを設け、このフラグ値を操作するようにしています。
よって表示する対象は、use = True のものとし、削除で use = False へ。
この内容を表示するために、ヘッダ部に「全設定数」「有効数」を配置しています。
それぞれのコントロールソースは、
有効数: =Count(*)
全設定数: =DCount("*","T問題")

3)連結フォームでの削除操作をフラグ操作に置き換える

削除の操作を行うと、
Form_Delete / (Form_Current) / Form_BeforeDelConfirm / Form_AfterDelConfirm
の4つのイベントが順に立て続けに発生します。
何もしないと、「削除しますか?」のAccessからのメッセージは、
Form_BeforeDelConfirm 後に表示されます。
Form_Delete ~ Form_BeforeDelConfirm 間は対象レコードをいじるとエラーとなります。
よって、
Form_Delete では、削除対象のレコードを覚え、
Form_BeforeDelConfirm では、次に対象となるレコードを覚え、削除操作をキャンセルし、
Form_AfterDelConfirm で、削除対象だったレコードのフラグ変更と再クエリ、次の対象に移動
という流れになります。
この流れをそのまま実現すると、表示画面がちらつきます。
(削除操作での表示更新/キャンセルによる表示戻し/再クエリでの表示更新/移動時での表示)
そこで、Me.Painting = False / True で一連の処理を挟み込みます。
これで画面のちらつきがおさまります。

登録した設問の出題順として、テーブル内に乱数そのものを格納する「rd」フィールドを設けています。
「シャッフル」ボタンクリックで、乱数の書き込みを行い、表示順を「乱数」に変更します。
乱数の値は、0以上 ~ 1 未満 であるため、新規登録時には 2 としています。
「シャッフル」操作をしない限り、問題に解答していく順に変更はありません。
週一回、月一回、でシャッフルするとか・・・

表示順は、レコードソースで指定するのではなく、フォーム内部だけでできる OrderBy を利用します。

2)処理以外でフォームを起動できなくする

Excelへ色付き簡易カレンダーを出力する で記述した方法でもできますが、
サブフォーム専用で考えてみます。
(データベースウィンドウに表示/ナビゲーションに表示されたフォームをから、ダブルクリックした際に起動させないようにするものになります。)
' サブフォームとして起動されていなければ Cancel = True
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (IsNull(Me.Parent)) Then
    Cancel = True
  End If
End Sub

この方法は、On Error Resume Next の動きを使った例となります。
単独で起動されようとすると Me.Parent 参照でエラーとなります。
エラーになったら「次の行」を実行するので、 Cancel = True が動くことになります。
なので、特に IsNull である必要はありませんが、組み込まれた起動時にエラーとならない記述にしておく必要があります。

他の方法としては、
Private Sub Form_Open(Cancel As Integer)
  Dim oTmp as Object
  On Error Resume Next
  Set oTmp = Me.Parent
  If (Err <> 0)) Then ' エラー番号で判別
    Cancel = True
  End If
End Sub
とか、上記 If 文を変更した
  If (oTmp Is Nothing) Then ' 値が Set されたかで判別
があると思います。(未検証)

4)親子リンクで親が確定していない時に子で編集できないようにする

このフォームでは、問題番号で親子リンクを設定していますが、
親で新規に移動した時点で、子側も表示が切り替わります。
この状態で子側の編集をキャンセルする方法として以下を記述しました(子側に記述)
' 親フォームの問題番号が確定していなければ(新規登録等)、編集状態にさせない
Private Sub Form_Dirty(Cancel As Integer)
  If (IsNull(Me.Parent.問題番号)) Then
    Cancel = True
  End If
End Sub

フォームの「ダーティー時」イベントで、親の問題番号が設定されているか判別します。
  If (IsNull(Me.Parent.問題番号)) Then
の部分は
  If (IsNull(Me.問題番号)) Then
でも良いのでは?と思うかもしれません。
これは私の環境だけなのかもしれないのですが、動きとしては次の様になります。
親の問題番号が確定している時、
 子の新規では、Me.問題番号 は NULL
親の問題番号が確定していない時、
 子の新規では、Me.問題番号 は NULL

子側で、この「ダーティー時」処理せずに編集状態に突入すると、
更新前処理では、Me.問題番号 は NULL ではなく、親の問題番号と同じ値が得られました。
ということは、「ダーティー時」の判別に Me.問題番号 は使えない。ということに。
※新規登録時は、挿入前処理(Form_BeforeInsert)で判別した方がよさそうです。

親が単票フォームなら大丈夫なのだろうか?(未検証)

なお、選択肢のテーブル「T選択」に、おまけ的に「加算点」を設けています。
正解した時に+αを加算するとか、不正解時にマイナス点を設定するとかに使えるように。


「F_問題」での記述
Dim sDelAns As String
Dim vPos As Variant


' レコード移動時にサブフォームの「レコード移動時」を実行
' サブフォームのレコード移動時では、レコードの追加を許可する/しないを制御
' 許可しない状態の後、選択肢データのない問題に移動した際には、
'  サブフォームのレコード移動時は実行されない
' なので、サブフォームのレコード数云々の判別をするより、サブフォーム内で処理させる
Private Sub Form_Current()
  Call Me.FSUB.Form.Form_Current
End Sub

Private Sub Form_Open(Cancel As Integer)
  Cancel = CheckOpen
End Sub

Private Sub Form_Load()
  sDelAns = ""
  Me.op1 = 1
  Call op1_Click
End Sub

' レコードセレクタを使って削除操作された時、実際に削除されてしまっては
' 履歴表示等の履歴操作に支障が出る。
' よって、削除操作では、テーブル内部の use フラグを False へ変更するものとする。
' 一連の表示/利用では use = True のものだけを対象とする。
'  Form_Delete / Form_BeforeDelConfirm / Form_AfterDelConfirm の順で削除操作されるので
'  始まり/終了時に Paintig 制御(これをしないと画面表示がちらつくので)

' 削除対象の問題番号を覚える
Private Sub Form_Delete(Cancel As Integer)
  Me.Painting = False
  sDelAns = sDelAns & "," & Me.問題番号
End Sub

' 削除したとして、次の表示対象を覚えておく
' Cancel = True せずに戻っていくと、その後で「削除しますか」メッセージが出る
' この処理の中でレコードを更新しようとするとエラーとなるので、
' 実際の処理は AfterDelConfirm に任せる。
' 削除対象、次の表示対象は覚えたので、Cancel = True で元に戻してやる。
Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)
  vPos = Me.問題番号
  Cancel = True
End Sub

' 削除対象があったら(の判別は不要だけど)対象の use を False へ
' 再クエリし、次の表示対象の位置に移動
Private Sub Form_AfterDelConfirm(Status As Integer)
  Dim sSql As String

  If (Len(sDelAns) > 0) Then
    sSql = "UPDATE T問題 SET use = False WHERE 問題番号 IN (" & Mid(sDelAns, 2) & ") ;"
    CurrentProject.Connection.Execute sSql
  End If
  sDelAns = ""
  Me.Requery
  If (IsNull(vPos)) Then
    DoCmd.GoToRecord , , acNewRec
  Else
    Me.Recordset.FindFirst "問題番号=" & vPos
  End If
  Me.Painting = True
End Sub

' 更新前処理で、新規データなら問題番号を採番し、
' 乱数部分を最後になるように 2.0 をデフォルト設定
Private Sub Form_BeforeUpdate(Cancel As Integer)
  If (Me.NewRecord) Then
    Me.問題番号 = Nz(DMax("問題番号", "T問題")) + 1
    Me.rd = 2#
  End If
End Sub

' 更新後処理で、配点の既定値を編集した配点に置き換える
Private Sub Form_AfterUpdate()
  Me.配点.DefaultValue = CStr(Me.配点)
End Sub

' 表示順は、フォーム上での表示順を使用する
Private Sub op1_Click()
  Dim sOrder As String

  Select Case Me.op1
    Case 1: sOrder = "[問題番号]"
    Case 2: sOrder = "[配点],[問題番号]"
    Case 3: sOrder = "[rd],[問題番号]"
  End Select
  Me.OrderBy = sOrder
  Me.OrderByOn = True
End Sub

' シャッフルボタンでは、use が True / False にかかわらず、
' 乱数の値そのままを設定する。
' 表示を乱数順に切り替える
Private Sub btn1_Click()
  Dim sSql As String

  sSql = "UPDATE T問題 SET rd = myRnd([問題番号]) WHERE RndInit() ;"
  CurrentProject.Connection.Execute sSql
  Me.Requery
  Me.op1 = 3
  Call op1_Click
End Sub

Private Sub btn2_Click()
  DoCmd.Close acForm, Me.Name, acSaveNo
End Sub

Private Sub Form_Close()
  Call ReWakeUpMenu
End Sub

 

「F_問題SUB」での記述
Dim sDelAns As String
Dim vPos As Variant


' サブフォームとして起動されていなければ Cancel = True
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (IsNull(Me.Parent)) Then
    Cancel = True
  End If
End Sub

Private Sub Form_Load()
  sDelAns = ""
End Sub

' レコード移動時に追加を許可する/しない、を判別設定
Public Sub Form_Current()
  If (Me.Recordset.RecordCount < AnsOptValueMax) Then
    Me.AllowAdditions = True
  Else
    Me.AllowAdditions = False
  End If
End Sub


' レコードセレクタを使って削除操作された時、実際に削除されてしまっては
' 履歴表示等の履歴操作に支障が出る。
' よって、削除操作では、テーブル内部の use フラグを False へ変更するものとする。
' 一連の表示/利用では use = True のものだけを対象とする。
'  Form_Delete / Form_BeforeDelConfirm / Form_AfterDelConfirm の順で削除操作されるので
'  始まり/終了時に Paintig 制御(これをしないと画面表示がちらつくので)

' 削除対象の an を覚える
Private Sub Form_Delete(Cancel As Integer)
  Me.Painting = False
  sDelAns = sDelAns & "," & Me.an
End Sub

' 削除したとして、次の表示対象を覚えておく
' Cancel = True せずに戻っていくと、その後で「削除しますか」メッセージが出る
' この処理の中でレコードを更新しようとするとエラーとなるので、
' 実際の処理は AfterDelConfirm に任せる。
' 削除対象、次の表示対象は覚えたので、Cancel = True で元に戻してやる。
Private Sub Form_BeforeDelConfirm(Cancel As Integer, Response As Integer)
  vPos = Me.an
  Cancel = True
End Sub

' 削除対象があったら(の判別は不要だけど)対象の use を False へ
' 再クエリし、次の表示対象の位置に移動
' 追加の許可がしないになっている状態で、全レコードを変更すると、再クエリ後
' レコード移動時イベントは発生しないので、許可しないままとなる。
' それを回避するための処理を入れておく。
Private Sub Form_AfterDelConfirm(Status As Integer)
  Dim sSql As String

  If (Len(sDelAns) > 0) Then
    sSql = "UPDATE T選択 SET use = False WHERE an IN (" & Mid(sDelAns, 2) & ") ;"
    CurrentProject.Connection.Execute sSql
  End If
  sDelAns = ""
  Me.Requery
  If (Me.Recordset.RecordCount = 0) Then
    Me.AllowAdditions = True
  End If
  If (IsNull(vPos)) Then
    DoCmd.GoToRecord , , acNewRec
  Else
    Me.Recordset.FindFirst "an=" & vPos
  End If
  Me.Painting = True
End Sub

' 親フォームの問題番号が確定していなければ(新規登録等)、編集状態にさせない
Private Sub Form_Dirty(Cancel As Integer)
  If (IsNull(Me.Parent.問題番号)) Then
    Cancel = True
  End If
End Sub

' 更新前処理で新規なら選択肢番号を採番
Private Sub Form_BeforeUpdate(Cancel As Integer)
  If (Me.NewRecord) Then
    Me.選択肢番号 = Nz(DMax("選択肢番号", "T選択", "問題番号 = " & Me.問題番号)) + 1
  End If
End Sub

' 更新後処理で正解チェックボックスが True なら、他の正解を False に変更
' 正解を1つだけにするためのもの
'  今回は正解を設定していない場合についての対処は、手抜きで、しない。
Private Sub Form_AfterUpdate()
  Dim sSql As String

  If (Me.正解) Then
    sSql = "UPDATE T選択 SET 正解 = False WHERE 問題番号 = " & Me.問題番号 & " AND an <> " & Me.an & " ;"
    CurrentProject.Connection.Execute sSql
    Me.Requery
  End If
End Sub

 

「F_分岐」と「F_解答SUB」と「F_履歴一覧SUB」

kSample91_4  kSample91_5  kSample91_6

選択のメニューを1つのオプショングループで作ってみました。
20問 ~ 100問は、1~5
結果は、9
問題開始は、10
終了は、99
というオプション値を設定。
問題開始は、処理記述し易いように名前を設定「op1vis」
オプショングループではクリックした時の値しか直接得られないので、
20問 ~ 100問がクリックされた時点で、何問という情報を op1vis の Tag に格納。
問題開始、結果のクリックで、表示対象のサブフォームを切り替えます。

問題開始がクリックされたら、選んでいた問題数分の問題番号をグローバル変数に格納します。
(処理対象の個数分の配列として)
サブフォーム「F_解答SUB」では、その配列数分処理します。
サブフォームが処理する1つ目が正常に処理できたことを確認した後、メニューを非表示にし、
サブフォームへ制御を渡します。
問題数がいろいろ選べますが、その問題数分用意されていない場合には、用意されている分だけで。
また、サブフォームの処理で、問題番号に対して選択肢が設定されていない時には、そこで終了します。

5)サブフォーム処理中は親を閉じれないようにする

親フォームでは、このメニューが非表示であることを利用し、閉じる操作をキャンセルします。
Private Sub Form_Unload(Cancel As Integer)
  Cancel = Not Me.op1.Visible
End Sub

この他に、サブフォームコントロールに設定した SourceObject を判別に利用する手もあります。
今回はメニューの表示/非表示を使いました。

Excelへ色付き簡易カレンダーを出力する では、
背景等のオプショングループ内の各コントロール Tag を利用した情報の持ち方を紹介しましたが、
今回は変数配列で操作する方法としました。

「F_分岐」での記述
' 画面等の初期化
' オプショングループ内の「問題開始(op1vis)」を非表示
' オプショングループを未選択、表示状態にし、サブフォームを空白に
Public Sub Init()
  Me.op1vis.Visible = False
  Me.op1 = 0
  Me.op1.Visible = True
  Me.op1.SetFocus
  Me.FSUB.SourceObject = ""
End Sub

' フォーム起動確認
Private Sub Form_Open(Cancel As Integer)
  Cancel = CheckOpen
End Sub

Private Sub Form_Load()
  Call Init
End Sub

' オプショングループが非表示なら、フォームを閉じることをキャンセル
' 非表示=問題解答中 なので
Private Sub Form_Unload(Cancel As Integer)
  Cancel = Not Me.op1.Visible
End Sub

Private Sub Form_Close()
  Call ReWakeUpMenu
End Sub

' 操作メニューを1つのオプショングループのみで作ってみた
'
' 問題開始時には設定された設問数をグローバル変数 iQNums に設定
' 作成していた問題数が設問数に満たない時には、ある分だけで
' サブフォームを表示して1問目を表示してみるが、
'  正常に設定表示されたら、フォーカスをサブフォームへ移しオプショングループを非表示に
'  エラーだったら、サブフォームを空白に戻し何もしない
Private Sub op1_Click()
  Dim rs As New ADODB.Recordset
  Dim i As Integer

  Select Case Me.op1
    Case 1, 2, 3, 4, 5
      Me.op1vis.Tag = Me.op1 * 20
      Me.op1vis.Visible = True
    Case 9
      Me.FSUB.SourceObject = "F_履歴一覧SUB"
      Me.op1vis.Visible = False
    Case 10
      ReDim iQNums(Me.op1vis.Tag - 1)

      rs.Source = "SELECT 問題番号 FROM T問題 WHERE use = True ORDER BY rd, 問題番号 ;"
      rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      i = 0
      Do While (Not rs.EOF)
        iQNums(i) = rs(0)
        rs.MoveNext
        i = i + 1
        If (i >= Me.op1vis.Tag) Then Exit Do
      Loop
      rs.Close

      If (i = 0) Then
        Exit Sub
      ElseIf (i < Me.op1vis.Tag) Then
        ReDim Preserve iQNums(i - 1)
      End If

      Me.FSUB.SourceObject = "F_解答SUB"
      If (Me.FSUB.Form.Init) Then
        Me.FSUB.SetFocus
        Me.FSUB.Form.tx1.SetFocus
        Me.op1.Visible = False
      Else
        Me.FSUB.SourceObject = ""
      End If
    Case 99
      DoCmd.Close acForm, Me.Name, acSaveNo
  End Select
End Sub

 

「F_解答SUB」での記述
' 現在の設問位置(0スタート:グローバル変数 iQNums を参照)
Dim iQCount As Integer

' 現在の選択肢、選択肢番号、設定位置管理用
Dim sQstr() As String
Dim iANums() As Long
Dim iA() As Integer

' 解答開始日と問題表示時刻
Dim dt As Date
Dim dtt As Date


' サブフォームとして起動されていなければ Cancel = True
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (IsNull(Me.Parent)) Then
    Cancel = True
  End If
End Sub


' オプショングループのラベルに設問設定
Private Sub SetLabel(sQ As String)
  Dim ctl As Control

  For Each ctl In Me.op1.Controls
    With ctl
      If (.ControlType = acLabel) Then
        If (.Parent.Name = Me.op1.Name) Then
          .Caption = sQ
          Exit For
        End If
      End If
    End With
  Next
End Sub

' 指定したチェックボックスのラベルに設問(選択肢)設定
Private Sub SetCheckBoxLabel(iNum As Integer, sQ As String)
  Dim ctl As Control

  For Each ctl In Me.op1.Controls
    With ctl
      If (.ControlType = acCheckBox) Then
        If (.OptionValue = iNum) Then
          .Controls(0).Caption = sQ
          .Visible = True
          Exit For
        End If
      End If
    End With
  Next
End Sub

' 設問数以上のチェックボックスを非表示に (iStart は非表示開始値)
Private Sub OffCheckBoxVisible(iStart As Integer)
  Dim i As Integer
  Dim ctl As Control

  For i = iStart To AnsOptValueMax
    For Each ctl In Me.op1.Controls
      With ctl
        If (.ControlType = acCheckBox) Then
          If (.OptionValue = i) Then
            .Visible = False
            Exit For
          End If
        End If
      End With
    Next
  Next
End Sub

' 選択肢内で、乱数による表示位置変更(並び替え)
Private Sub SetRnd()
  Dim i As Integer, j As Integer
  Dim iTmp As Integer, sgTmp As Single
  Dim iLCount As Integer
  Dim sga() As Single

  iLCount = UBound(iA)
  ReDim sga(1 To iLCount)

  Randomize
  For i = 1 To iLCount
    sga(i) = Rnd
  Next

  For i = 1 To iLCount - 1
    For j = i + 1 To iLCount
      If (sga(j) < sga(i)) Then
        sgTmp = sga(i)
        sga(i) = sga(j)
        sga(j) = sgTmp
        iTmp = iA(i)
        iA(i) = iA(j)
        iA(j) = iTmp
      End If
    Next
  Next
End Sub

' 抽出された選択肢をオプショングループに設定
' オプショングループの値以上の選択肢があった場合は、
' 正解のある/なしにかかわらず、先頭から設定
'  並び替えしない時には、Call SetRnd をコメントに
Private Sub SetCheckBox()
  Dim i As Integer
  Dim iLMax As Integer

  Call SetRnd

  iLMax = UBound(iA)
  If (iLMax > AnsOptValueMax) Then iLMax = AnsOptValueMax
  For i = 1 To iLMax
    Call SetCheckBoxLabel(i, sQstr(iA(i)))
  Next

  Call OffCheckBoxVisible(iLMax + 1)
End Sub

' 問題の抽出と設定
' オプショングループを未選択状態にし、解答ボタンを非表示に
Private Function SetQA() As Boolean
  Dim rs As New ADODB.Recordset
  Dim i As Integer

  SetQA = False
  If (iQCount > UBound(iQNums)) Then
    Exit Function
  End If

  Me.lab01.Caption = iQCount + 1 & "問目 / " & UBound(iQNums) + 1 & "問中"

  Call SetLabel(DLookup("設問", "T問題", "問題番号 = " & iQNums(iQCount)))

  rs.Source = "SELECT * FROM T選択 WHERE use = True AND 問題番号 = " & iQNums(iQCount) & " ;"
  rs.Open , CurrentProject.Connection, adOpenKeyset, adLockReadOnly
  With rs
    If (.EOF) Then
      .Close
      Exit Function
    End If

    ReDim sQstr(1 To .RecordCount)
    ReDim iANums(1 To .RecordCount)
    ReDim iA(1 To .RecordCount)

    i = 1
    While (Not .EOF)
      sQstr(i) = .Fields("選択肢")
      iANums(i) = .Fields("選択肢番号")
      iA(i) = i
      .MoveNext
      i = i + 1
    Wend
    .Close
  End With

  Call SetCheckBox

  Me.tx1.SetFocus
  Me.op1 = 0
  Me.btn1.Visible = False
  dtt = Now
  SetQA = True
End Function

' 初期設問設定
' テーブルに格納する際の、日付、回数を求めておく
' (親フォームから呼ばれる)
Public Function Init() As Boolean
  dt = Date
  Me.Tag = Nz(DMax("回数", "T解答", "sno = " & snoSaved)) + 1
  iQCount = 0
  Init = SetQA
End Function

' 次の問題設定
Private Function NextQA() As Boolean
  iQCount = iQCount + 1
  NextQA = SetQA
End Function

' 現在チェックされている選択肢番号を得る
Private Function GetOp1Value() As Long
  GetOp1Value = iANums(iA(Me.op1))
End Function


' 解答ボタン:内容をテーブル登録
Private Sub btn1_Click()
  Dim sSql As String

  sSql = "INSERT INTO T解答 (sno,回数,日付,時間,問題番号,選択肢番号) VALUES ("
  sSql = sSql & snoSaved & ", " & Me.Tag & ", #" & dt & "#, #" & Format(Now - dtt, "hh:nn:ss") _
        & "#, " & iQNums(iQCount) & ", " & GetOp1Value & " );"
  CurrentProject.Connection.Execute sSql
  If (Not NextQA) Then Call btn2_Click
End Sub

' 中断ボタン:親フォームの Init 関数実行で、結果自分をClose
Private Sub btn2_Click()
  Call Me.Parent.Init
End Sub

' オプショングループがクリックされたら解答ボタンを表示
Private Sub op1_Click()
  Me.btn1.Visible = True
End Sub

 

「F_履歴一覧SUB」での記述
' サブフォームとして起動されていなければ Cancel = True
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (IsNull(Me.Parent)) Then
    Cancel = True
  End If
End Sub

' リストボックスの RowSource を設定
' ログイン者に絞った表示がしたいので WHERE 部分に変数値を設定
' 回数が、連結列
Private Sub Form_Load()
  Dim sSql As String

  sSql = "SELECT "
  sSql = sSql & "T1.回数"
  sSql = sSql & ", First(T1.日付) AS 日付"
  sSql = sSql & ", Sum(IIf(T3.正解=True,1,0)) AS 正解"
  sSql = sSql & ", Count(*) AS 全数"
  sSql = sSql & ", (正解 & '/' & 全数 & ' (' & Format(正解/全数*100,'0.0') & ' %)') AS [正解数 (率)]"
  sSql = sSql & ", Sum(T3.加算点-T3.正解*T2.配点) AS 点数"
  sSql = sSql & ", Sum(T2.配点) AS 全点"
  sSql = sSql & ", (点数 & '/' & 全点 & ' (' & Format(点数/全点*100,'0.0') & ' %)') AS [得点 (率)] "
  sSql = sSql & "FROM (T解答 AS T1 "
  sSql = sSql & "LEFT JOIN T問題 AS T2 ON T2.問題番号=T1.問題番号) "
  sSql = sSql & "LEFT JOIN T選択 AS T3 ON (T3.問題番号=T1.問題番号) AND (T3.選択肢番号=T1.選択肢番号) "
  sSql = sSql & "WHERE (T1.sno=" & snoSaved & ") "
  sSql = sSql & "GROUP BY T1.回数 "
  sSql = sSql & "ORDER BY T1.回数 DESC ;"

  Me.lst01.ColumnCount = 8
  Me.lst01.ColumnWidths = "1cm;2.5cm;0cm;0cm;3.5cm;0cm;0cm;4cm"
  Me.lst01.ColumnHeads = True
  Me.lst01.RowSourceType = "テーブル/クエリ"
  Me.lst01.RowSource = sSql
End Sub

' ダブルクリック時に詳細フォームを起動
' 起動時に sno, 回数を条件指定
Private Sub lst01_DblClick(Cancel As Integer)
  DoCmd.OpenForm "F_履歴詳細", , , "sno = " & snoSaved & " AND 回数 = " & Me.lst01
End Sub

 

「F_履歴詳細」

kSample91_7

デフォルトで全解答を表示できるようにしておき、起動時に絞込み条件を指定してもらうようにします。
以下をレコードソースとしてフォームを作成します。
(フォームを簡単に作るには、下記内容でクエリを作り、それを対象にウィザードで作ります)
(私はあまりクエリ自体を表に出したくないので、出来上がったフォームのレコードソースを書き換え、使ったクエリを削除します)
また、見るだけなので、「レコードセット」を「スナップショット」に変更しています。

SELECT
T1.an
, T1.sno
, T1.回数
, T2.設問
, T2.選択肢 AS 正解
, T2.配点
, T1.時間
, T3.選択肢 AS 解答
, IIF(T2.選択肢番号=T3.選択肢番号,'○','×') AS 判定
, T3.加算点
, (T3.加算点 - (T3.正解 * T2.配点)) AS 得点
FROM (T解答 AS T1
LEFT JOIN
(SELECT Q1.問題番号, Q1.設問, Q1.配点, Q2.選択肢番号, Q2.選択肢
FROM T問題 AS Q1 LEFT JOIN T選択 AS Q2 ON Q2.問題番号 = Q1.問題番号
WHERE Q2.正解 = True) AS T2 ON T2.問題番号 = T1.問題番号)
LEFT JOIN T選択 AS T3 ON (T3.問題番号=T1.問題番号) AND (T3.選択肢番号=T1.選択肢番号)
ORDER BY T1.an
;

LEFT JOIN を使っているのは、万が一、解答データがあるが、問題/選択肢を手動で削除されていたら・・・
程度のこと。
(ただ、その時のことを加味した記述内容にはなっていませんが)

1レコード表示を2段にしたので、見ているレコードがわかるように条件付き書式で色換えします。
ヘッダ部に不可視のテキストボックス「txan」を配置し、条件付き書式で、
条件を式、式に [txan]=[an] を設定し、背景色を選択。

フッター部分には、正解数と総得点用のものを配置。
正解数部分は: =Count(*) & " 問中 " & Sum(IIf([判定]="○",1,0)) & " 問正解"
総得点部分は: =Sum([得点])

また、操作中に他をいじらせたくないので
「ポップアップ」を「はい」と、「作業ウィンドウ固定」を「はい」
に設定してます。


「F_履歴詳細」での記述
' フォーム起動確認
Private Sub Form_Open(Cancel As Integer)
  Cancel = CheckOpen
End Sub

' 条件付き書式用
' ヘッダに配置した不可視のテキストボックス(txan)へ、一意情報設定
Private Sub Form_Current()
  Me.txan = Me.an
End Sub

 

※ このサンプルの状態では、運用するまでには、まだまだ工夫が必要です。

問題、選択肢登録時、正解を設定していない時の動き
(履歴等のSQL部分で NULL を加味した記述に変更する)

解答したデータがあった際に、その問題の正解を変更禁止

削除操作したレコードの復活処理

配点レベルでの問題抽出
(5点から何個、10点から何個とか)

解答を中断した場合、続行できるようにするとか

履歴詳細表示時のフィルタ解除操作に対する対策
(プロパティ「レコード移動」を「いいえ」にするとか)

レポート出力

設定問題ごとの成績表示/レポート出力

等など


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kSample91_2000.zipkSample91_2003.zipkSample91_2007.zip
 サイズ 88,25890,25394,451
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

なお、十択問題までサポートする選択問題用サンプルには問題は登録されてません。
関連記事

2011/07/09

Category: 使えたら

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/91-38a85ff1
この記事にトラックバックする(FC2ブログユーザー)

top △


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