frmsystem.frm

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

Private Sub cmdChange_Click()
    On Error Resume Next
    Dim dlg As frmUserName
    
    Set dlg = New frmUserName
    Load dlg
    dlg.m_sLogin = lsvUser.ListItems(m_iChange).ListSubItems(1).Text
    dlg.m_sName = lsvUser.ListItems(m_iChange).ListSubItems(2).Text
    dlg.Init
    dlg.Show vbModal
    If dlg.m_bCancel = False Then
        lsvUser.ListItems(m_iChange).ListSubItems(1).Text = dlg.m_sLogin
        lsvUser.ListItems(m_iChange).ListSubItems(2).Text = dlg.m_sName
    End If
    Set dlg = Nothing
    
    m_bChange = False
    m_iChange = 0
    cmdChange.Enabled = False
    cmdDelete.Enabled = False
End Sub

Private Sub cmdDelete_Click()
    On Error Resume Next
    Dim i As Integer
    
    If lsvUser.ListItems.Count > m_iChange Then
        For i = m_iChange To lsvUser.ListItems.Count - 1
            lsvUser.ListItems(i).ListSubItems(0).Text = lsvUser.ListItems(i + 1).ListSubItems(0).Text
            lsvUser.ListItems(i).ListSubItems(1).Text = lsvUser.ListItems(i + 1).ListSubItems(1).Text
            lsvUser.ListItems(i).ListSubItems(2).Text = lsvUser.ListItems(i + 1).ListSubItems(2).Text
        Next i
    End If
    lsvUser.ListItems.Remove lsvUser.ListItems.Count
    
    m_bChange = False
    m_iChange = 0
    cmdChange.Enabled = False
    cmdDelete.Enabled = False
End Sub

Private Sub cmdOK_Click()
    On Error GoTo ERROR_EXIT
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String
    Dim Leng As Integer, i As Integer
    Dim r As clsRegistry
    
    If CheckInfo = False Then Exit Sub
    
    Set r = New clsRegistry
    
    '保存INI文件
    Subkey = g_strREG_SERVER_KEY
    sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
    sNextFile = RemoveNullChar(sNextFile)

    If sNextFile = "" Then
        sINIFile = App.Path & "\CyQueue.INI"
        SetErrorLogFile App.Path
    Else
        AddDirSep sNextFile
        sINIFile = sNextFile & "CyQueue.INI"
    End If
    Set r = Nothing
    
    Leng = lsvUser.ListItems.Count
        
    '写INI文件
    sWriteINI sINIFile, "Server", "ServerName", txtServer.Text
    sWriteINI sINIFile, "Server", "ServerPort", txtPort.Text
    
    sWriteINI sINIFile, "User", "Count", CStr(Leng)
    
    For i = 1 To Leng
        sWriteINI sINIFile, "Settings", "UserLogin" & i, _
                    Trim$(lsvUser.ListItems(i).ListSubItems(1).Text)
        sWriteINI sINIFile, "Settings", "UserName" & i, _
                    Trim$(lsvUser.ListItems(i).ListSubItems(2).Text)
    Next i
    
    MsgBox "客户端系统配置已更改,系统下次登录时生效。", vbOKOnly, "系统提示"
    
    Unload Me
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmSystem"
    m_tagErrInfo.strErrFunc = "cmdOK_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 Form_Load()
    On Error GoTo ERROR_EXIT
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String
    Dim Leng As Integer, i As Integer
    Dim r As clsRegistry
    Dim itmX As ListItem
    
    Set r = New clsRegistry
    m_bChange = False
    m_iChange = 0
    
    '初始化 Listview显示
    lsvUser.ColumnHeaders.Add , , "编号"
    lsvUser.ColumnHeaders.Add , , "员工工号"
    lsvUser.ColumnHeaders.Add , , "员工名称"
    
    Subkey = g_strREG_SERVER_KEY
    sNextFile = r.GetValue(eHKEY_LOCAL_MACHINE, Subkey, "Path")
    sNextFile = RemoveNullChar(sNextFile)
    If sNextFile = "" Then
        sINIFile = App.Path & "\CyQueue.INI"
        SetErrorLogFile App.Path
    Else
        AddDirSep sNextFile
        sINIFile = sNextFile & "CyQueue.INI"
    End If
    Set r = Nothing
    
    '检查服务器名和端口号
    txtServer.Text = sGetINI(sINIFile, "Server", "ServerName", "?")
    txtPort.Text = Format(sGetINI(sINIFile, "Server", "ServerPort", "?"), "00000")
    
    Leng = CInt(sGetINI(sINIFile, "User", "Count", 0))
    If Leng = 0 Then GoTo ERROR_EXIT
    
    ReDim strServer(Leng - 1)
    For i = 1 To Leng
        Set itmX = lsvUser.ListItems.Add(, , CStr(i))
        itmX.SubItems(1) = sGetINI(sINIFile, "Settings", "UserLogin" & i, "?")
        itmX.SubItems(2) = sGetINI(sINIFile, "Settings", "UserName" & i, "?")
    Next i
    
    cmdChange.Enabled = False
    cmdDelete.Enabled = False
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmSystem"
    m_tagErrInfo.strErrFunc = "Form_Load"
    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 Form_Terminate()
    On Error Resume Next
    Set frmSystem = Nothing
End Sub

Private Sub lsvUser_ItemClick(ByVal Item As MSComctlLib.ListItem)
    On Error Resume Next
    If Item.Index > 0 Then
        m_iChange = Item.Index
        m_bChange = True
        '修改按钮状态
        cmdChange.Enabled = True
        cmdDelete.Enabled = True
    End If
End Sub

Private Sub txtIPNumber_GotFocus()
    On Error Resume Next
    txtIPNumber.BackColor = &H80000018
End Sub

Private Sub txtIPNumber_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = 13 Then  '是回车键？
    KeyAscii = 0 '0取消输入
    SendKeys "{tab}"
    End If
End Sub

Private Sub txtIPNumber_LostFocus()
    On Error Resume Next
    txtIPNumber.BackColor = &H80000005
End Sub

Private Sub txtPort_GotFocus()
    On Error Resume Next
    txtPort.BackColor = &H80000018
End Sub

Private Sub txtPort_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = 13 Then  '是回车键？
    KeyAscii = 0 '0取消输入
    SendKeys "{tab}"
    End If
End Sub

Private Sub txtPort_LostFocus()
    On Error Resume Next
    txtPort.BackColor = &H80000005
End Sub

Private Sub txtServer_GotFocus()
    On Error Resume Next
    txtServer.BackColor = &H80000018
End Sub

Private Sub txtServer_KeyPress(KeyAscii As Integer)
    On Error Resume Next
    If KeyAscii = 13 Then  '是回车键？
    KeyAscii = 0 '0取消输入
    SendKeys "{tab}"
    End If
End Sub

Private Sub txtServer_LostFocus()
    On Error Resume Next
    txtServer.BackColor = &H80000005
End Sub

'//////////////////////////////////////////////////////////////////
'检查数据有效性
Private Function CheckInfo() As Boolean
    On Error Resume Next
    Dim i As Integer
    
    If Trim$(txtServer.Text) = "" Or IsNumeric(txtPort.Text) = False Then
        MsgBox "请输入有效的数据服务器名和服务端口号！", vbOKOnly + vbCritical, "系统错误"
        txtServer.SetFocus
        CheckInfo = False
        Exit Function
    End If
    If lsvUser.ListItems.Count = 0 Then
        MsgBox "请输入有效的用户信息！", vbOKOnly + vbCritical, "系统错误"
        txtServer.SetFocus
        CheckInfo = False
        Exit Function
    End If
    For i = 1 To lsvUser.ListItems.Count
        If Trim$(lsvUser.ListItems(i).ListSubItems(1).Text) = "" Then
            MsgBox "请输入有效的用户工号,用户工号不能为空！", vbOKOnly + vbCritical, "系统错误"
            txtServer.SetFocus
            CheckInfo = False
            Exit Function
        End If
    Next i
    
    CheckInfo = True
End Function