frmset.frm

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

VERSION 5.00
Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "TABCTL32.OCX"
Begin VB.Form frmSet 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "CyMobile管理系统设置"
   ClientHeight    =   2775
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4725
   Icon            =   "frmSet.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   2775
   ScaleWidth      =   4725
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin TabDlg.SSTab sst1 
      Height          =   2055
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   4455
      _ExtentX        =   7858
      _ExtentY        =   3625
      _Version        =   393216
      Style           =   1
      Tabs            =   2
      TabsPerRow      =   2
      TabHeight       =   520
      TabCaption(0)   =   "数据库"
      TabPicture(0)   =   "frmSet.frx":0CCA
      Tab(0).ControlEnabled=   -1  'True
      Tab(0).Control(0)=   "fra1"
      Tab(0).Control(0).Enabled=   0   'False
      Tab(0).ControlCount=   1
      TabCaption(1)   =   "通讯"
      TabPicture(1)   =   "frmSet.frx":0CE6
      Tab(1).ControlEnabled=   0   'False
      Tab(1).Control(0)=   "fra2"
      Tab(1).ControlCount=   1
      Begin VB.Frame fra2 
         Caption         =   "系统通讯端口设置"
         Height          =   1215
         Left            =   -74880
         TabIndex        =   8
         Top             =   600
         Width           =   4215
         Begin VB.TextBox txtPort 
            Height          =   270
            Left            =   1560
            MaxLength       =   5
            TabIndex        =   10
            Top             =   360
            Width           =   2415
         End
         Begin VB.TextBox txtClient 
            Enabled         =   0   'False
            Height          =   270
            Left            =   1560
            MaxLength       =   4
            TabIndex        =   9
            Top             =   720
            Width           =   2415
         End
         Begin VB.Label lblInfo 
            Caption         =   "系统通讯端口："
            Height          =   255
            Index           =   2
            Left            =   120
            TabIndex        =   12
            Top             =   375
            Width           =   1575
         End
         Begin VB.Label lblInfo 
            Caption         =   "最大终端客户数："
            Height          =   255
            Index           =   3
            Left            =   120
            TabIndex        =   11
            Top             =   720
            Width           =   1575
         End
      End
      Begin VB.Frame fra1 
         Caption         =   "系统数据库设置"
         Height          =   1215
         Left            =   120
         TabIndex        =   3
         Top             =   600
         Width           =   4215
         Begin VB.TextBox txtDatebase 
            Height          =   270
            Left            =   1560
            TabIndex        =   5
            Top             =   720
            Width           =   2415
         End
         Begin VB.TextBox txtServer 
            Height          =   270
            Left            =   1560
            TabIndex        =   4
            Top             =   360
            Width           =   2415
         End
         Begin VB.Label lblInfo 
            Caption         =   "数据库服务器："
            Height          =   255
            Index           =   0
            Left            =   120
            TabIndex        =   7
            Top             =   375
            Width           =   1575
         End
         Begin VB.Label lblInfo 
            Caption         =   "系统数据库："
            Height          =   255
            Index           =   1
            Left            =   120
            TabIndex        =   6
            Top             =   735
            Width           =   1575
         End
      End
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "关闭(&C)"
      Height          =   375
      Left            =   3600
      TabIndex        =   1
      Top             =   2280
      Width           =   975
   End
   Begin VB.CommandButton cmdApply 
      Caption         =   "应用(&A)"
      Height          =   375
      Left            =   2640
      TabIndex        =   0
      Top             =   2280
      Width           =   975
   End
End
Attribute VB_Name = "frmSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Const g_strREG_SERVER_KEY = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyQueue\1.21\Server"

Dim m_tagErrInfo                As TYPE_ERRORINFO      ' 错误信息

Private Sub cmdApply_Click()
    On Error GoTo ERROR_EXIT
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String
    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
    
    '写INI文件
    sWriteINI sINIFile, "Settings", "ServerName", txtServer.Text
    sWriteINI sINIFile, "Settings", "ServerPort", txtPort.Text
    sWriteINI sINIFile, "Settings", "DBName", txtDatebase.Text
    sWriteINI sINIFile, "Settings", "DBSource", txtServer.Text
    
    MsgBox "服务端系统配置已更改,系统下次启动时生效。", vbOKOnly, "系统提示"
    
    Unload Me
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmSet"
    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 cmdQuit_Click()
    On Error Resume Next
    Unload Me
End Sub

Private Sub Form_Load()
    On Error GoTo ERROR_EXIT
    Dim sINIFile As String, sNextFile As String
    Dim Subkey As String
    Dim r As clsRegistry
    
    Set r = New clsRegistry
    
    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, "Settings", "ServerName", "")
    txtPort.Text = Format(sGetINI(sINIFile, "Settings", "ServerPort", "0"), "00000")
    txtDatebase.Text = sGetINI(sINIFile, "Settings", "DBName", "")
    txtClient.Text = CStr(server_max_clients)
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmSet"
    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 frmSet = Nothing
End Sub

Private Sub txtClient_GotFocus()
    On Error Resume Next
    txtClient.BackColor = &H80000018
End Sub

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

Private Sub txtClient_LostFocus()
    On Error Resume Next
    txtClient.BackColor = &H80000005
End Sub

Private Sub txtDatebase_GotFocus()
    On Error Resume Next
    txtDatebase.BackColor = &H80000018
End Sub

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

Private Sub txtDatebase_LostFocus()
    On Error Resume Next
    txtDatebase.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 Trim$(txtDatebase.Text) = "" Then
        MsgBox "请输入正确的数据库名称！", vbOKOnly + vbCritical, "系统错误"
        txtServer.SetFocus
        CheckInfo = False
        Exit Function
    End If
    
    CheckInfo = True
End Function