～ kiku tips ～

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

Dim myNo As Integer
Dim bNewEdit As Boolean

Private Sub Form_Open(Cancel As Integer)
　　Dim sAry() As String

　　On Error Resume Next
　　sAry = Split(Me.Parent.Tag, ",")
　　If (Err <> 0) Then
　　　　Cancel = True
　　　　Exit Sub
　　End If

　　myNo = CInt(sAry(0))
　　Me.RecordSource = sAry(1)
　　Me.txt1.ControlSource = sAry(2)
　　Me.txt1.Controls(0).Caption = sAry(2)
　　Me.txt2.ControlSource = sAry(3)
　　Me.txt2.Controls(0).Caption = sAry(3)
　　Me.op11.ControlSource = "use"
　　Me.txt11.ControlSource = sAry(4)
　　Me.txt12.ControlSource = sAry(5)

　　Me.Filter = Me.Parent.GetMyFilter(myNo)
　　Me.FilterOn = Len(Me.Filter) > 0
　　If (Not Me.FilterOn) Then
　　　　Me.DataEntry = True
　　End If
　　bNewEdit = False
End Sub

Private Sub Form_Current()
　　If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
　　bNewEdit = False
End Sub

Private Sub Form_BeforeInsert(Cancel As Integer)
　　Call Me.Parent.NewMyItemReset(myNo)
　　bNewEdit = True
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
　　If (Me.NewRecord) Then
　　　　Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
　　　　If (Len(Me.txt12.ControlSource) > 0) Then
　　　　　　Me.txt12 = Me.Parent.GetMyParentItem(myNo)
　　　　End If
　　End If
End Sub

Private Sub Form_AfterUpdate()
　　Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
　　bNewEdit = False
End Sub

SELECT
IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) AS ID,
T1.受付ID,
T1.受付日付,
T2.見積ID,
T2.見積日付,
T3.契約ID,
T3.契約日付,
T4.完了ID,
T4.完了日付,
Switch(IsNull(T1.受付日付),0,IsNull(T2.見積日付),1,IsNull(T3.契約日付),2,IsNull(T4.完了日付),3,True,4) AS 判定
FROM
(((SELECT * FROM T受付 WHERE use=True) AS T1
LEFT JOIN
(SELECT * FROM T見積 WHERE use=True) AS T2 ON T1.受付ID=T2.受付ID)
LEFT JOIN (SELECT * FROM T契約 WHERE use=True) AS T3 ON T2.見積ID=T3.見積ID)
LEFT JOIN (SELECT * FROM T完了 WHERE use=True) AS T4 ON T3.契約ID=T4.契約ID
ORDER BY IdMake(T1.受付ID,T2.見積ID,T3.契約ID,T4.完了ID) DESC;

Public Function IdMake(ParamArray vAry()) As String
　　Dim i As Integer
　　Dim sS As String
　　Dim sTmp As String

　　sS = ""
　　For i = LBound(vAry) To UBound(vAry)
　　　　sTmp = Nz(vAry(i))
　　　　If (Len(sTmp) = 0) Then sTmp = "Z"
　　　　sS = sS & "-" & sTmp
　　Next
　　IdMake = Mid(sS, 2)
End Function

Dim CSUB(1 To 4) As Variant

Private Sub initCnst()
　　CSUB(1) = Array("txt1", "受付ID", "1,T受付,受付日付,担当者,受付ID,")
　　CSUB(2) = Array("txt2", "見積ID", "2,T見積,見積日付,見積内容,見積ID,受付ID")
　　CSUB(3) = Array("txt3", "契約ID", "3,T契約,契約日付,契約内容,契約ID,見積ID")
　　CSUB(4) = Array("txt4", "完了ID", "4,T完了,完了日付,完了内容,完了ID,契約ID")
End Sub


Public Function GetMyFilter(iNum As Integer) As String
　　Dim s As String

　　GetMyFilter = ""
　　s = Me(CSUB(iNum)(0))
　　If (Len(s) > 0) Then
　　　　GetMyFilter = CSUB(iNum)(1) & " = " & s
　　End If
End Function

Public Function GetMyParentItem(iNum As Integer) As Long
　　Dim i As Integer
　　Dim s As String

　　GetMyParentItem = 0
　　i = iNum - 1
　　If (i > 0) Then
　　　　s = Me(CSUB(i)(0))
　　　　If (Len(s) = 0) Then
　　　　　　GetMyParentItem = 0
　　　　Else
　　　　　　GetMyParentItem = CLng(s)
　　　　End If
　　End If
End Function


Public Sub NewMyItemReset(iNum As Integer)
　　Dim i As Integer

　　If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub

　　DoCmd.Echo False
　　For i = iNum To 4
　　　　Me("txt" & i) = ""
　　Next
　　For i = iNum + 1 To 4
　　　　With Me("FSUB" & i)
　　　　　　.Visible = False
　　　　　　.SourceObject = ""
　　　　End With
　　Next
　　DoCmd.Echo True
End Sub

Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
　　Dim sTxt As String

　　DoCmd.Echo False
　　sTxt = CSUB(iNum)(0)
　　If (Me(sTxt) <> iSrc) Then
　　　　Me(sTxt) = iSrc
　　　　Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
　　End If
　　Me.lst1.Requery
　　Call ShowFSub(iNum)
　　With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　DoCmd.Echo True
End Sub

Public Sub ReShow(iNum As Integer)
　　DoCmd.Echo False
　　Call lst1_Click
　　With Me("FSUB" & iNum)
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　DoCmd.Echo True
End Sub



Private Sub ShowFSub(iNum As Integer)
　　Dim i As Integer
　　Dim bShow As Boolean

　　bShow = True
　　For i = iNum To 4
　　　　With Me("FSUB" & i)
　　　　　　If (bShow) Then
　　　　　　　　Me.Tag = CSUB(i)(2)
　　　　　　　　.SourceObject = "FS1"
　　　　　　　　.Visible = True
　　　　　　　　If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
　　　　　　Else
　　　　　　　　.Visible = False
　　　　　　　　.SourceObject = ""
　　　　　　End If
　　　　End With
　　Next
　　Me.Tag = ""
End Sub


Private Sub init()
　　Dim i As Integer

　　Me.lst1 = Null
　　Me.lst1.Requery

　　For i = 1 To 4
　　　　Me("txt" & i) = ""
　　　　With Me("FSUB" & i)
　　　　　　.Visible = False
　　　　　　.SourceObject = ""
　　　　End With
　　Next
End Sub



Private Sub Form_Load()
　　Call initCnst
　　Call init
End Sub

Private Sub lst1_Click()
　　DoCmd.Echo False
　　Me.txt1 = Me.lst1.Column(1)
　　Me.txt2 = Me.lst1.Column(3)
　　Me.txt3 = Me.lst1.Column(5)
　　Me.txt4 = Me.lst1.Column(7)
　　Call ShowFSub(1)
　　DoCmd.Echo True
End Sub

Private Sub btn1_Click()
　　DoCmd.Echo False
　　Call init
　　DoCmd.Echo True
End Sub

Private Sub btn2_Click()
　　DoCmd.Echo False
　　Call init
　　Me.Tag = CSUB(1)(2)
　　With Me("FSUB1")
　　　　.SourceObject = "FS1"
　　　　.Visible = True
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　Me.Tag = ""
　　DoCmd.Echo True
End Sub

Dim myNo As Integer
Dim bNewEdit As Boolean

Private Sub Form_Open(Cancel As Integer)
　　Dim sAry() As String

　　On Error Resume Next
　　sAry = Split(Me.Parent.Tag, ",")
　　If (Err <> 0) Then
　　　　Cancel = True
　　　　Exit Sub
　　End If

　　myNo = CInt(sAry(0))
　　Me.RecordSource = sAry(1)
　　Me.txt1.ControlSource = sAry(2)
　　Me.txt1.Controls(0).Caption = sAry(2)
　　Me.txt2.ControlSource = sAry(3)
　　Me.txt2.Controls(0).Caption = sAry(3)
　　Me.op11.ControlSource = "use"
　　Me.txt11.ControlSource = sAry(4)
　　Me.txt12.ControlSource = sAry(5)

　　Me.Filter = Me.Parent.GetMyFilter(myNo)
　　Me.FilterOn = Len(Me.Filter) > 0
　　If (Not Me.FilterOn) Then
　　　　Me.DataEntry = True
　　End If
　　bNewEdit = False
End Sub

Private Sub Form_Current()
　　If (bNewEdit) Then Call Me.Parent.ReShow(myNo)
　　bNewEdit = False
End Sub

Private Sub Form_BeforeInsert(Cancel As Integer)
　　Call Me.Parent.NewMyItemReset(myNo)
　　bNewEdit = True
End Sub

Private Sub Form_BeforeUpdate(Cancel As Integer)
　　If (Me.NewRecord) Then
　　　　Me.txt11 = Nz(DMax(Me.txt11.ControlSource, Me.RecordSource), 0) + 1
　　　　If (Len(Me.txt12.ControlSource) > 0) Then
　　　　　　Me.txt12 = Me.Parent.GetMyParentItem(myNo)
　　　　End If
　　End If
End Sub

Private Sub Form_AfterUpdate()
　　Dim sSql As String

　　If ((bNewEdit) And (Me.FilterOn) And (Len(Me.txt12.ControlSource) > 0)) Then
　　　　sSql = "UPDATE " & Me.RecordSource & " SET use = False " _
　　　　　　　　& "WHERE " & Me.Filter & " ;"
　　　　CurrentDb.Execute sSql
　　End If
　　Call Me.Parent.NewMyItemSet(myNo, Me.txt11)
　　bNewEdit = False
End Sub

Dim CSUB(1 To 4) As Variant

Private Sub initCnst()
　　CSUB(1) = Array("txt1", "受付ID", "1,T受付2,受付日付,担当者,受付ID,")
　　CSUB(2) = Array("txt2", "見積ID", "2,T見積2,見積日付,見積内容,見積ID,受付ID")
　　CSUB(3) = Array("txt3", "契約ID", "3,T契約2,契約日付,契約内容,契約ID,見積ID")
　　CSUB(4) = Array("txt4", "完了ID", "4,T完了2,完了日付,完了内容,完了ID,契約ID")
End Sub


Public Function GetMyFilter(iNum As Integer) As String
　　Dim s As String

　　GetMyFilter = ""
　　s = Me(CSUB(iNum)(0))
　　If (Len(s) > 0) Then
　　　　GetMyFilter = CSUB(iNum)(1) & " = " & s
　　End If
End Function

Public Function GetMyParentItem(iNum As Integer) As Long
　　Dim i As Integer
　　Dim s As String

　　GetMyParentItem = 0
　　i = iNum - 1
　　If (i > 0) Then
　　　　s = Me(CSUB(i)(0))
　　　　If (Len(s) = 0) Then
　　　　　　GetMyParentItem = 0
　　　　Else
　　　　　　GetMyParentItem = CLng(s)
　　　　End If
　　End If
End Function


Public Sub NewMyItemReset(iNum As Integer)
　　Dim i As Integer

　　If (Len(Me(CSUB(iNum)(0))) = 0) Then Exit Sub

　　DoCmd.Echo False
　　For i = iNum To 4
　　　　Me("txt" & i) = ""
　　Next
　　For i = iNum + 1 To 4
　　　　With Me("FSUB" & i)
　　　　　　.Visible = False
　　　　　　.SourceObject = ""
　　　　End With
　　Next
　　DoCmd.Echo True
End Sub

Public Sub NewMyItemSet(iNum As Integer, iSrc As Long)
　　Dim sTxt As String

　　DoCmd.Echo False
　　sTxt = CSUB(iNum)(0)
　　If (Me(sTxt) <> iSrc) Then
　　　　Me(sTxt) = iSrc
　　　　Me.lst1 = IdMake(Me.txt1.Value, Me.txt2.Value, Me.txt3.Value, Me.txt4.Value)
　　End If
　　Me.lst1.Requery
　　Call ShowFSub(iNum)
　　With Me("FSUB" & Choose(iNum, 2, 3, 4, 1))
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　DoCmd.Echo True
End Sub

Public Sub ReShow(iNum As Integer)
　　DoCmd.Echo False
　　Call lst1_Click
　　With Me("FSUB" & iNum)
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　DoCmd.Echo True
End Sub



Private Sub ShowFSub(iNum As Integer)
　　Dim i As Integer
　　Dim bShow As Boolean

　　bShow = True
　　For i = iNum To 4
　　　　With Me("FSUB" & i)
　　　　　　If (bShow) Then
　　　　　　　　Me.Tag = CSUB(i)(2)
　　　　　　　　.SourceObject = "FS2"
　　　　　　　　.Visible = True
　　　　　　　　If (Len(Me(CSUB(i)(0))) = 0) Then bShow = False
　　　　　　Else
　　　　　　　　.Visible = False
　　　　　　　　.SourceObject = ""
　　　　　　End If
　　　　End With
　　Next
　　Me.Tag = ""
End Sub


Private Sub init()
　　Dim i As Integer

　　Me.lst1 = Null
　　Me.lst1.Requery

　　For i = 1 To 4
　　　　Me("txt" & i) = ""
　　　　With Me("FSUB" & i)
　　　　　　.Visible = False
　　　　　　.SourceObject = ""
　　　　End With
　　Next
End Sub



Private Sub Form_Load()
　　Call initCnst
　　Call init
End Sub

Private Sub lst1_Click()
　　DoCmd.Echo False
　　Me.txt1 = Me.lst1.Column(1)
　　Me.txt2 = Me.lst1.Column(3)
　　Me.txt3 = Me.lst1.Column(5)
　　Me.txt4 = Me.lst1.Column(7)
　　Call ShowFSub(1)
　　DoCmd.Echo True
End Sub

Private Sub btn1_Click()
　　DoCmd.Echo False
　　Call init
　　DoCmd.Echo True
End Sub

Private Sub btn2_Click()
　　DoCmd.Echo False
　　Call init
　　Me.Tag = CSUB(1)(2)
　　With Me("FSUB1")
　　　　.SourceObject = "FS2"
　　　　.Visible = True
　　　　.SetFocus
　　　　.Form.txt1.SetFocus
　　End With
　　Me.Tag = ""
　　DoCmd.Echo True
End Sub