frmqueueset.frm

排队分诊管理系统源代码！该代码使用VB6开发环境

         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar stbInfo 
      Height          =   300
      Index           =   2
      Left            =   7920
      TabIndex        =   18
      Top             =   200
      Width           =   375
      _ExtentX        =   661
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Bevel           =   2
            Object.Width           =   3316
            MinWidth        =   3316
            Text            =   "种"
            TextSave        =   "种"
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "frmQueueSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim m_tagErrInfo    As TYPE_ERRORINFO

Dim m_bChoice       As Boolean                          '是否选择了 ListView 的选项
Dim m_iChoice       As Integer                          '选择的 ListView 的选项的 Key

Private Sub cmdAddNew_Click()
    On Error Resume Next
    Dim dlg As dlgQueueSet
    
    Set dlg = New dlgQueueSet
    Load dlg
    If dlg.InitSet = True Then dlg.Show vbModal
    Set dlg = Nothing
    cmdRefresh_Click
End Sub

Private Sub cmdChange_Click()
    On Error Resume Next
    Dim dlg As dlgQueueSet
    
    Set dlg = New dlgQueueSet
    Load dlg
    dlg.ServiceCode = lsvService.ListItems(m_iChoice).Text
    If dlg.InitSet = True Then dlg.Show vbModal
    Set dlg = Nothing
    cmdRefresh_Click
End Sub

Private Sub cmdDelete_Click()
    On Error GoTo ERROR_EXIT
    Dim iTrans As Integer
    
    If MsgBox("是否删除选择的服务信息(Y/N)?", vbYesNo Or vbQuestion, "系统提示") = vbNo Then Exit Sub
    If CheckDelete = False Then
        MsgBox "该服务有关联的窗口条屏信息，无法删除！", vbOKOnly, "系统提示"
        Exit Sub
    End If
    
    iTrans = dbMyDB.BeginTrans
    
    dbMyDB.Execute "DELETE FROM Style WHERE st_code = '" & lsvService.ListItems(m_iChoice).Text & _
                   "' AND st_type = 1"
    
    If iTrans > 0 Then
        dbMyDB.CommitTrans
        iTrans = 0
    End If
        
    cmdRefresh_Click
    
    Exit Sub
ERROR_EXIT:
    If iTrans > 0 Then dbMyDB.RollbackTrans
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueSet"
    m_tagErrInfo.strErrFunc = "cmdDelete_Click"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

Private Sub cmdQuit_Click()
    On Error Resume Next
    Unload Me
End Sub

Private Sub cmdRefresh_Click()
    On Error Resume Next
    m_bChoice = False
    m_iChoice = 0
    txtType.Enabled = False
    cmdChange.Enabled = False
    cmdDelete.Enabled = False
    InitListInfo
End Sub

Private Sub Form_Load()
    On Error Resume Next
    m_bChoice = False
    m_iChoice = 0
    txtType.Enabled = False
    cmdChange.Enabled = False
    cmdDelete.Enabled = False
    InitListInfo
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Dim i As Integer, j As Integer

    If Me.WindowState = 1 Then Exit Sub
    
    If Me.Width < 8535 Then Me.Width = 8535
    If Me.Height < 6420 Then Me.Height = 6420
    
    i = Me.Width - 8535
    j = Me.Height - 6420

    '修改宽度
    fra3.Width = i + 8175
    lsvService.Width = i + 7935
    cmdRefresh.Left = i + 6120
    cmdQuit.Left = i + 7200
    
    '修改高度位置
    fra3.Height = j + 3855
    lsvService.Height = j + 3495
    
    cmdAddNew.Top = j + 5520
    cmdChange.Top = j + 5520
    cmdDelete.Top = j + 5520
    cmdRefresh.Top = j + 5520
    cmdQuit.Top = j + 5520
End Sub

Private Sub Form_Terminate()
    On Error Resume Next
    Set frmQueueSet = Nothing
End Sub

Private Sub lsvService_ItemClick(ByVal Item As MSComctlLib.ListItem)
    On Error Resume Next
    m_bChoice = True
    m_iChoice = Item.Index
    cmdChange.Enabled = True
    cmdDelete.Enabled = True
End Sub

'/////////////////////////////////////////////////////////////////////////////////////////
'/初始化 List 控件信息
Private Function InitListInfo() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, i As Integer
    Dim itmX As ListItem
    
    lsvService.ListItems.Clear
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    '查询数据库
    strSQL = "SELECT * FROM Style WHERE st_type = 1 "
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        rs.MoveFirst
        For i = 1 To rs.RecordCount
            Set itmX = lsvService.ListItems.Add(, , rs!st_code)
            If Not IsNull(rs!st_name) Then itmX.SubItems(1) = rs!st_name
            If Not IsNull(rs!note) Then itmX.SubItems(2) = rs!note
            rs.MoveNext
        Next i
    Else
        InitListInfo = False
        Exit Function
    End If
    rs.Close
    
    txtType.Text = lsvService.ListItems.Count
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    InitListInfo = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueSet"
    m_tagErrInfo.strErrFunc = "InitListInfo"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    InitListInfo = False
End Function

'/////////////////////////////////////////////////////////////////////////////////////////////
'/检查能否删除相关信息
Private Function CheckDelete() As Boolean
    On Error Resume Next
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, bResult As Boolean
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    bResult = False
    
    '查询数据库
    strSQL = "SELECT * FROM StyleRelation WHERE sr_type = 2 AND rt_code = '" & _
             lsvService.ListItems(m_iChoice).Text & "' AND rt_type = 1"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        bResult = False
    Else
        bResult = True
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    CheckDelete = bResult
End Function