スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

帳票フォームで帯表示 


帳票フォームでガンチャート(?)もどきをやってみた。
kEnt108

今のスキルではレコード毎に幅を変更して・・・ってできなかったので、
テキストボックスを複数配置し、条件付き書式で背景色を変更・・・・という方法です。

何時から表示を始めて、何時間分を、何個の区切りで・・・・
区切りの悪い所は「黄色」、もろ該当を「緑」
kEnt108_2     kEnt108_5

作成しておくテキストボックスの個数により、表示状況は変わります。

これ、表示時に配置し直すのですが、作る時にもきれいに配置したいな・・・・
ってことから、
フォームを作成する部分を全て VBA で記述。
用意してある処理用 VBA をコピー&貼り付けて・・・・フォーム作成完了・・・・
(確認の手間、さほどかかりません)

前の記事でも書きましたが、TYPE を使って、Dictionary を使って・・・の2通りを。

既存で用意したフォームは「F56DIC」「F56TYPE」「F96」の3つ。
(数字部分がテキストボックスの個数)

ポップアップで時間帯入力 も合わせて参照いただければと・・・・

 
まず、以下のテーブルを用意しました。
テーブル「T社員」
sno社員CD氏名
1 H23A001 Aさん
2 H23B001 Bさん
3 H23A002 Cさん
4 H23A003 Dさん

テーブル「T勤怠」
ansno出社帰宅更新
112011/12/01 7:50:00 2011/12/01 18:48:00  
222011/12/01 12:40:00 2011/12/01 17:05:00  
332011/12/01 7:40:00 2011/12/01 19:35:00  
442011/12/01 7:55:00 2011/12/01 17:20:00  


これを元に、帳票フォームを作成していきます。
フォームの表示は、左上にあるコンボボックス「cbxh1」の日付を条件に表示するようにします。
「cbxh1」の RowSource は
SELECT DISTINCT Format(出社,'yyyy/mm/dd') AS 日 FROM T勤怠;

フォームの RecordSource は、
SELECT * FROM T勤怠 WHERE
IIF([Forms]![フォーム名]![cbxh1] Is Null, False,
出社 >= [Forms]![フォーム名]![cbxh1] AND 出社 < DateAdd('d',1,[Forms]![フォーム名]![cbxh1]));

なので、「cbxh1」で選択するまでは、新規行しか表示されません。

フォームを全部作成する VBA は、標準モジュール「Module1」に記述しています。
Private Const MakeFormName As String = "F1"
Private Const MakeTextCount As Integer = 48
にあるフォーム名と、テキストボックスを何個作成するか変更して、一度保存して、
その下の関数「MakeForm」を実行すると、フォームが作成されます。
(変更して、保存せずに実行すると・・・何かおかしな動きに・・・・・・わかりません)

フォームの作成が終わったら、そのフォームの処理に必要な VBA 記述を転記します。
標準モジュール「Module1_Dic」には、Dictionary を使った記述がコメントで、
標準モジュール「Module1_Type」には、TYPE を使った記述がコメントであります。
コメント部分をすべて、作成したフォームに転記し、コメントを外すと・・・・
これで、フォームの完成です。

VBA でフォームを作っていくんですが、作る順番を考えます。
重ねる場合とか・・・・
作っていくとドンドン上側になっていきます。(前に作ったのが下側)

なので、テキストボックス間の線(赤色)は、テキストボックスを作成しきってから・・・

なお、複数のテキストボックス・・・・これ、クリックされたら・・・・
1つ1つに「編集ロック」「使用可能」・・・・・個別に設定しても良かったのですが、
(VBA でやるんだから記述しておけば手間はかからないでしょうけど・・・)
今回、テキストボックスを配置する全領域を覆う透明なラベルを最後に作成することに。
(これでクリック操作はラベルでガードされることに・・・)

フォーム作成「Module1」に記述したもの
Private Const MakeFormName As String = "F1"
Private Const MakeTextCount As Integer = 48

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

  If (MakeTextCount < 24) Then Exit Sub

  On Error Resume Next
  DoCmd.DeleteObject acForm, MakeFormName

  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, acForm, sS
  RefreshDatabaseWindow
End Sub


Private Sub FrmPos(frm As Form)
  With frm
    .RecordSource = "SELECT * FROM T勤怠 WHERE " _
            & " IIF([Forms]![" & MakeFormName & "]![cbxh1] Is Null, False," _
            & " 出社 >= [Forms]![" & MakeFormName & "]![cbxh1] AND" _
            & " 出社 < DateAdd('d',1,[Forms]![" & MakeFormName & "]![cbxh1]));"
    .DefaultView = 1
    .Section(acFooter).Height = 0
    .RecordSelectors = False
    .ScrollBars = 2
    .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, 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

  frm.Section(acHeader).Height = 4 * 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

 

Dictionary 用「Module1_Dic」に記述したもの(コメントははずしています)
Dim iTextCount As Long
Dim dic As Object

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.Item(iNum)(0)
  dtWe = dtWs + dic.Item(iNum)(1)

  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

  If (dic Is Nothing) Then
    Set dic = CreateObject("Scripting.Dictionary")
  End If
  dtS = TimeSerial(Me.op1, 0, 0)
  id = 60 \ Me.op3

  For i = 1 To iTextCount
    k = id * (i - 1)
    dic.Item(i) = Array(dtS + TimeSerial(k \ 60, k Mod 60, 0) _
              , 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
  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

  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_AfterUpdate()
  Me.cbxh1.Requery
End Sub

Private Sub Form_Close()
  Set dic = Nothing
End Sub

 

TYPE 用「Module1_Type」に記述したもの(コメントははずしています)
Private Type DTOFFSET
  dtS As Date
  dtd As Date
End Type

Dim iTextCount As Long
Dim dic() As DTOFFSET

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(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
  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_AfterUpdate()
  Me.cbxh1.Requery
End Sub

 


TYPE 用 / Dictionary 用の違いは

配置したテキストボックスは条件付き書式を使って色変えを行います。
この時の処理を少しでも速く(???)と思って(・・・・実際には???)

条件付き書式で呼ぶ関数を用意しました。
引数は、テキストボックス番号、出社、帰宅 の3つ。
で、自分がどの位置にあるか・・・
=0: 範囲にない
=1: 範囲にチョコットかかっている
=2: 範囲にもろ該当

この 1 or 2 で色変えをしています。

そんな中、テキストボックスの番号から何時始まり、何分間、を事前に用意していれば・・・・
ということで、それを管理する方法として使っていました。

Private Type DTOFFSET
  dtS As Date
  dtd As Date
End Type

Dim iTextCount As Long
Dim dic() As DTOFFSET
として
  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)
で個数を求めておいて
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 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
であるないを返す。
ただこの時、Date 型での判別で意図した判別にならない場合があり、
文字列に変換してから判別するように・・・・
ちなみに、おかしくなるのは、
1時間を3つ区切りで表示していた場合の、20分。
これ、文字にすると hh:20:00 になるのに、違うと言われ・・・
(型内部での誤差と思います)

なお、条件付き書式を
  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
のように、1 ~ 順番に判別するようにしていましたが、
記述する順番を見直すことで速くなったり・・・遅くなったり・・・・
(多分、今の状態だと遅いのかな)
条件に一致した時点で以降処理しないんだから・・・・
無駄でも = 0 判別を追加して、= 0 / = 2 / =1 の順が良いのかも???
出現率の低い = 1 は、最後になるんでしょうね・・・・


この、条件付き書式・・・
実際には、フォーム作成時に組み込んでおきたかったのですが、私のスキルではできず・・・

う~~ん。どうするんだろう・・・・・


※ 2000 で動かすと、1時間単位のところの「赤線」が表示されないこと多々あり。

※ 各環境で作成できましたが、表示は異なるようです。
 2000 では、テキストボックスの枠が太く濃かったり・・・
(標準での既定値がチョコチョコ違うんでしょうね・・・)

※ 動きは 2000 / 2003 の方が、2007 より速いような・・・・
 (これに限ったことではないのですが・・・)


まっ、そこそこ動くってなもんで・・・


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt108_2000.zipkEnt108_2003.zipkEnt108_2007.zip
 サイズ 98,182108,479111,699
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/12/01

Category: サンプルかな

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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