frmserverchange.frm

客户关系管理系统(打包+源程序)是数据库系统开发项目方案精解系列丛书VB数据库管理中附带CD中的程序

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmServerChange 
   Caption         =   "问题记录更改"
   ClientHeight    =   6180
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6915
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   6180
   ScaleWidth      =   6915
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton cmdClear 
      Caption         =   "清理界面"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   2760
      TabIndex        =   17
      Top             =   5520
      Width           =   1215
   End
   Begin VB.Frame Frame1 
      Caption         =   "问题提交者"
      Height          =   1455
      Left            =   3480
      TabIndex        =   7
      Top             =   240
      Width           =   3135
      Begin VB.OptionButton Option2 
         Caption         =   "客户   C"
         Enabled         =   0   'False
         Height          =   255
         Left            =   240
         TabIndex        =   11
         Top             =   878
         Width           =   1095
      End
      Begin VB.TextBox Text2 
         BackColor       =   &H80000013&
         Enabled         =   0   'False
         Height          =   330
         Left            =   1320
         TabIndex        =   10
         Top             =   840
         Width           =   1575
      End
      Begin VB.OptionButton Option1 
         Caption         =   "供应商 S"
         Enabled         =   0   'False
         Height          =   255
         Left            =   240
         TabIndex        =   9
         Top             =   398
         Value           =   -1  'True
         Width           =   1095
      End
      Begin VB.TextBox Text1 
         BackColor       =   &H80000013&
         Enabled         =   0   'False
         Height          =   330
         Left            =   1320
         TabIndex        =   8
         Top             =   360
         Width           =   1575
      End
   End
   Begin VB.TextBox txtQuestID 
      Height          =   330
      Left            =   1560
      TabIndex        =   6
      Top             =   315
      Width           =   1575
   End
   Begin VB.TextBox txtDescription 
      Enabled         =   0   'False
      Height          =   1170
      Left            =   360
      TabIndex        =   5
      Top             =   2280
      Width           =   6255
   End
   Begin VB.TextBox txtViaperson 
      Enabled         =   0   'False
      Height          =   330
      Left            =   1560
      TabIndex        =   4
      Top             =   1275
      Width           =   1575
   End
   Begin VB.TextBox txtSolution 
      Enabled         =   0   'False
      Height          =   1170
      Left            =   360
      TabIndex        =   3
      Top             =   4080
      Width           =   6255
   End
   Begin VB.CommandButton Command1 
      Caption         =   "更新"
      Default         =   -1  'True
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   1080
      TabIndex        =   1
      Top             =   5520
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "取消"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   4440
      TabIndex        =   0
      Top             =   5520
      Width           =   1215
   End
   Begin MSComCtl2.DTPicker DT_QuestDate 
      Height          =   330
      Left            =   1560
      TabIndex        =   2
      Top             =   795
      Width           =   1575
      _ExtentX        =   2778
      _ExtentY        =   582
      _Version        =   393216
      Enabled         =   0   'False
      Format          =   27000832
      CurrentDate     =   38015
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "问题信息单号"
      Height          =   255
      Left            =   240
      TabIndex        =   16
      Top             =   360
      Width           =   1215
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "问题提交时间"
      Height          =   255
      Left            =   240
      TabIndex        =   15
      Top             =   840
      Width           =   1215
   End
   Begin VB.Label Label3 
      Alignment       =   1  'Right Justify
      Caption         =   "经办人"
      Height          =   255
      Left            =   720
      TabIndex        =   14
      Top             =   1320
      Width           =   735
   End
   Begin VB.Label Label4 
      Alignment       =   1  'Right Justify
      Caption         =   "问题（现状）描述"
      Height          =   255
      Left            =   240
      TabIndex        =   13
      Top             =   2040
      Width           =   1575
   End
   Begin VB.Label Label5 
      Alignment       =   1  'Right Justify
      Caption         =   "解决方案描述（可预留空）"
      Height          =   255
      Left            =   240
      TabIndex        =   12
      Top             =   3840
      Width           =   2295
   End
End
Attribute VB_Name = "frmServerChange"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
    Private blCommand1 As Boolean '判断是否开始更新，false：command1控件为“更新”，true：“完成”
    
Private Sub cmdClear_Click()
    Initial_Change
End Sub

Private Sub Command1_Click()
    Dim Rst As New ADODB.Recordset
    Dim strSQL As String
    
On Error GoTo ErrorExit
    If blCommand1 = False Then  '当前command1控件的名字是“更新”，接下来使用者将要填写新数据
        If Me.txtQuestID = "" Then      '判断问题信息单号不为空
            MsgBox "问题信息单号不能为空！"
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        If IsNumeric(Me.txtQuestID) = False Then    '判断单号为数字
            MsgBox "问题信息单号必须为数字！"
            Me.txtQuestID = ""
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        If Len(Me.txtQuestID) <> 8 Then     '判断单号位数为8
            MsgBox "问题信息单号必须8位！"
            Me.txtQuestID = ""
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        strSQL = "select * from tb_Quest where QuestID =" & Me.txtQuestID
        Rst.Open strSQL, CnnDatabase, adOpenStatic
        If Rst.RecordCount = 0 Then         '判断问题单号不存在
            MsgBox "问题单号不存在！"
            Exit Sub
        End If
        If Rst.RecordCount > 1 Then         '判断问题单号在数据库中有重复
            MsgBox "问题单号重复！", , "数据库错误！"
            Exit Sub
        End If
        Me.txtQuestID = Rst!QuestID         '将查到的旧记录写入界面控件中
        Me.DT_QuestDate.Value = Rst!questdate
        Me.txtViaperson = Rst!Viaperson
        Me.txtDescription = Rst!Description
        Me.txtSolution = Rst!solution
        If Left(Rst!questperson, 1) = "S" Then
            Me.Option1.Value = True
            Me.Text1 = Mid(Rst!questperson, 2, Len(Rst!questperson) - 1)
            Me.Text2 = ""
            Me.Text1.BackColor = &H80000005 '供应商代码栏背景为白色
            Me.Text2.BackColor = &H80000013 '客户代码栏为灰色
            Me.Text1.Enabled = True         '供应商代码栏可用
            Me.Text2.Enabled = False
        Else
            Me.Text1 = ""
            Me.Option2.Value = True
            Me.Text2 = Mid(Rst!questperson, 2, Len(Rst!questperson) - 1)
            Me.Text2.BackColor = &H80000005 '客户代码栏背景为白色
            Me.Text1.BackColor = &H80000013 '供应商代码栏为灰色
            Me.Text2.Enabled = True         '客户代码栏可用
            Me.Text1.Enabled = False
       End If
        Rst.Close
        blIsFalse               '调用私有函数进行界面变更
        Exit Sub
    Else                        '当前command1的名字是“完成”，接下来保存新数据、清理界面
        If Me.txtQuestID = "" Then      '判断问题信息单号不为空
            MsgBox "问题信息单号不能为空！"
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        If IsNumeric(Me.txtQuestID) = False Then    '判断单号为数字
            MsgBox "问题信息单号必须为数字！"
            Me.txtQuestID = ""
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        If Len(Me.txtQuestID) <> 8 Then     '判断单号位数为8
            MsgBox "问题信息单号必须8位！"
            Me.txtQuestID = ""
            Me.txtQuestID.SetFocus
            Exit Sub
        End If
        If Me.txtViaperson = "" Then        '判断经办人不留空
            MsgBox "经办人栏不得留空！"
            Me.txtViaperson.SetFocus
            Exit Sub
        End If
        If Me.txtDescription = "" Then      '判断问题描述不留空
            MsgBox "请填写问题描述。"
            Me.txtDescription.SetFocus
            Exit Sub
        End If
        If Me.Option1.Value = True Then     '如果当前问题提交者是供应商
            strSQL = "select * from tb_Supplier where SuppID = 'S" & Me.Text1 & "'"
            Rst.Open strSQL, CnnDatabase, adOpenStatic
            If Rst.RecordCount > 1 Then     '供应商代码不唯一
                MsgBox "此供应商代码在供应商信息数据表中不唯一！", vbCritical, "数据库错误！"
                Rst.Close
                Exit Sub
            End If
            If Rst.RecordCount = 0 Then     '供应商代码不存在
                MsgBox "无此供应商代码！", vbCritical, "供应商代码错误"
                Rst.Close
                Exit Sub
            End If
            Rst.Close
        Else                               '当前问题提交者是客户
            strSQL = "select * from tb_Customer where CustID = 'C" & Me.Text2 & "'"
            Rst.Open strSQL, CnnDatabase, adOpenStatic
            If Rst.RecordCount > 1 Then     '客户代码不唯一
                MsgBox "此客户代码在客户信息数据表中不唯一！", vbCritical, "数据库错误！"
                Rst.Close
                Exit Sub
            End If
            If Rst.RecordCount = 0 Then     '客户代码不存在
                MsgBox "无此客户代码！", vbCritical, "客户代码错误"
                Rst.Close
                Exit Sub
            End If
            Rst.Close
        End If
        strSQL = "select * from tb_Quest where QuestID =" & Me.txtQuestID
        Rst.Open strSQL, CnnDatabase, adOpenDynamic, adLockOptimistic
        Rst!QuestID = Me.txtQuestID       '开始更新记录
        Rst!questdate = Me.DT_QuestDate
        Rst!Viaperson = Me.txtViaperson
        If Me.Option1.Value = True Then   '当前问题提交者是供应商
            Rst!questperson = "S" & Me.Text1
        Else                              '当前问题提交者是客户
            Rst!questperson = "C" & Me.Text2
        End If
        Rst!Description = Me.txtDescription
        Rst!solution = Me.txtSolution
        Rst.Update     '更新记录结束
        MsgBox "更新问题记录提交成功！", vbInformation, "信息更改完成-"
        Initial_Change    '重新初始化界面
    End If
    Exit Sub
    
ErrorExit:
    MsgBox Err.Description, vbCritical, Me.Caption
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub Initial_Change()
    Me.txtQuestID = ""      '清空界面
    Me.txtViaperson = ""
    Me.txtDescription = ""
    Me.txtSolution = ""
    Me.DT_QuestDate.Value = Date    '初始今天日期
    Me.Option1.Value = True         '默认提交者是供应商
    Me.Option2.Value = False
    Me.Text1.BackColor = &H80000013 '供应商代码栏背景为灰色
    Me.Text2.BackColor = &H80000013 '客户代码栏为灰色
    Me.Text1 = ""
    Me.Text2 = ""
    Command1.Caption = "更新"       '按钮名称
    Me.DT_QuestDate.Enabled = False '控件不可用
    Me.txtViaperson.Enabled = False
    Me.Option1.Enabled = False
    Me.Option2.Enabled = False
    Me.Text1.Enabled = False        '供应商代码栏不可用
    Me.Text2.Enabled = False
    Me.txtDescription.Enabled = False
    Me.txtSolution.Enabled = False
    Me.txtQuestID.Enabled = True
    blCommand1 = False              '更改标志
End Sub

Private Sub Form_Load()
    Initial_Change
End Sub

Private Sub Option1_Click()
    Me.Text1.Enabled = True         '供应商代码栏可用
    Me.Text2.Enabled = False
    Me.Text1.BackColor = &H80000005 '供应商代码栏背景为白色
    Me.Text2.BackColor = &H80000013 '客户代码栏为灰色
    Me.Text1 = ""
    Me.Text2 = ""

End Sub

Private Sub Option2_Click()
    Me.Text1.Enabled = False        '供应商代码栏不可用
    Me.Text2.Enabled = True         '客户代码栏可用
    Me.Text1.BackColor = &H80000013 '供应商代码栏背景为灰色
    Me.Text2.BackColor = &H80000005 '客户代码栏背景为白色
    Me.Text1 = ""
    Me.Text2 = ""

End Sub

Private Sub blIsFalse()
    Command1.Caption = "完成"       '设置控件caption
    Me.DT_QuestDate.Enabled = True  '设置控件可用性
    Me.txtViaperson.Enabled = True
    Me.Option1.Enabled = True
    Me.Option2.Enabled = True
    Me.txtDescription.Enabled = True
    Me.txtSolution.Enabled = True
    Me.txtQuestID.Enabled = False
    blCommand1 = True       '更改标志
End Sub