スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

帳票フォームで帯入力 


帳票フォームで帯表示 で表示についてやってみました。
kEnt108

そこで、表示だけではなくて時間帯の入力も、その帯上でできれば良いね・・・・ってことで。

入力する時、コロコロ背景色を変更したいな・・・
帳票フォーム上では無理でしょ・・・しかも条件付き書式が設定してあるのに・・・・
入力する部分は単票にして、サブフォームとして組み込めば・・・・
なので、標題はあっさり変更ということで・・・

帳票+サブになるけど、この場合サブをヘッダ/フッタに配置すれば動くみたい。
(※お勧めできる構成ではないと思います。・・・自己責任にて)

今回、時間帯を入力したいので時刻表示のラベルに近いヘッダ部に配置しましょう。
こんな感じで・・・
kEnt109_2  kEnt109_6
kEnt109_5  kEnt109_10

サンプルなので、サブフォームがわかるように背景色付けて・・・
用意したパターンは2つ

パターン1
・主フォームでは追加できない(追加はサブフォームだけで)
・修正は主フォーム上のみ
Module1フォームすべてを作成する VBA 記述
Module1_Code フォームが出来上がってから、主フォームに記述する VBA がコメントで
Module1Sサブフォーム作成を担当する VBA 記述
Module1S_Code フォームが出来上がってから、サブフォームに記述する VBA がコメントで

パターン2
・主フォームでも追加できる
・主フォームで選択したレコードをサブフォームに表示
・サブフォーム上で修正等を行う
Module2フォームすべてを作成する VBA 記述
Module2_Code フォームが出来上がってから、主フォームに記述する VBA がコメントで
Module2Sサブフォーム作成を担当する VBA 記述
Module2S_Code フォームが出来上がってから、サブフォームに記述する VBA がコメントで

用意したフォームは、
パターン1用で、主フォーム「F96_1」サブフォーム「F96_1S」
パターン2用で、主フォーム「F96_2」サブフォーム「F96_2S」

前回記事同様に、フォーム作成 VBA を実行すると同じようなものが作れます。

サブフォーム上での操作は、
・帯上でクリックすると指定操作が開始
・マウスを動かすとコロコロと1マス単位で色付け
・一度クリックすると、そこを始点/終点として固定
・マウスを動かすと帯表示が追従します
・もう一度クリックすると、帯を確定します
・「登録」ボタンをクリックするまでは登録しません
気に食わなかったとか・・・・ESC キー等でキャンセルしてください。
kEnt109_7  kEnt109_8  kEnt109_9(画像はパターン2)

※ 2000 では、このキャンセル操作で帯表示が残ります。
これは Undo が 2000 には無いので・・・・
(2003 / 2007 では、編集前の表示に戻ります)

※ 今回やってみて気付いたこと
・帳票+サブの構成は、やれば動くようですが、リンク親/子フィールドを設定したい時、
サブはフッタ部に・・・・ヘッダ部では動かないみたい
(今回この設定は使ってませんが・・・・)

・サブフォームでは、単票で自力で背景色を変更するだけだったので、ラベルに変更していました。
(主フォームが、テキストボックス+条件付き書式だったのを・・・)
同じ値を使って配置し直しても、見え方がラベル/テキストボックスでチョッと異なった。

ポップアップで時間帯入力 も合わせて参照いただければと・・・・
 
帳票フォームで帯表示 でのサンプルをベースに変更をかけていきます。
表示までの詳細は、そちらの方を参照ください。

以下では、パターン2について記述していきます。

と、その前に、パターン1についてサラッと・・・・
サブフォームは新規の入力しかしないので、レコードソースには、
SELECT * FROM T勤怠 WHERE an=0;
のように1件も抽出しないようにしておきます。
(an はオートナンバで、0 はない)
後は主フォームを追加なしで・・・

その他多くはパターン2と雰囲気一緒なので、実際の記述はサンプルファイルを参照してください。


パターン2

主フォーム


主フォームの処理は 帳票フォームで帯表示 とほぼ一緒ですが、
サブフォームとのやり取り用の関数 / 変数の Public 化を施しています。
変数の Public 化では、配列の変数は Public にできないので、関数を経由して。
以下が処理用に記述した VBA になります。(登録時のチェックを追加してます)
(黄色い部分が帳票フォームで帯表示から変更した部分)
主フォーム処理用 VBA「Module2_Code」(コメントは削除してます)
Private Type DTOFFSET
  dtS As Date
  dtd As Date
End Type

Public iTextCount As Long
Dim dic() As DTOFFSET

Public Function GetStartDate(iNum As Long) As Date
  GetStartDate = CDate(Nz(Me.cbxh1, Date)) + dic(iNum).dtS
End Function

Public Function GetEndDate(iNum As Long) As Date
  GetEndDate = CDate(Nz(Me.cbxh1, Date)) + dic(iNum).dtS + dic(iNum).dtd
End Function



Public Function WhatMean(iNum As Long, dtS As Date, dtE As Date) As Integer
  Dim dtWs As Date, dtWe As Date
  Dim s_dtS As String, s_dtWs As String
  Dim s_dtE As String, s_dtWe As String

  dtWs = CDate(Format(dtS, "yyyy/mm/dd")) + dic(iNum).dtS
  dtWe = dtWs + dic(iNum).dtd

  s_dtS = Format(dtS, "yyyymmddhhnnss")
  s_dtE = Format(dtE, "yyyymmddhhnnss")
  s_dtWs = Format(dtWs, "yyyymmddhhnnss")
  s_dtWe = Format(dtWe, "yyyymmddhhnnss")

  WhatMean = 0
  If ((s_dtS >= s_dtWe) Or (s_dtE <= s_dtWs)) Then Exit Function
  WhatMean = 1
  If ((s_dtS <= s_dtWs) And (s_dtE >= s_dtWe)) Then WhatMean = 2
End Function

Private Sub ReMakeDic()
  Dim i As Long
  Dim id As Integer, k As Integer
  Dim dtS As Date

  dtS = TimeSerial(Me.op1, 0, 0)
  id = 60 \ Me.op3

  For i = 1 To iTextCount
    k = id * (i - 1)
    dic(i).dtS = dtS + TimeSerial(k \ 60, k Mod 60, 0)
    dic(i).dtd = TimeSerial(id \ 60, id Mod 60, 0)
  Next
End Sub

Private Sub ShowScale()
  Dim sgW As Single
  Dim i As Long, j As Long, k As Long

  Call ReMakeDic

  sgW = (17.5 - 5) * IPX / (Me.op2 * Me.op3)
  j = 0
  For i = 1 To iTextCount
    With Me("ltx" & i)
      If (i <= (Me.op2 * Me.op3)) Then
        .Left = 5 * IPX + sgW * (i - 1)
        .Width = sgW
        .Visible = True
      Else
        .Visible = False
      End If
    End With
    If (((i - 1) Mod Me.op3) = 0) Then
      If (j <= Me.op2) Then
        k = 5 * IPX + sgW * Me.op3 * j
        With Me("labh" & j)
          .Left = k - .Width \ 2
          .Caption = (Me.op1 + j) Mod 24
          .Visible = True
        End With
        With Me("lnh" & j)
          .Left = k
          .Visible = True
        End With
        With Me("lnd" & j)
          .Left = k
          .Visible = True
        End With
        j = j + 1
      End If
    End If
  Next
  If ((Me.op2 * Me.op3) = iTextCount) Then
    k = Me("ltx" & iTextCount).Left + Me("ltx" & iTextCount).Width
    With Me("labh" & j)
      .Left = k - .Width \ 2
      .Caption = (Me.op1 + j) Mod 24
      .Visible = True
    End With
    With Me("lnh" & j)
      .Left = k
      .Visible = True
    End With
    With Me("lnd" & j)
      .Left = k
      .Visible = True
    End With
    j = j + 1
  End If
  For i = j To 24
    Me("labh" & i).Visible = False
    Me("lnh" & i).Visible = False
    Me("lnd" & i).Visible = False
  Next
  Call Me.FSUB.Form.ShowScale
  Me.Recalc
End Sub


Private Sub cbxh1_Click()
  Me.Requery
End Sub

Private Sub op1_Click()
  Call ShowScale
End Sub

Private Sub op2_Click()
  While ((Me.op2 * Me.op3) > iTextCount)
    Me.op3 = Me.op3 - 1
  Wend
  Call ShowScale
End Sub

Private Sub op3_Click()
  While ((Me.op2 * Me.op3) > iTextCount)
    Me.op2 = Me.op2 - 2
  Wend
  Call ShowScale
End Sub


Private Sub Form_Load()
  Dim ctl As Control
  Dim i As Long

  iTextCount = 0
  For Each ctl In Me.Section(acDetail).Controls
    If (Left(ctl.Name, 3) = "ltx") Then iTextCount = iTextCount + 1
  Next
  ReDim dic(1 To iTextCount)

  Me.op1 = 7
  Me.op2 = 14
  Me.op3 = 3
  For i = 1 To iTextCount
    With Me("ltx" & i)
      With .FormatConditions.Add(acExpression, , "WhatMean(" & i & ", [txt2], [txt3])=1")
        .BackColor = RGB(255, 255, 64)
      End With
      With .FormatConditions.Add(acExpression, , "WhatMean(" & i & ", [txt2], [txt3])=2")
        .BackColor = RGB(128, 255, 128)
      End With
    End With
  Next
  Call op3_Click
End Sub

Private Sub Form_Current()
  Me.txtan = Me.an
  Me.FSUB.Form.Requery
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  Dim sMsg As String

  sMsg = ""
  If (IsNull(Me.cbx1)) Then sMsg = sMsg & "人を選んでよ" & vbCrLf
  If (IsNull(Me.txt2)) Then sMsg = sMsg & "出社を設定してよ" & vbCrLf
  If (IsNull(Me.txt3)) Then sMsg = sMsg & "帰宅を設定してよ" & vbCrLf
  If (Len(sMsg) > 0) Then
    MsgBox sMsg, vbExclamation
    Cancel = True
    Exit Sub
  End If
  If (Me.txt2 >= Me.txt3) Then
    MsgBox "なに過去に帰宅してんの", vbExclamation
    Cancel = True
    Exit Sub
  End If

  Me.更新 = Now()
End Sub

Private Sub Form_AfterUpdate()
  Me.txtan = Me.an
  Me.cbxh1.Requery
  Me.Recalc
End Sub


 

サブフォーム


サブフォームでは、親で管理しているものを参照して処理を進めます。
・帯部分を配置し直すのは関数にして、必要に応じて親から実行してもらいます。
(位置/幅等は親のものをコピーする感じで・・・)

帯での入力(マウスの動きの検知)では、最前面に配置していたラベル「labmv」を
シャッターのような感じで Visible を True / False 切り替えで制御
Visible = False になれば、下のラベルでマウスの動きを検知できる・・・・
(念のため OnMouseMove / OnClick は可視部分のみに都度設定)
このラベル「labmv」の存在については 帳票フォームで帯表示 を参照ください。
主フォームでの役割を流用してみました。

サブフォームのレコードソースでは、抽出条件で、
親のヘッダに非表示で配置した「txtan」を参照することに・・・・
親フォームでは、レコードを選択するごとに「txtan」にオートナンバ「an」を設定し、
サブフォームを Requery ・・・・・・ (これで同期することに)

また、フォームの「更新前処理」では常に Cancel = True とし、安易に更新されるのを防ぐ。
(「登録」ボタンをクリックするまでは、更新しないように)
登録する時には、一度「更新前処理」を無効として、Me.Dirty = False で保存してみた。
レコードの保存は通常
    DoCmd.RunCommand acCmdSaveRecord
だと思いますが、保存したいフォームがアクティブでないと・・・・
アクティブにしないで保存したい場合等・・・・ Me.Dirty = False を覚えておくと便利かも。

Form_Current のところで1行
'  If (Me.Parent.iTextCount = 0) Then Exit Sub
コメントにしていますが、実際には無くても動きます。
注意点として残しておきました。
というのは、親フォームの Form_Open が呼ばれる前に、サブフォームの処理は終わっている・・・
今回親フォームの変数を参照するようにしていたので、サブフォームでレコードがあったら・・・
その変数には、まだ値が設定されていない・・・ 変数の値は、VBA での初期値 0
(今回は For 文の「まで」に使っていたので、実際には For 文内は実行されず・・・)
For i = 1 To 0 ← での 0 部分が親の変数を参照
では・・・・

なお、「出社」「帰宅」部分を直接触られたら・・・・
どう帯表示してよいか・・・・わっからなくなるので、帯表示は消すことに・・・
(OnChange を利用・・・変更の都度実行されるけど、邪魔になる動きではなかったので・・・)

サブフォーム処理用 VBA「Module2S_Code」(コメントは削除してます)
Dim iFixPos As Long
Dim iMovePos As Long


Public Sub ShowScale()
  Dim i As Long

  For i = 1 To Me.Parent.iTextCount
    With Me.Parent("ltx" & i)
      Me("ltx" & i).Left = .Left
      Me("ltx" & i).Width = .Width
      Me("ltx" & i).Visible = .Visible
    End With
  Next
  For i = 0 To 24
    With Me.Parent("lnd" & i)
      Me("lnd" & i).Left = .Left
      Me("lnd" & i).Visible = .Visible
    End With
  Next
End Sub


Private Function LabelMove(iNum As Long)
  Dim i As Long, j As Long, k As Long
  Dim iC As Long, vA As Variant

  If (iFixPos = 0) Then
    If (iMovePos > 0) Then Me("ltx" & iMovePos).BackColor = RGB(255, 255, 255)
    iMovePos = iNum
    Me("ltx" & iMovePos).BackColor = RGB(192, 255, 255)
    i = iNum: j = iNum
  Else
    iC = RGB(255, 255, 255)
    For Each vA In Array(iMovePos, iNum)
      iMovePos = vA
      If (iFixPos <= iMovePos) Then
        i = iFixPos
        j = iMovePos
      Else
        i = iMovePos
        j = iFixPos
      End If
      For k = i To j
        Me("ltx" & k).BackColor = iC
      Next
      iC = RGB(192, 255, 255)
    Next
  End If
  Me.txt2 = Me.Parent.GetStartDate(i)
  Me.txt3 = Me.Parent.GetEndDate(j)
End Function

Private Function LabelClick(iNum As Long)
  Dim i As Long

  If (iFixPos = 0) Then
    iFixPos = iNum
    Call LabelMove(iNum)
  Else
    Call LabelMove(iNum)
    For i = 1 To Me.Parent.iTextCount
      With Me("ltx" & i)
        If (Not .Visible) Then Exit For
        If (.BackColor <> RGB(255, 255, 255)) Then
          .BackColor = RGB(128, 255, 128)
        End If
        .OnClick = ""
        .OnMouseMove = ""
      End With
    Next
    Me.labmv.Visible = True
  End If
End Function

Private Function LabelStart()
  Dim i As Long

  If (Me.labmv.Visible = True) Then
    iFixPos = 0
    iMovePos = 0
    For i = 1 To Me.Parent.iTextCount
      With Me("ltx" & i)
        If (Not .Visible) Then Exit For
        .BackColor = RGB(255, 255, 255)
        .OnClick = "=LabelClick(" & i & ")"
        .OnMouseMove = "=LabelMove(" & i & ")"
      End With
    Next
    Me.labmv.Visible = False
  End If
End Function

Private Function LabelColorInit()
  Dim i As Long

  For i = 1 To Me.Parent.iTextCount
    With Me("ltx" & i)
      If (Not .Visible) Then Exit For
      .BackColor = RGB(255, 255, 255)
    End With
  Next
End Function

Private Sub btn1_Click()
  Dim sMsg As String
  Dim iAn As Long

  If (Me.labmv.Visible = False) Then
    MsgBox "操作が終わってからにしてよ", vbExclamation
    Exit Sub
  End If

  sMsg = ""
  If (IsNull(Me.cbx1)) Then sMsg = sMsg & "人を選んでよ" & vbCrLf
  If (IsNull(Me.txt2)) Then sMsg = sMsg & "出社を設定してよ" & vbCrLf
  If (IsNull(Me.txt3)) Then sMsg = sMsg & "帰宅を設定してよ" & vbCrLf
  If (Len(sMsg) > 0) Then
    MsgBox sMsg, vbExclamation
    Exit Sub
  End If
  If (Me.txt2 >= Me.txt3) Then
    MsgBox "なに過去に帰宅してんの", vbExclamation
    Exit Sub
  End If

  Echo False
  Me.更新 = Now()
  sMsg = Me.BeforeUpdate
  Me.BeforeUpdate = ""
  Me.Dirty = False
  Me.BeforeUpdate = sMsg
  iAn = Me.an
  With Me.Parent
    .cbxh1.Requery
    .Requery
    .Recordset.FindFirst "an = " & iAn
  End With
  Echo True
End Sub

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

Private Sub Form_Load()
  Me.labmv.OnClick = "=LabelStart()"
  Me.txt2.OnChange = "=LabelColorInit()"
  Me.txt3.OnChange = "=LabelColorInit()"
End Sub

Private Sub Form_Current()
  Dim i As Long

'  If (Me.Parent.iTextCount = 0) Then Exit Sub
  If (Me.NewRecord) Then
    Call LabelColorInit
  Else
    For i = 1 To Me.Parent.iTextCount
      With Me("ltx" & i)
        If (Not .Visible) Then Exit For
        Select Case Me.Parent.WhatMean(i, Me.txt2, Me.txt3)
          Case 0
            .BackColor = RGB(255, 255, 255)
          Case 1
            .BackColor = RGB(255, 255, 64)
          Case 2
            .BackColor = RGB(128, 255, 128)
        End Select
      End With
    Next
  End If
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
  MsgBox "入力が完了しないと移動できません", vbExclamation
  Cancel = True
End Sub

Private Sub Form_Undo(Cancel As Integer)
  Dim i As Long

  If (Me.NewRecord) Then
    Call LabelColorInit
  Else
    For i = 1 To Me.Parent.iTextCount
      With Me("ltx" & i)
        If (Not .Visible) Then Exit For
        Select Case Me.Parent.WhatMean(i, Me.txt2.OldValue, Me.txt3.OldValue)
          Case 0
            .BackColor = RGB(255, 255, 255)
          Case 1
            .BackColor = RGB(255, 255, 64)
          Case 2
            .BackColor = RGB(128, 255, 128)
        End Select
      End With
    Next
  End If
End Sub

 

フォームの作成部分


フォーム作成「Module2」

フォーム名とテキストボックスの個数を設定、保存後、「MakeForm」を実行
主フォーム名は、指定したフォーム名に「_2」を付加したものになります
Private Const MakeFormName As String = "F1"
Private Const MakeTextCount As Integer = 60

Public Sub MakeForm()
  Dim frm As Form
  Dim sS As String

  If (MakeTextCount < 24) Then Exit Sub

  Call Module2S.MakeSubForm(MakeFormName & "_2S", MakeTextCount)

  On Error Resume Next
  DoCmd.DeleteObject acForm, MakeFormName & "_2"

  Set frm = CreateForm
  DoCmd.RunCommand acCmdFormHdrFtr
  Call FrmPos(frm)
  Call FrmHead(frm)
  Call FrmDetail(frm)
  With frm
    .Width = 18.5 * IPX
    .HasModule = True
    sS = .Name
  End With
  DoCmd.Close acForm, frm.Name, acSaveYes
  DoCmd.Rename MakeFormName & "_2", acForm, sS
  RefreshDatabaseWindow
End Sub


Private Sub FrmPos(frm As Form)
  With frm
    .RecordSource = "SELECT * FROM T勤怠 WHERE " _
            & " IIF([Forms]![" & MakeFormName & "_2" & "]![cbxh1] Is Null, False," _
            & " 出社 >= [Forms]![" & MakeFormName & "_2" & "]![cbxh1] AND" _
            & " 出社 < DateAdd('d',1,[Forms]![" & MakeFormName & "_2" & "]![cbxh1]));"
    .DefaultView = 1
    .Section(acFooter).Height = 0
    .RecordSelectors = False
    .ScrollBars = 2
    .AllowAdditions = True
    .Section(acHeader).BackColor = RGB(255, 255, 255)
    .Section(acDetail).BackColor = RGB(255, 255, 255)
    .Width = 18# * IPX
  End With
End Sub

Private Sub FrmHead(frm As Form)
  Dim iW As Long
  Dim sN As String
  Dim i As Integer

  iW = frm.Width \ 26
  With CreateControl(frm.Name, acOptionGroup, acHeader)
    .Name = "op1"
    For i = 0 To 23
      With CreateControl(frm.Name, acOptionButton, acHeader, "op1")
        sN = "op1_" & i
        .Name = sN
        .Top = 0.3 * IPX
        .Left = iW * (i + 1)
        .Width = 0.4 * IPX
        .Height = 0.4 * IPX
        .OptionValue = i
        With CreateControl(frm.Name, acLabel, acHeader, sN)
          .Name = "l" & sN
          .Top = frm(sN).Top + frm(sN).Height
          .Left = frm(sN).Left - 40
          .Width = 0.5 * IPX
          .Height = frm(sN).Height
          .TextAlign = 2
          .Caption = i
        End With
      End With
    Next
    .Top = 0.2 * IPX
    .Left = iW \ 3
    .Width = iW * 25
    .Height = 1 * IPX
    .BorderWidth = 3
    .SpecialEffect = 4
    .DefaultValue = 7
  End With

  With CreateControl(frm.Name, acOptionGroup, acHeader)
    .Name = "op2"
    For i = 2 To 24 Step 2
      With CreateControl(frm.Name, acOptionButton, acHeader, "op2")
        sN = "op2_" & i
        .Name = sN
        .Top = frm("op1").Top + frm("op1").Height + 0.2 * IPX
        .Left = iW * (i - 1)
        .Width = 0.4 * IPX
        .Height = 0.4 * IPX
        .OptionValue = i
        With CreateControl(frm.Name, acLabel, acHeader, sN)
          .Name = "l" & sN
          .Top = frm(sN).Top - 30
          .Left = frm(sN).Left + frm(sN).Width + 10
          .Width = 0.5 * IPX
          .Height = frm(sN).Height
          .TextAlign = 2
          .Caption = i
        End With
      End With
    Next
    .Top = frm("op1").Top + frm("op1").Height + 0.1 * IPX
    .Left = frm("op1").Left
    .Width = iW * 25
    .Height = 0.6 * IPX
    .BorderWidth = 3
    .SpecialEffect = 4
    .DefaultValue = 12
  End With

  With CreateControl(frm.Name, acOptionGroup, acHeader)
    .Name = "op3"
    For i = 1 To 6
      With CreateControl(frm.Name, acOptionButton, acHeader, "op3")
        sN = "op3_" & i
        .Name = sN
        .Top = frm("op2").Top + frm("op2").Height + 0.2 * IPX
        .Left = iW * (i * 2 - 1)
        .Width = 0.4 * IPX
        .Height = 0.4 * IPX
        .OptionValue = i
        With CreateControl(frm.Name, acLabel, acHeader, sN)
          .Name = "l" & sN
          .Top = frm(sN).Top - 30
          .Left = frm(sN).Left + frm(sN).Width + 10
          .Width = 0.5 * IPX
          .Height = frm(sN).Height
          .TextAlign = 2
          .Caption = i
        End With
      End With
    Next
    .Top = frm("op2").Top + frm("op2").Height + 0.1 * IPX
    .Left = frm("op2").Left
    .Width = iW * 13
    .Height = 0.6 * IPX
    .BorderWidth = 3
    .SpecialEffect = 4
    .DefaultValue = 4
  End With

  With CreateControl(frm.Name, acTextBox, acHeader)
    .Name = "txtan"
    .Top = frm("op3").Top
    .Left = 11 * IPX
    .Width = 1 * IPX
    .Height = 0.45 * IPX
    .Visible = False
  End With

  With CreateControl(frm.Name, acComboBox, acHeader)
    .Name = "cbxh1"
    .Top = 3 * IPX
    .Left = 1 * IPX
    .Width = 3 * IPX
    .Height = 0.45 * IPX
    .RowSource = "SELECT DISTINCT Format(出社,'yyyy/mm/dd') AS 日 FROM T勤怠;"
  End With

  iW = (17.5 - 5) * IPX \ 24
  For i = 0 To 24
    With CreateControl(frm.Name, acLabel, acHeader)
      .Name = "labh" & i
      .Top = 3 * IPX - 0.5 * IPX * ((i Mod 2) = 1)
      .Left = 5 * IPX + iW * i - 0.25 * IPX
      .Width = 0.5 * IPX
      .Height = 0.4 * IPX
      .BorderStyle = 1
      .BorderWidth = 1
      .BorderColor = RGB(255, 0, 0)
      .TextAlign = 2
      .Caption = i
      .Visible = False
    End With
    With CreateControl(frm.Name, acLine, acHeader)
      .Name = "lnh" & i
      .Top = 3.4 * IPX - 0.5 * IPX * ((i Mod 2) = 1)
      .Left = 5 * IPX + iW * i
      .Width = 0
      .Height = 0.6 * IPX + 0.5 * IPX * ((i Mod 2) = 1)
      .BorderStyle = 1
      .BorderWidth = 1
      .BorderColor = RGB(255, 0, 0)
      .Visible = False
    End With
  Next

  With CreateControl(frm.Name, acSubform, acHeader)
    .Name = "FSUB"
    .Top = 4 * IPX
    .Left = 0.02 * IPX
    .Width = 18 * IPX
    .Height = 2.2 * IPX
    .BorderStyle = 0
    .SourceObject = MakeFormName & "_2S"
  End With

  frm.Section(acHeader).Height = 6.1 * IPX
End Sub

Private Sub FrmDetail(frm As Form)
  Dim iW As Long
  Dim i As Integer
  
  With CreateControl(frm.Name, acComboBox, acDetail, , "sno")
    .Name = "cbx1"
    .Top = 0
    .Left = 0.3 * IPX
    .Width = 3 * IPX
    .Height = 0.45 * IPX
    .ColumnCount = 3
    .ColumnWidths = "0cm;2cm;2cm"
    .ListWidth = 4.5 * IPX
    .RowSource = "SELECT sno, 社員CD, 氏名 FROM T社員 ORDER BY 氏名;"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail)
    .Name = "txt1"
    .Top = 0.5 * IPX
    .Left = 0.3 * IPX
    .Width = 3 * IPX
    .Height = 0.45 * IPX
    .Locked = True
    .Enabled = False
    .TextAlign = 3
    .BackStyle = 1
    .BackColor = RGB(255, 234, 234)
    .ControlSource = "=IIF(IsNull([cbx1]),'',[cbx1].[Column](2))"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail, , "出社")
    .Name = "txt2"
    .Top = 1 * IPX
    .Left = 0.6 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
  End With
  With CreateControl(frm.Name, acTextBox, acDetail, , "帰宅")
    .Name = "txt3"
    .Top = 1.5 * IPX
    .Left = 0.6 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
  End With

  iW = (17.5 - 5) * IPX \ MakeTextCount
  For i = 1 To MakeTextCount
    With CreateControl(frm.Name, acTextBox, acDetail)
      .Name = "ltx" & i
      .Top = 0
      .Left = 5 * IPX + iW * (i - 1)
      .Width = iW
      .Height = 2 * IPX
      .BackStyle = 1
      .BackColor = RGB(255, 255, 255)
      .TabStop = False
      .Visible = False
    End With
  Next

  iW = (17.5 - 5) * IPX \ 24
  For i = 0 To 24
    With CreateControl(frm.Name, acLine, acDetail)
      .Name = "lnd" & i
      .Top = 0
      .Left = 5 * IPX + iW * i
      .Width = 0
      .Height = 2 * IPX
      .BorderStyle = 1
      .BorderWidth = 1
      .BorderColor = RGB(255, 0, 0)
      .Visible = False
    End With
  Next

  With CreateControl(frm.Name, acLabel, acDetail)
    .Name = "labmv"
    .Top = 0
    .Left = 5 * IPX
    .Width = (17.5 - 5) * IPX
    .Height = 2.1 * IPX
    .BackStyle = 0
    .BorderStyle = 0
  End With

  frm.Section(acDetail).Height = 2.1 * IPX
End Sub

 

サブフォーム作成担当「Module2S」

主フォーム作成をコピーし、「ヘッダ」部分の処理を削除したものが主
複数貼り付けるテキストボックスをラベルに変更(名前はそのまま使用)
指定されたサブフォーム名の後ろ1文字を削除したものが親フォーム名と解釈
Private MakeFormName As String
Private MakeTextCount As Integer

Public Sub MakeSubForm(sFrmName As String, iNum As Integer)
  Dim frm As Form
  Dim sS As String

  MakeFormName = sFrmName
  MakeTextCount = iNum
  On Error Resume Next
  DoCmd.DeleteObject acForm, MakeFormName

  Set frm = CreateForm
  Call FrmPos(frm)
  Call FrmDetail(frm)
  With frm
    .Width = 18 * IPX
    .HasModule = True
    sS = .Name
  End With
  DoCmd.Close acForm, frm.Name, acSaveYes
  DoCmd.Rename MakeFormName, acForm, sS
  RefreshDatabaseWindow
End Sub


Private Sub FrmPos(frm As Form)
  With frm
    .RecordSource = "SELECT * FROM T勤怠 WHERE an = Nz([Forms]![" _
            & Left(MakeFormName, Len(MakeFormName) - 1) & "]![txtan],0);"
    .DefaultView = 0
    .RecordSelectors = False
    .ScrollBars = 0
    .NavigationButtons = False
    .Section(acDetail).BackColor = RGB(220, 220, 220)
  End With
End Sub

Private Sub FrmDetail(frm As Form)
  Dim iW As Long
  Dim i As Integer
  
  With CreateControl(frm.Name, acComboBox, acDetail, , "sno")
    .Name = "cbx1"
    .Top = 0.1 * IPX
    .Left = 0.3 * IPX
    .Width = 3 * IPX
    .Height = 0.45 * IPX
    .ColumnCount = 3
    .ColumnWidths = "0cm;2cm;2cm"
    .ListWidth = 4.5 * IPX
    .RowSource = "SELECT sno, 社員CD, 氏名 FROM T社員 ORDER BY 氏名;"
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btn1"
    .Top = 0.1 * IPX
    .Left = 3.5 * IPX
    .Width = 1.3 * IPX
    .Height = 0.6 * IPX
    .Caption = "登録"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail)
    .Name = "txt1"
    .Top = 0.6 * IPX
    .Left = 0.3 * IPX
    .Width = 3 * IPX
    .Height = 0.45 * IPX
    .Locked = True
    .Enabled = False
    .TextAlign = 3
    .BackStyle = 1
    .BackColor = RGB(255, 234, 234)
    .ControlSource = "=IIF(IsNull([cbx1]),'',[cbx1].[Column](2))"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail, , "出社")
    .Name = "txt2"
    .Top = 1.1 * IPX
    .Left = 0.6 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
  End With
  With CreateControl(frm.Name, acTextBox, acDetail, , "帰宅")
    .Name = "txt3"
    .Top = 1.6 * IPX
    .Left = 0.6 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
  End With

  iW = (17.5 - 5) * IPX \ MakeTextCount
  For i = 1 To MakeTextCount
    With CreateControl(frm.Name, acLabel, acDetail)
      .Name = "ltx" & i
      .Top = 0.1 * IPX
      .Left = 5 * IPX + iW * (i - 1)
      .Width = iW
      .Height = 2 * IPX
      .BorderStyle = 1
      .BorderWidth = 1
      .BorderColor = 0
      .BackStyle = 1
      .BackColor = RGB(255, 255, 255)
      .Visible = False
    End With
  Next

  iW = (17.5 - 5) * IPX \ 24
  For i = 0 To 24
    With CreateControl(frm.Name, acLine, acDetail)
      .Name = "lnd" & i
      .Top = 0.1 * IPX
      .Left = 5 * IPX + iW * i
      .Width = 0
      .Height = 2 * IPX
      .BorderStyle = 1
      .BorderWidth = 1
      .BorderColor = RGB(255, 0, 0)
      .Visible = False
    End With
  Next

  With CreateControl(frm.Name, acLabel, acDetail)
    .Name = "labmv"
    .Top = 0.1 * IPX
    .Left = 5 * IPX
    .Width = (17.5 - 5) * IPX
    .Height = 2.1 * IPX
    .BackStyle = 0
    .BorderStyle = 0
  End With

  frm.Section(acDetail).Height = 2.2 * IPX
End Sub

 

そうそう、
サブフォームの帯で入力する時の時刻間隔はマス単位になるので、
1時間当たりのマスを変更しながらいじってみてください。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt109_2000.zipkEnt109_2003.zipkEnt109_2007.zip
 サイズ 147,500159,829163,895
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/12/04

Category: サンプルかな

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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