项目向导.frm

u8

         If lstXmml.ListCount = 0 Then
            txtXmbm = "": edtXmmc = "": cmdOk.Enabled = False: cmdDel.Enabled = False
         Else
            cmdDel.Enabled = True
         End If
      End If
      
    End If
   
End Sub

'**********************************************************************
'*函数说明: 显示图片                                                    *
'*参    数: nStep - 步数             　                                 *
'*                                                                      *
'*返回值  :                                             　              *
'***********************************************************************
Private Sub ShowSign(nStep As Long)
   Select Case nStep
      Case 0
         l1.Visible = True
         s1.Visible = False
         n2.Visible = True
         l2.Visible = False
         s2.Visible = False
         n3.Visible = True
         l3.Visible = False
      Case 1
         l1.Visible = False
         s1.Visible = True
         n2.Visible = False
         l2.Visible = True
         s2.Visible = False
         n3.Visible = True
         l3.Visible = False
      Case 2
         l1.Visible = False
         s1.Visible = True
         n2.Visible = False
         l2.Visible = False
         s2.Visible = True
         n3.Visible = False
         l3.Visible = True
   End Select
   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 Function VerifyDl() As Boolean
   Dim i As Long, j As Long, id As Integer
   
   VerifyDl = False
   
   If edtDlmc = "" Then
      MsgBox "报表名称不能为空！", vbInformation, zjGl_Name
      SetTxtFocus edtDlmc
      Exit Function
   End If
   
   For i = 1 To 3
      If txtgrade(i) = "" Then
         For j = i To 3
            If txtgrade(j) <> "" Then
               MsgBox "级数可自定义，但不允许跨级定义!", vbInformation, zjGl_Name
               txtgrade(j - 1).SetFocus
               Exit Function
            End If
         Next j
      End If
   Next i
   
   j = 0
   For i = 0 To 3
      If txtgrade(i) <> "" Then
         j = j + IIf(IsNumeric(txtgrade(i)), CInt(txtgrade(i)), 0)
         lngGrade(i + 1) = IIf(IsNumeric(txtgrade(i)), CInt(txtgrade(i)), 0)
      Else
         lngGrade(i + 1) = 0
      End If
   Next i
   If j > 8 Then
      MsgBox "总级长不能超出8位！", vbInformation, zjGl_Name
      SetTxtFocus txtgrade(1)
      Exit Function
   End If
   
   cGrade = txtgrade(0) & txtgrade(1) & txtgrade(2) & txtgrade(3)
   VerifyDl = True
   
End Function

Private Sub cmdAdd_Click()
   txtXmbm = ""
   edtXmmc = ""
   txtXmbm.Enabled = True
   cobSrc.Enabled = True
   cobSrc.ListIndex = IIf(cobSrc.Text = cobSrc.List(0), 0, 1)
   cmdOk.Enabled = True
   blnAddOrEdit = True
   txtXmbm.SetFocus
   
End Sub

Private Sub cmdDel_Click()
   Dim rsD As New UfRecordset, strID As String
   
   If lstXmml.ListCount = 0 Then Exit Sub
   If PromptDelItem(lstXmml.List(lstXmml.ListIndex)) Then
      DeleteItem
   Else
      Exit Sub
   End If
   blnFillcob = False
   bReXmLst = True
   blnRefresh = True
   If lstXmml.ListCount = 0 Then
      txtXmbm = "": edtXmmc = ""
      cmdDel.Enabled = False: cmdOk.Enabled = False
   End If
   
End Sub

Private Sub cmdOK_Click()
   If blnAddOrEdit Then
      If Not AddItem Then Exit Sub
   Else
      EditItem
   End If
   blnAddOrEdit = False
   cmdOk.Enabled = False
   cmdDel.Enabled = True
   txtXmbm.Enabled = False
   cobSrc.Enabled = False
   blnFillcob = False
   bReXmLst = True
   blnRefresh = True
   
End Sub

'**********************************************************************
'*函数说明: 删除项目编码                                                *
'*参    数:                             　                             *
'*                                                                     *
'*返回值  :                                             　             *
'***********************************************************************
Private Sub DeleteItem()
   Dim rsD As New UfRecordset, sqlD As String, sqlDs As String
   Dim strID As String, strSubID As String
   Dim sumGrade As Long, i As Integer
   
   strID = mID(lstXmml.List(lstXmml.ListIndex), 2, InStr(1, _
         lstXmml.List(lstXmml.ListIndex), "]") - 2)
   On Error GoTo ErrL
   dbsZJ.BeginTrans
   sqlDs = "DELETE FROM FD_Itemss WHERE [iitem_id] IN (SELECT [iitem_id] FROM " & _
      "FD_Items WHERE [citem_id] LIKE '" & strID & "%' AND [iitems_id]=" & _
      (cobDl.ListIndex + 1) & ")"
   dbsZJ.Execute sqlDs
   
   VerifyGrade
   If iGrade > 1 Then
      For i = 1 To iGrade - 1
         sumGrade = sumGrade + lngGrade(i)
      Next i
      strSubID = Left(strID, sumGrade)
      sqlD = "SELECT * FROM FD_Items WHERE [igrade]=" & iGrade & " AND [iitems_id]=" & _
         (cobDl.ListIndex + 1) & " AND [citem_id] LIKE '" & strSubID & "%'"
      Set rsD = dbsZJ.OpenRecordset(sqlD, dbOpenSnapshot)
      If Not rsD.EOF Then
      rsD.MoveLast
      If rsD.RecordCount = 1 Then
         sqlD = "UPDATE FD_Items SET [bend] = 1 WHERE [citem_id]='" & strSubID & _
            "' AND [iitems_id]=" & (cobDl.ListIndex + 1)
         dbsZJ.Execute sqlD
      End If
      End If
   End If
   sqlD = "DELETE FROM FD_Items WHERE [citem_id] LIKE '" & strID & "%' AND [iitems_id]=" & _
      (cobDl.ListIndex + 1)
   dbsZJ.Execute sqlD
   dbsZJ.CommitTrans
   
   i = lstXmml.ListIndex
   If lstXmml.ListCount > 0 Then
      If i < lstXmml.ListCount Then
         FillLst i
      Else
         FillLst lstXmml.ListCount - 1
      End If
   End If
   Exit Sub
   
ErrL:
   dbsZJ.Rollback
   
End Sub

'**********************************************************************
'*函数说明: 编辑项目编码                                                *
'*参    数:                             　                             *
'*                                                                     *
'*返回值  :                                             　             *
'***********************************************************************
Private Sub EditItem()
   Dim rsG As New UfRecordset, id As Integer
   
   If Trim(txtXmbm) = "" Then
      MsgBox "项目编码不能为空！", vbInformation, zjGl_Name
      SetTxtFocus txtXmbm
      Exit Sub
   End If
      
   If Trim(edtXmmc) = "" Then
      MsgBox "项目名称不能为空！", vbInformation, zjGl_Name
      SetTxtFocus edtXmmc
      Exit Sub
   End If
   
   
   VerifyGrade
   
   On Error GoTo ErrL
   dbsZJ.BeginTrans
   Set rsG = dbsZJ.OpenRecordset("SELECT * FROM FD_Items WHERE [iitems_id]=" & (cobDl.ListIndex + 1) & " AND [citem_id]='" & txtXmbm & "'", dbOpenDynaset)
   With rsG
      If .EOF Then
         .AddNew
         ![iitems_id] = cobDl.ListIndex + 1
         ![cItem_id] = txtXmbm
         ![cItem_Name] = edtXmmc
         ![iGrade] = iGrade
         ![bend] = True
         ![bSource] = IIf((cobSrc.ListIndex = 0), True, False)
         .Update
      Else
         .edit
         ![cItem_Name] = edtXmmc
         .Update
      End If
      lstXmml.List(lstXmml.ListIndex) = "[" & txtXmbm & "] " & edtXmmc
   End With
   
   dbsZJ.CommitTrans
   
   Exit Sub
   
ErrL:
   dbsZJ.Rollback
   If lstXmml.ListIndex <> -1 Then
      lstXmml.Selected(lstXmml.ListIndex) = True
   Else
      txtXmbm = "": edtXmmc = ""
   End If

End Sub

'**********************************************************************
'*函数说明: 增加项目编码                                                *
'*参    数:               　                                           *
'*                                                                     *
'*返回值  : True : 增加成功                           　                *
'***********************************************************************
Private Function AddItem() As Boolean
   Dim rsG As New UfRecordset
   Dim sqlG As String
   Dim id As Integer
   Dim strG As String
   Dim strF As String
   Dim i As Integer
   
   AddItem = False
   If Not VerifyGrade Then
      Exit Function
   End If
   If Not IsNumeric(txtXmbm) Then
      MsgBox "项目编码不符合级次定义！", vbInformation, zjGl_Name
      SetTxtFocus txtXmbm
      Exit Function
   End If
   If iGrade <> 1 Then
      For i = 1 To iGrade - 1
         strF = strF & strGrade(i)
      Next i
      sqlG = "SELECT * FROM FD_Items WHERE [citem_id]='" & strF & _
             "' AND [iitems_id]=" & (cobDl.ListIndex + 1)
      Set rsG = dbsZJ.OpenRecordset(sqlG, dbOpenSnapshot)
      If rsG.EOF Then
         MsgBox "项目编码不符合级次定义！", vbInformation, zjGl_Name
         SetTxtFocus txtXmbm
         Exit Function
      End If
   End If
   
   If edtXmmc = "" Then
      MsgBox "项目名称不能为空！", vbInformation, zjGl_Name
      SetTxtFocus edtXmmc
      Exit Function
   End If
   
   For i = 1 To iGrade
      strG = strG & strGrade(i)
   Next i
   
   Dim rsGrade As New UfRecordset
   Dim rsBend As New UfRecordset
   
   sqlG = "SELECT * FROM FD_Items WHERE [citem_id]='" & txtXmbm & "' AND " & _
         "[iitems_id]=" & (cobDl.ListIndex + 1)
   Set rsG = dbsZJ.OpenRecordset(sqlG, dbOpenSnapshot)
   If Not rsG.EOF Then
      MsgBox "项目编码不能重复！", vbInformation, zjGl_Name
      SetTxtFocus txtXmbm
      Exit Function
   End If
   On Error GoTo ErrL
   dbsZJ.BeginTrans
   Set rsGrade = dbsZJ.OpenRecordset("FD_Items", dbOpenDynaset)
   With rsGrade
      .AddNew
      ![iitems_id] = cobDl.ListIndex + 1
      ![cItem_id] = strG
      ![cItem_Name] = edtXmmc
      ![iGrade] = iGrade
      ![bend] = True
      ![bSource] = IIf((cobSrc.ListIndex = 0), True, False)
      .Update
   End With
   If iGrade <> 1 Then
      Set rsBend = dbsZJ.OpenRecordset("SELECT * FROM FD_Items WHERE [citem_id]='" & _
         strF & "' AND [iitems_id]=" & (cobDl.ListIndex + 1), dbOpenDynaset)
      With rsBend
         .edit
         ![bend] = False
         .Update
      End With
   End If
   lstXmml.AddItem "[" & strG & "] " & edtXmmc
   lstXmmlSelected "[" & strG & "] " & edtXmmc
   AddItem = True
   dbsZJ.CommitTrans
   
   Exit Function
   
ErrL:
   dbsZJ.Rollback
   lstXmml.Selected(lstXmml.ListIndex) = True
   
End Function

Private Sub lstXmmlSelected(strItem As String)
   Dim i As Integer
   
   For i = 0 To lstXmml.ListCount
      If lstXmml.List(i) = strItem Then
         lstXmml.Selected(i) = True
         Exit For
      End If
   Next i
   
End Sub