项目向导.frm

u8

Private Sub cmdX_Click(Index As Integer)
   blnChangeKm = True
   Select Case Index
      Case 0
         AllItem lstDxkm, lstXdkm
      Case 1
         SingleItem lstDxkm, lstXdkm
      Case 2
         SingleItem lstXdkm, lstDxkm
      Case 3
         AllItem lstXdkm, lstDxkm
   End Select
   
End Sub

Private Sub cobDl_Click()
   Dim rsX As New UfRecordset, sqlX As String
   Dim i As Long
   Static lngDl As Long
   
   If Not blnRuned Then
      lngDl = 0
      blnRuned = True
   End If
   If lngDl = cobDl.ListIndex + 1 Then Exit Sub
   
   If blnChangeDl Then
      If Not VerifyDl Then
         Exit Sub
      Else
         If lngDl <> 0 Then
            SavDl lngDl
         End If
      End If
      blnChangeDl = False
   End If
   lngDl = cobDl.ListIndex + 1
   
   blnClick = True
   edtDlmc = cobDl.Text
   blnClick = False
   sqlX = "SELECT [cgrade] FROM FD_Item WHERE [iitems_id]=" & (cobDl.ListIndex + 1)
   Set rsX = dbsZJ.OpenRecordset(sqlX, dbOpenSnapshot)
   For i = 0 To 3
      txtgrade(i) = mID(rsX![cGrade], (i + 1), 1)
   Next i
   '级次判断，调试后启用本段代码
   sqlX = "SELECT * FROM FD_Items WHERE [iitems_id]=" & (cobDl.ListIndex + 1)
   Set rsX = dbsZJ.OpenRecordset(sqlX, dbOpenSnapshot)
   If rsX.EOF Then
      For i = 0 To 3
         txtgrade(i).Locked = False
      Next i
   Else
      For i = 0 To 3
         txtgrade(i).Locked = True
      Next i
   End If
   FillLst 0
   bReXmLst = True
   
End Sub

Private Sub SavDl(mIndex As Long)
   Dim sqlDl As String, i As Integer, strGrade As String
   
   On Error GoTo ErrL
   dbsZJ.BeginTrans
   For i = 0 To 3
      strGrade = strGrade & txtgrade(i)
   Next i
   sqlDl = "UPDATE FD_Item SET [citems_name]='" & edtDlmc & "',[cgrade]='" & strGrade & _
         "' WHERE [iitems_id]=" & mIndex
   dbsZJ.Execute sqlDl
   dbsZJ.CommitTrans
   cobDl.List(mIndex - 1) = edtDlmc
   blnRefresh = True
   Exit Sub
ErrL:
   dbsZJ.Rollback
   
End Sub

'**********************************************************************
'*函数说明: 存储科目                                                    *
'*参    数: mIndex - 项目名称            　                             *
'*                                                                     *
'*返回值  :                                             　             *
'***********************************************************************
Private Function SavKm(mIndex As Integer) As Boolean
   Dim sqlKm As String
   Dim rsKm As New UfRecordset
   Dim i As Integer
   Dim sqlExch As String
   Dim rsExch As New UfRecordset
   Dim strAccID As String
   
   On Error GoTo ErrL
   dbsZJ.BeginTrans
   sqlKm = "DELETE FROM FD_Itemss WHERE [iitem_id]=" & lngCobXmmc(1, mIndex)
   dbsZJ.Execute sqlKm
   Set rsKm = dbsZJ.OpenRecordset("FD_Itemss", dbOpenDynaset)
   With rsKm
      For i = 0 To lstXdkm.ListCount - 1
      .AddNew
      ![iItem_id] = lngCobXmmc(1, mIndex)
      ![cCode] = mID(lstXdkm.List(i), 2, InStr(1, lstXdkm.List(i), "]") - 2)
      .Update
      Next i
   End With
   blnChangeKm = False
   blnRefresh = True
   SavKm = True
   dbsZJ.CommitTrans
   Exit Function
   
ErrL:
   dbsZJ.Rollback
   SavKm = True
   blnChangeKm = False
   
End Function

Private Sub cobSrc_KeyUp(KeyCode As Integer, Shift As Integer) 'Cuidong 2000/08/04
   If KeyCode = vbKeyReturn Then SendKeys ("{Tab}")            'Cuidong 2000/08/04
End Sub                                                        'Cuidong 2000/08/04

Private Sub cobXmmc_Click()
   Dim rsXm As New UfRecordset, sqlXm As String
   Dim blnKm As Boolean
   Static lngXm As Long
      
   If Not blnFillcob Then
      lngXm = 0
      blnFillcob = True
   End If
   If lngXm = cobXmmc.ListIndex + 1 Then Exit Sub
   If blnChangeKm Then
      If Not SavKm(lngXm - 1) Then
         MsgBox "网络互斥，请过一会儿再试！", vbInformation, zjGl_Name
      End If
      blnChangeKm = False
   End If
   lngXm = cobXmmc.ListIndex + 1
   If lngCobXmmc(0, cobXmmc.ListIndex) = 1 Then
      Label4 = "待选科目"
      Label9 = "选定科目"
      blnKm = True
   Else
      Label4 = "待选账户"
      Label9 = "选定账户"
      blnKm = False
   End If
   If blnKm Then
      sqlXm = "SELECT FD_Itemss.[ccode] AS fCode, code.[ccode_name] AS fName " & _
           "FROM FD_Itemss INNER JOIN code ON FD_Itemss.[ccode]=code.[ccode] " & _
           "WHERE FD_Itemss.[iitem_id]=" & lngCobXmmc(1, cobXmmc.ListIndex)
   Else
      sqlXm = "SELECT FD_Itemss.[ccode] AS fCode, FD_AccDef.[cAccName] AS fName " & _
           "FROM FD_Itemss INNER JOIN FD_AccDef ON FD_Itemss.[ccode]=FD_AccDef" & _
           ".[cAccID] WHERE FD_Itemss.[iitem_id]=" & _
           lngCobXmmc(1, cobXmmc.ListIndex)
   End If
   Set rsXm = dbsZJ.OpenRecordset(sqlXm, dbOpenSnapshot)
   lstXdkm.Clear
   While Not rsXm.EOF
      lstXdkm.AddItem "[" & rsXm![fCode] & "] " & rsXm![fName]
      rsXm.MoveNext
   Wend
   
   If blnKm Then
      sqlXm = "SELECT [ccode] AS fCode, [ccode_name] AS fName FROM code WHERE " & _
            "[ccode] NOT IN (SELECT [ccode] FROM FD_Itemss WHERE [iitem_id]=" & _
            lngCobXmmc(1, cobXmmc.ListIndex) & ")"
   Else
      sqlXm = "SELECT [cAccID] AS fCode, [cAccName] AS fName FROM FD_AccDef " & _
            "WHERE [cAccID] NOT IN (SELECT [ccode] FROM FD_Itemss WHERE [iitem_id]=" & _
            lngCobXmmc(1, cobXmmc.ListIndex) & ")"
   End If
   Set rsXm = dbsZJ.OpenRecordset(sqlXm, dbOpenSnapshot)
   lstDxkm.Clear
   While Not rsXm.EOF
      lstDxkm.AddItem "[" & rsXm![fCode] & "] " & rsXm![fName]
      rsXm.MoveNext
   Wend
   If lstDxkm.ListCount > 0 Then
      lstDxkm.Selected(0) = True
      cmdX(0).Enabled = True
      cmdX(1).Enabled = True
   Else
      cmdX(0).Enabled = False
      cmdX(1).Enabled = False
   End If
   If lstXdkm.ListCount > 0 Then
      lstXdkm.Selected(0) = True
      cmdX(2).Enabled = True
      cmdX(3).Enabled = True
   Else
      cmdX(2).Enabled = False
      cmdX(3).Enabled = False
   End If
   
End Sub

Private Sub edtXmmc_KeyUp(KeyCode As Integer, Shift As Integer) 'Cuidong 2000/08/04
   If KeyCode = vbKeyReturn Then SendKeys ("{Tab}")             'Cuidong 2000/08/04
End Sub                                                         'Cuidong 2000/08/04

Private Sub Form_Load()
   mStep = 0
   Me.Icon = LoadResPicture(109, vbResIcon)
   bk(mStep).Visible = True
   cmdStep(0).Enabled = False
   cobSrc.Text = ""                 'Cuidong 2000/06/30
   cobSrc.AddItem "科目"
   cobSrc.AddItem "账户"
   blnRuned = False
   CenterForm Me
   
End Sub

Private Sub lstDxkm_DblClick()
   blnChangeKm = True
   SingleItem lstDxkm, lstXdkm
   
End Sub

Private Sub SingleItem(lstFrom As ListBox, lstTo As ListBox)
   Dim i As Long
   
   lstTo.AddItem lstFrom.List(lstFrom.ListIndex)
   If lstTo.ListIndex = -1 Then
      lstTo.Selected(0) = True
   End If
   
   i = lstFrom.ListIndex
   lstFrom.RemoveItem lstFrom.ListIndex
   If lstFrom.ListCount <> 0 Then
      If i < lstFrom.ListCount Then
         lstFrom.Selected(i) = True
      Else
         lstFrom.Selected(i - 1) = True
      End If
   End If
   
   If lstDxkm.ListCount > 0 Then
      cmdX(0).Enabled = True
      cmdX(1).Enabled = True
   Else
      cmdX(0).Enabled = False
      cmdX(1).Enabled = False
   End If
   If lstXdkm.ListCount > 0 Then
      cmdX(2).Enabled = True
      cmdX(3).Enabled = True
   Else
      cmdX(2).Enabled = False
      cmdX(3).Enabled = False
   End If
   
End Sub

Private Sub AllItem(lstFrom As ListBox, lstTo As ListBox)
   Dim i As Long
   
   For i = 0 To lstFrom.ListCount - 1
      lstTo.AddItem lstFrom.List(i)
   Next i
   lstFrom.Clear
   If lstTo.ListIndex = -1 Then lstTo.Selected(0) = True
   If lstFrom.Name = "lstDxkm" Then
      cmdX(0).Enabled = False
      cmdX(1).Enabled = False
      cmdX(2).Enabled = True
      cmdX(3).Enabled = True
   Else
      cmdX(0).Enabled = True
      cmdX(1).Enabled = True
      cmdX(2).Enabled = False
      cmdX(3).Enabled = False
   End If
   
End Sub

Private Sub lstXdkm_DblClick()
   blnChangeKm = True
   SingleItem lstXdkm, lstDxkm
   
End Sub

Private Sub lstXmml_Click()
   Dim rsXm As New UfRecordset, sqlXm As String, strID As String
   Dim i As Integer
      
   strID = mID(lstXmml.List(lstXmml.ListIndex), 2, InStr(1, _
         lstXmml.List(lstXmml.ListIndex), "]") - 2)
   sqlXm = "SELECT * FROM FD_Items WHERE [citem_id]='" & strID & _
         "' AND [iitems_id]=" & (cobDl.ListIndex + 1)
   Set rsXm = dbsZJ.OpenRecordset(sqlXm, dbOpenSnapshot)
   If rsXm.EOF Then
      ' 记录被其他用户删除，此处应删除次项目
      i = lstXmml.ListIndex
      lstXmml.RemoveItem lstXmml.ListIndex
      If lstXmml.ListCount > 0 Then
         If i < lstXmml.ListCount Then
            lstXmml.Selected(i) = True
         Else
            lstXmml.Selected(i - 1) = True
         End If
      End If
   Else
      txtXmbm = rsXm![cItem_id]
      edtXmmc = rsXm![cItem_Name]
      cobSrc.Text = IIf(rsXm![bend], IIf(rsXm![bSource], cobSrc.List(0), cobSrc.List(1)), "")
   End If
   cmdOk.Enabled = False
   txtXmbm.Enabled = False
   cobSrc.Enabled = False
   blnAddOrEdit = False
   
End Sub

Private Sub edtDlmc_Change()
   If Not blnClick Then blnChangeDl = True
   
End Sub

Private Sub txtgrade_Change(Index As Integer)
   txtgrade(Index) = Cut_String(txtgrade(Index), 1)
   If Not blnClick Then blnChangeDl = True
   
End Sub

Private Sub txtgrade_KeyPress(Index As Integer, KeyAscii As Integer)
   If (KeyAscii >= Asc(1) And KeyAscii <= Asc(9)) Or KeyAscii = 8 Then
   Else
      KeyAscii = 0
   End If
   
End Sub

Private Sub txtXmbm_Change()
   Dim i As Integer, tmpGrade As Integer
   
   For i = 1 To 4
      tmpGrade = tmpGrade + lngGrade(i)
   Next i
   txtXmbm = Cut_String(txtXmbm, IIf(tmpGrade = 0, 8, tmpGrade))
   
End Sub

Private Sub txtXmbm_KeyPress(KeyAscii As Integer)
   
   If (KeyAscii >= Asc(0) And KeyAscii <= Asc(9)) Or KeyAscii = 8 Then
   Else
      KeyAscii = 0
   End If

End Sub

Private Sub edtxmmc_Change()
   cmdOk.Enabled = True
   
End Sub

Private Sub txtXmbm_KeyUp(KeyCode As Integer, Shift As Integer) 'Cuidong 2000/08/04
   If KeyCode = vbKeyReturn Then SendKeys ("{Tab}")             'Cuidong 2000/08/04
End Sub                                                         'Cuidong 2000/08/04