FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

ポップアップで時間帯入力 


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

帳票フォームで帯入力 で帳票にサブ組み込みで時間帯の入力についてやってみました。
kEnt109_6

今度は、時間帯入力部分は別フォームにして、使いまわしできるようにしておきましょう・・・ということで
kEnt110_3

入力の操作は 帳票フォームで帯入力 とほぼ同じです。
・帯上でクリックすると指定操作が開始
・マウスを動かすとコロコロと1マス単位で色付け
・一度クリックすると、そこを始点/終点として固定
・マウスを動かすと帯表示が追従します
・もう一度クリックすると、帯を確定します
・「登録」ボタンをクリックするまでは登録しません

このフォームを起動する時には、OpenArgs 経由で情報を渡します。
表示開始時刻,何時間分,1時間のマス数,基準日,開始を返すコントロール名,終了を返すコントロール名

ここでのコントロール名は、起動したフォームに存在するコントロール名になります。
起動したフォームは Screen.ActiveControl から辿ります。
(辿り方については 起動元に値を設定 を参照ください)

指定例
"8,12,6,2011/12/06,txt2,txt3"
であれば、
8時始まりの12時間分(計72マス)表示して、2011/12/06 を基準として作成したものを
txt2 / txt3 に設定する。

用意していたフォームは「F_DT24」「F_DT36」になります。
今回も、きれいに並べたデザインにしたいので、フォーム作成 VBA 「Module3」を添付しています。
フォーム名の数字部分は、何時間分を表示できるか(時刻表示のラベルを何個持っているか)
この「F_DT24」を使って 帳票フォームで帯表示 に組み込むと
例えば、時間部分のテキストボックスをダブルクリックした時にフォームを起動するようにしたとすると
Private Sub txt2_DblClick(Cancel As Integer)
  Dim sArg As String

  sArg = Me.op1 & "," & Me.op2 & "," & Me.op3 & "," & Me.cbxh1 & ",txt2,txt3"
  DoCmd.OpenForm "F_DT24", , , , , , sArg
End Sub

Private Sub txt3_DblClick(Cancel As Integer)
  Dim sArg As String

  sArg = Me.op1 & "," & Me.op2 & "," & Me.op3 & "," & Me.cbxh1 & ",txt2,txt3"
  DoCmd.OpenForm "F_DT24", , , , , , sArg
End Sub
のような使い方になります。
 
用意した確認用のフォームは「F24」「F36」
どのフォームを起動するかだけの違いで、
「F24」では「F_DT24」を、「F36」では「F_DT36」を起動するようになっています。

フォーム「F24」の構成は、
上横に並んでいるテキストボックス「txt01」~「txt03」
縦に並んでいるテキストボックスは「txt1」~「txt3」(「txt1」は基準日用)
kEnt110   kEnt110_1   kEnt110_2

「確認」ボタンをクリックされた時にフォームを起動するようにしています。
Private Sub btn2_Click()
  Dim sArg As String

  sArg = Me.txt01 & "," & Me.txt02 & "," & Me.txt03 & "," _
      & Me.txt1 & ",txt2,txt3"
  DoCmd.OpenForm "F_DT24", , , , , , sArg
End Sub

 
この確認用フォームへの入力は、数字に限らず何でも・・・・
指定がなかった場合、解釈できなかった場合・・・一応デフォルトで動くようになってます。
(処理抜けがあるかも・・・)


フォーム



このフォームは使い回しが出来るように作ってます。
帳票フォームで帯表示帳票フォームで帯入力 での表示する時刻の管理、入力等混ぜました。
時間帯を表示する部分は、180 個のラベルにしています。
(この位なら応答がじれったくなることはなかったので)

また、このフォームを作る時に「何時間分」を指定できるようにしました。
(時刻の表示部分の個数を指定できるように・・・・後述を参照ください)

動きとして、このフォームは非連結で作成しています。
指定された内容は保持しておいて、必要に応じてそれを内部参照する・・・・
基準日、開始/終了時刻部分では、初期の情報は Tag に持つようにしています。
「戻す」ボタンで、Tag から Value へ設定し直し・・・ってなことを。

「マス数/1時間」部分は仕様を追加して、1 / 2 / 3 / 4 / 5 / 6 / 10 / 12 / 15 / 20 / 30 / 60
の 60 をきれいに割り切れる数字であれば・・・・としています。
割り切れない数値を指定された場合には、それに近い値に変更して表示/入力するように・・・

「何時間分」と「マス数」で、作成されていたラベル(用意していたフォームでは 180 個)を
使って表示していきますが、数が足りなかった場合は「何時間分」を狭めていきます。
例えば、6時間分を60マスを指定・・・なら、3時間分60マスに変更されます。
(開始時刻には変更ありません)

フォーム処理用 VBA「Module3_Code」(コメントは削除してます)
Private Const IPX As Long = 567

Private Type DTOFFSET
  dtS As Date
  dtd As Date
End Type

Dim iTimeCount As Long
Dim iLabelCount As Long
Dim dic() As DTOFFSET

Dim iFixPos As Long
Dim iMovePos As Long

Dim frm As Form
Dim iOp1 As Long
Dim iOp2 As Long
Dim iOp3 As Long
Dim sTxt2 As String
Dim sTxt3 As String

Private 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(iOp1, 0, 0)
  id = 60 \ iOp3

  For i = 1 To iLabelCount
    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 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 = CDate(Me.txt1) + dic(i).dtS
  Me.txt3 = CDate(Me.txt1) + dic(j).dtS + dic(j).dtd
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 iLabelCount
      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 iLabelCount
      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 iLabelCount
    With Me("ltx" & i)
      If (Not .Visible) Then Exit For
      .BackColor = RGB(255, 255, 255)
    End With
  Next
End Function

Private Function ShowInit()
  Dim i As Long

  Me.txt1 = Me.txt1.Tag
  Me.txt2 = Me.txt2.Tag
  Me.txt3 = Me.txt3.Tag

  Me.labmv.Visible = True
  iFixPos = 0
  iMovePos = 0
  For i = 1 To iLabelCount
    With Me("ltx" & i)
      If (Not .Visible) Then Exit For
      Select Case 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
      .OnClick = ""
      .OnMouseMove = ""
    End With
  Next
End Function

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

  Call ReMakeDic

  sgW = (12.5 - 1) * IPX / (iOp2 * iOp3)
  j = 0
  For i = 1 To iLabelCount
    With Me("ltx" & i)
      If (i <= (iOp2 * iOp3)) Then
        .Left = 1 * IPX + sgW * (i - 1)
        .Width = sgW
        .Visible = True
      Else
        .Visible = False
      End If
    End With
    If (((i - 1) Mod iOp3) = 0) Then
      If (j <= iOp2) Then
        k = 1 * IPX + sgW * iOp3 * j
        With Me("lab" & j)
          .Left = k - .Width \ 2
          .Caption = (iOp1 + j) Mod 24
          .Visible = True
        End With
        With Me("ln" & j)
          .Left = k
          .Visible = True
        End With
        j = j + 1
      End If
    End If
  Next
  If ((iOp2 * iOp3) = iLabelCount) Then
    k = Me("ltx" & iLabelCount).Left + Me("ltx" & iLabelCount).Width
    With Me("lab" & j)
      .Left = k - .Width \ 2
      .Caption = (iOp1 + j) Mod 24
      .Visible = True
    End With
    With Me("ln" & j)
      .Left = k
      .Visible = True
    End With
    j = j + 1
  End If
  For i = j To iTimeCount
    Me("lab" & i).Visible = False
    Me("ln" & i).Visible = False
  Next
  Call ShowInit
End Sub


Private Sub Form_Open(Cancel As Integer)
  Dim ctl As Control

  On Error Resume Next
  Set ctl = Screen.ActiveControl
  If (Not ctl Is Nothing) Then
    While (TypeOf ctl.Parent Is Control)
      Set ctl = ctl.Parent
    Wend
    Set frm = ctl.Parent
    Set ctl = Nothing
  End If
End Sub

Private Function DateGet(sDate As String, iHdis As Long, ctlBox As TextBox) As String
  Dim dt As Date
  Dim ctl As Control

  On Error Resume Next
  DateGet = ""
  If (Len(sDate) > 0) Then
    dt = CDate(sDate)
    If (Err <> 0) Then
      If (Not frm Is Nothing) Then
        On Error GoTo ERR_HND
        Set ctl = frm(sDate)
        DateGet = sDate
        dt = CDate(ctl.Value)
        Set ctl = Nothing
      End If
    End If
  Else
    dt = CDate(Me.txt1.Tag) + TimeSerial(iHdis, 0, 0)
  End If

  If (Me.txt1.Tag > Format(dt, "yyyy/mm/dd")) Then
    dt = CDate(Me.txt1.Tag & Format(dt, " hh:nn:00"))
  End If
  ctlBox.Tag = Format(dt, "yyyy/mm/dd hh:nn:00")
EXIT_HND:
  Exit Function

ERR_HND:
  Call DateGet("", iHdis, ctlBox)
  Resume EXIT_HND
End Function

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

  iLabelCount = 0
  iTimeCount = -1
  For Each ctl In Me.Section(acDetail).Controls
    Select Case Left(ctl.Name, 3)
      Case "ltx"
        iLabelCount = iLabelCount + 1
      Case "lab"
        If (ctl.Name <> "labmv") Then
          iTimeCount = iTimeCount + 1
        End If
    End Select
  Next
  ReDim dic(1 To iLabelCount)

  sAry = Split(Me.OpenArgs & ",,,,,", ",")

  iOp1 = -1
  If (Len(sAry(0)) > 0) Then iOp1 = Val(sAry(0))
  If (iOp1 < 0) Then iOp1 = 7
  iOp1 = iOp1 Mod 24

  iOp2 = 0
  If (Len(sAry(1)) > 0) Then iOp2 = Val(sAry(1))
  If (iOp2 <= 0) Then iOp2 = 12
  If (iOp2 > iTimeCount) Then iOp2 = iTimeCount

  iOp3 = 0
  If (Len(sAry(2)) > 0) Then iOp3 = Val(sAry(2))
  If (iOp3 <= 0) Then iOp3 = 4
  i = 60 \ iOp3
  If (i <= 0) Then
    iOp3 = 6
  Else
    While ((60 Mod i) <> 0)
      i = i + 1
    Wend
    iOp3 = 60 \ i
  End If
  While ((iOp2 * iOp3) > iLabelCount)
    iOp2 = iOp2 - 1
  Wend

  If (IsDate(sAry(3))) Then
    Me.txt1.Tag = Format(CDate(sAry(3)), "yyyy/mm/dd")
  Else
    Me.txt1.Tag = Format(Date, "yyyy/mm/dd")
  End If

  sTxt2 = DateGet(sAry(4), iOp1 + 1, Me.txt2)
  sTxt3 = DateGet(sAry(5), iOp1 + iOp2 - 1, Me.txt3)
  If (Me.txt2.Tag > Me.txt3.Tag) Then Me.txt3.Tag = Me.txt2.Tag
  Call ShowScale

  For i = 1 To 3
    With Me("txt" & i)
      .OnChange = "=LabelColorInit()"
      .ValidationRule = "Not Is Null"
      .ValidationText = "空にはできません"
    End With
  Next
  Me.txt1.InputMask = "0000/00/00"
  Me.labmv.OnClick = "=LabelStart()"
  Me.btn1.OnClick = "=ShowInit()"
End Sub

Private Sub btn2_Click()
  If (Me.txt2 > Me.txt3) Then
    MsgBox "なに過去に帰宅してんの", vbExclamation
    Exit Sub
  End If

  On Error Resume Next
  If (Not frm Is Nothing) Then
    Me.Visible = False
    If (Len(sTxt2) > 0) Then frm(sTxt2) = Me.txt2
    If (Len(sTxt3) > 0) Then frm(sTxt3) = Me.txt3
  End If
  Call btn3_Click
End Sub

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

Private Sub Form_Close()
  Set frm = Nothing
End Sub

 

フォームの作成部分



前記事、前々記事同様に、フォーム名、マスの数を指定するのに加え、何時間分を指定します。
Private Const MakeFormName As String = "F_DT24"
Private Const MakeTextCount As Integer = 180
Private Const MakeLabelCount As Integer = 24
ここで、変数名とか前のものを流用して・・・・なので、しっくりこないかも。
何時間分・・・・は、24 以上を指定してください。
作成する前に上記を変更したら、一度保存してからで・・・・

フォーム作成「Module3」
Private Const MakeFormName As String = "F_DT24"
Private Const MakeTextCount As Integer = 180
Private Const MakeLabelCount As Integer = 24

Private Const IPX As Long = 567

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

  On Error Resume Next
  DoCmd.DeleteObject acForm, MakeFormName

  Set frm = CreateForm
  Call FrmPos(frm)
  Call FrmDetail(frm)
  With frm
    .Width = 13.5 * 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
    .DefaultView = 0
    .RecordSelectors = False
    .ScrollBars = 0
    .NavigationButtons = False
    .AutoCenter = True
    .PopUp = True
    .Modal = True
  End With
End Sub

Private Sub FrmDetail(frm As Form)
  Dim iW As Long
  Dim i As Integer

  With CreateControl(frm.Name, acTextBox, acDetail)
    .Name = "txt1"
    .Top = 0.1 * IPX
    .Left = 0.3 * IPX
    .Width = 2.5 * IPX
    .Height = 0.45 * IPX
    .BackStyle = 1
    .BackColor = RGB(255, 255, 255)
    .Format = "Short Date"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail)
    .Name = "txt2"
    .Top = 0.8 * IPX
    .Left = 0.3 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
    .BackStyle = 1
    .BackColor = RGB(255, 255, 255)
    .Format = "General Date"
  End With

  With CreateControl(frm.Name, acTextBox, acDetail)
    .Name = "txt3"
    .Top = 1.4 * IPX
    .Left = 0.3 * IPX
    .Width = 3.8 * IPX
    .Height = 0.45 * IPX
    .BackStyle = 1
    .BackColor = RGB(255, 255, 255)
    .Format = "General Date"
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btn1"
    .Caption = "戻す"
    .Top = 0.5 * IPX
    .Left = 5 * IPX
    .Width = 2 * IPX
    .Height = 1 * IPX
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btn2"
    .Caption = "登録"
    .Top = 0.5 * IPX
    .Left = 8 * IPX
    .Width = 2 * IPX
    .Height = 1 * IPX
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btn3"
    .Caption = "終了"
    .Top = 0.5 * IPX
    .Left = 10.5 * IPX
    .Width = 2 * IPX
    .Height = 1 * IPX
  End With

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

  iW = (12.5 - 1) * IPX \ MakeLabelCount
  For i = 0 To MakeLabelCount
    With CreateControl(frm.Name, acLabel, acDetail)
      .Name = "lab" & i
      .Top = 2 * IPX - 0.5 * IPX * ((i Mod 2) = 1)
      .Left = 1 * 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, acDetail)
      .Name = "ln" & i
      .Top = 2.4 * IPX - 0.5 * IPX * ((i Mod 2) = 1)
      .Left = 1 * IPX + iW * i
      .Width = 0
      .Height = 2.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, acLabel, acDetail)
    .Name = "labmv"
    .Top = 3 * IPX
    .Left = 1 * IPX
    .Width = (12.5 - 1) * IPX
    .Height = 2 * IPX
    .BackStyle = 0
    .BorderStyle = 0
  End With

  frm.Section(acDetail).Height = 5.5 * IPX
End Sub
(前記事と変わったところは、1cm 縮めました)
なお、作成する環境によって出来上がったものの見え方が違ってきます。
フォントの大きさとか・・・テキストボックスのくぼみとか・・・・等々
必要に応じてそれらの指定は組み込んでください。
(添付のフォームは、私の 2007 で作成したままの見え方です)
 

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt110_2000.zipkEnt110_2003.zipkEnt110_2007.zip
 サイズ 78,21295,95199,161
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/12/06

Category: 使えたら

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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