dlgflackset.frm

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

VERSION 5.00
Begin VB.Form dlgFlackSet 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "宣传用语参数设置"
   ClientHeight    =   4065
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4560
   Icon            =   "dlgFlackSet.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4065
   ScaleWidth      =   4560
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  '所有者中心
   Begin VB.ComboBox cboObject 
      Height          =   300
      ItemData        =   "dlgFlackSet.frx":0CCA
      Left            =   1320
      List            =   "dlgFlackSet.frx":0CD4
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   480
      Width           =   3015
   End
   Begin VB.Frame fra1 
      Caption         =   "显示效果"
      Height          =   1095
      Left            =   240
      TabIndex        =   12
      Top             =   1560
      Width           =   4095
      Begin VB.ComboBox cboOut 
         Height          =   300
         ItemData        =   "dlgFlackSet.frx":0CF0
         Left            =   1200
         List            =   "dlgFlackSet.frx":0D09
         Style           =   2  'Dropdown List
         TabIndex        =   4
         Top             =   640
         Width           =   2775
      End
      Begin VB.ComboBox cboIn 
         Height          =   300
         ItemData        =   "dlgFlackSet.frx":0D57
         Left            =   1200
         List            =   "dlgFlackSet.frx":0D70
         Style           =   2  'Dropdown List
         TabIndex        =   3
         Top             =   240
         Width           =   2775
      End
      Begin VB.Label lblInfo 
         Caption         =   "退出效果："
         Height          =   195
         Index           =   5
         Left            =   120
         TabIndex        =   14
         Top             =   693
         Width           =   975
      End
      Begin VB.Label lblInfo 
         Caption         =   "进入效果："
         Height          =   195
         Index           =   4
         Left            =   120
         TabIndex        =   13
         Top             =   293
         Width           =   975
      End
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   3360
      TabIndex        =   7
      Top             =   3600
      Width           =   975
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Height          =   375
      Left            =   2400
      TabIndex        =   6
      Top             =   3600
      Width           =   975
   End
   Begin VB.TextBox txtName 
      Height          =   615
      Left            =   1320
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   840
      Width           =   3015
   End
   Begin VB.TextBox txtCode 
      Enabled         =   0   'False
      Height          =   270
      Left            =   1320
      TabIndex        =   0
      Top             =   120
      Width           =   3015
   End
   Begin VB.TextBox txtNote 
      Height          =   735
      Left            =   1320
      MultiLine       =   -1  'True
      TabIndex        =   5
      Top             =   2760
      Width           =   3015
   End
   Begin VB.Label lblInfo 
      Caption         =   "备注信息："
      Height          =   195
      Index           =   3
      Left            =   240
      TabIndex        =   11
      Top             =   2760
      Width           =   975
   End
   Begin VB.Label lblInfo 
      Caption         =   "宣传用语："
      Height          =   195
      Index           =   2
      Left            =   240
      TabIndex        =   10
      Top             =   840
      Width           =   975
   End
   Begin VB.Label lblInfo 
      Caption         =   "作用对象："
      Height          =   195
      Index           =   1
      Left            =   240
      TabIndex        =   9
      Top             =   533
      Width           =   975
   End
   Begin VB.Label lblInfo 
      Caption         =   "用语编号："
      Height          =   195
      Index           =   0
      Left            =   240
      TabIndex        =   8
      Top             =   165
      Width           =   975
   End
End
Attribute VB_Name = "dlgFlackSet"
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_sCode         As String
Dim m_bChange       As Boolean
Dim m_iType         As Integer

Private Sub cboIn_GotFocus()
    On Error Resume Next
    cboIn.BackColor = &H80000018
End Sub

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

Private Sub cboIn_LostFocus()
    On Error Resume Next
    cboIn.BackColor = &H80000005
End Sub

Private Sub cboObject_GotFocus()
    On Error Resume Next
    cboObject.BackColor = &H80000018
End Sub

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

Private Sub cboObject_LostFocus()
    On Error Resume Next
    cboObject.BackColor = &H80000005
End Sub

Private Sub cboOut_GotFocus()
    On Error Resume Next
    cboOut.BackColor = &H80000018
End Sub

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

Private Sub cboOut_OLECompleteDrag(Effect As Long)
    On Error Resume Next
    cboOut.BackColor = &H80000005
End Sub

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

Private Sub cmdOK_Click()
    On Error GoTo ERROR_EXIT
    Dim iTrans As Integer
    Dim i As Integer, sData As String
    
    If Not IsNumeric(txtCode.Text) Then
        MsgBox "请输入正确的服务用语编号！", vbOKOnly, "系统提示"
        Exit Sub
    End If
    If Trim$(txtName.Text) = "" Then
        MsgBox "请输入正确的服务用语内容！", vbOKOnly, "系统提示"
        Exit Sub
    End If
    i = cboObject.ItemData(cboObject.ListIndex)
    
    sData = CStr(cboIn.ItemData(cboIn.ListIndex))
    sData = sData & vbTab
    sData = sData & CStr(cboOut.ItemData(cboOut.ListIndex))
     
    '修改数据库
    iTrans = dbMyDB.BeginTrans
    
    If m_bChange = False Then
        dbMyDB.Execute "INSERT INTO FlackDateSet([fd_type],[fd_code],[fd_name],[fd_effect],[note])" _
                & "VALUES( '" & i & "', '" & txtCode.Text & "', '" & txtName.Text & _
                "', '" & sData & "', '" & txtNote.Text & "')"
    Else
        dbMyDB.Execute "UPDATE FlackDateSet SET fd_name = '" & txtName.Text & "', fd_effect = '" & sData & "', " & _
                "note = '" & txtNote.Text & "' WHERE fd_type = '" & i & "' AND fd_code = '" & txtCode.Text & "'"
    End If
    
    If iTrans > 0 Then
        dbMyDB.CommitTrans
        iTrans = 0
    End If
    
    Unload Me
    
    Exit Sub
ERROR_EXIT:
    If iTrans > 0 Then dbMyDB.RollbackTrans
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "dlgFlackSet"
    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 rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, i As Integer
    
    m_bChange = False
    cboObject.ListIndex = 0
    cboIn.ListIndex = 0
    cboOut.ListIndex = 0
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    '查询数据库
    strSQL = "SELECT TOP 1 * FROM FlackDateSet ORDER BY fd_id DESC"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        rs.MoveFirst
        If Not IsNumeric(rs!fd_code) Then GoTo ERROR_EXIT
        i = CInt(rs!fd_code) + 1
        m_sCode = CStr(i)
    Else
        m_sCode = "1"
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "dlgFlackSet"
    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 dlgQueueSet = Nothing
End Sub

Private Sub txtCode_GotFocus()
    On Error Resume Next
    txtCode.BackColor = &H80000018
End Sub

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

Private Sub txtCode_LostFocus()
    On Error Resume Next
    txtCode.BackColor = &H80000005
End Sub

Private Sub txtNote_GotFocus()
    On Error Resume Next
    txtNote.BackColor = &H80000018
End Sub

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

Private Sub txtNote_LostFocus()
    On Error Resume Next
    txtNote.BackColor = &H80000005
End Sub

Private Sub txtName_GotFocus()
    On Error Resume Next
    txtName.BackColor = &H80000018
End Sub

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

Private Sub txtName_LostFocus()
    On Error Resume Next
    txtName.BackColor = &H80000005
End Sub

'//////////////////////////////////////////////////////////////////////////////////////////
'/设定宣传用语编号
Public Property Let FlackCode(ByVal vNewValue As String)
    On Error Resume Next
    m_sCode = vNewValue
    m_bChange = True
End Property

Public Property Let FlackType(ByVal vNewValue As Integer)
    On Error Resume Next
    m_iType = vNewValue
    m_bChange = True
End Property

'初始化对话框
Public Function InitSet() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, sData() As String
    
    If m_bChange = False Then
        txtCode.Text = m_sCode
        cboObject.Enabled = True
    Else
        '连接数据库
        cmd.ActiveConnection = dbMyDB
        cmd.CommandType = adCmdText
        
        '查询数据库
        strSQL = "SELECT  * FROM FlackDateSet WHERE fd_type = '" & m_iType & "' AND fd_code = '" & m_sCode & "'"
        cmd.CommandText = strSQL
        rs.CursorLocation = adUseClient
        rs.Open cmd, , adOpenStatic, adLockReadOnly
        If Not rs.EOF And rs.RecordCount > 0 Then
            txtCode.Text = m_sCode
            cboObject.ListIndex = m_iType
            If Not IsNull(rs!fd_name) Then txtName.Text = rs!fd_name
            If Not IsNull(rs!note) Then txtNote.Text = rs!note
            If Not IsNull(rs!fd_effect) Then
                sData = Split(rs!fd_effect, vbTab)
                cboIn.ListIndex = sData(0)
                cboOut.ListIndex = sData(1)
            End If
        Else
            GoTo ERROR_EXIT
        End If
        rs.Close
        cboObject.Enabled = False
    End If
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    InitSet = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "dlgFlackSet"
    m_tagErrInfo.strErrFunc = "InitSet"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Function