frmarchivesupdate.frm

适用一般于毕业设计！ VB代码源加SQL 数据库 ··

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form FrmArchivesUpdate 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "编辑档案"
   ClientHeight    =   5850
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   8325
   Icon            =   "FrmArchivesUpdate.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5850
   ScaleWidth      =   8325
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.Frame Frame1 
      Height          =   5655
      Left            =   120
      TabIndex        =   3
      Top             =   60
      Width           =   6555
      Begin VB.TextBox txtArcNo 
         Height          =   375
         Left            =   1200
         TabIndex        =   0
         Text            =   "ArcNo"
         Top             =   300
         Width           =   2835
      End
      Begin VB.TextBox txtArcName 
         Height          =   375
         Left            =   1200
         TabIndex        =   7
         Text            =   "ArcName"
         Top             =   780
         Width           =   5115
      End
      Begin VB.TextBox txtKeyword 
         Height          =   375
         Left            =   1200
         TabIndex        =   6
         Text            =   "Keyword"
         Top             =   1260
         Width           =   5115
      End
      Begin VB.TextBox txtContent 
         Height          =   2235
         Left            =   1200
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   5
         Text            =   "FrmArchivesUpdate.frx":06EA
         Top             =   2220
         Width           =   5115
      End
      Begin VB.TextBox txtMemo 
         Height          =   855
         Left            =   1200
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   4
         Text            =   "FrmArchivesUpdate.frx":06F4
         Top             =   4560
         Width           =   5115
      End
      Begin MSComCtl2.DTPicker DtDate 
         Height          =   375
         Left            =   1200
         TabIndex        =   14
         Top             =   1740
         Width           =   1755
         _ExtentX        =   3096
         _ExtentY        =   661
         _Version        =   393216
         CheckBox        =   -1  'True
         Format          =   56426497
         CurrentDate     =   2
         MaxDate         =   109939
         MinDate         =   2
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "档案名称"
         Height          =   180
         Left            =   300
         TabIndex        =   13
         Top             =   900
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "档案编号"
         Height          =   180
         Left            =   300
         TabIndex        =   12
         Top             =   420
         Width           =   720
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "关 键 字"
         Height          =   180
         Left            =   300
         TabIndex        =   11
         Top             =   1380
         Width           =   720
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         Caption         =   "主要内容"
         Height          =   180
         Left            =   300
         TabIndex        =   10
         Top             =   2340
         Width           =   720
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   "制定日期"
         Height          =   180
         Left            =   300
         TabIndex        =   9
         Top             =   1860
         Width           =   720
      End
      Begin VB.Label Label6 
         AutoSize        =   -1  'True
         Caption         =   "备    注"
         Height          =   180
         Left            =   300
         TabIndex        =   8
         Top             =   4680
         Width           =   720
      End
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定"
      Height          =   400
      Left            =   6900
      TabIndex        =   1
      Top             =   600
      Width           =   1245
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消"
      Height          =   400
      Left            =   6900
      TabIndex        =   2
      Top             =   1260
      Width           =   1245
   End
End
Attribute VB_Name = "FrmArchivesUpdate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Update_Data(Rs As ADODB.Recordset, _
                        ClassID As String, ByVal mFlag As Integer)
  '参数Rs：班级档案记录集
  '参数ClassID：档案所在班级内码
  '参数mFlag：插入/修改标志，0-新增；1-修改
  If mFlag = 0 Then
    Rs.AddNew
    Rs!ID = GetRndCode                                '生成新的档案内码
    Rs!ClassID = ClassID                              '班级内码
  End If
  Rs!ArcNo = txtArcNo.Text                            '档案编号
  Rs!ArcName = txtArcName.Text                        '档案名称
  Rs!Keyword = txtKeyword.Text                        '关键字
  If IsDate(DtDate.Value) Then                          '制定日期
    Rs!ArcDate = Format(DtDate.Value, "yyyy-mm-dd")
  Else
    Rs!ArcDate = Null
  End If
  Rs!Content = txtContent.Text                          '主要内容
  Rs!Memo = txtMemo.Text                              '备注
  Rs.Update
End Sub

Private Sub Form_Load()
  Dim sID As String
  Dim strSql As String
  Dim Rs As New ADODB.Recordset
  
  If ModifyFlag = 0 Then      '添加记录，需要清空各控件中的内容
    txtArcNo.Text = ""
    txtArcName.Text = ""
    txtKeyword.Text = ""
    DtDate.Value = Null
    txtContent.Text = ""
    txtMemo.Text = ""
  Else                        '修改记录，在控件中填充内容
    '获取当前档案的内码
    sID = Right(FrmArchives.ListView1.SelectedItem.Key, _
                Len(FrmArchives.ListView1.SelectedItem.Key) - 1)
    '查询该档案的详细信息
    strSql = "select ID,ArcNo,ArcName,Keyword,ArcDate,Content,Memo " & _
             "from Archives where ID='" & sID & "'"
    Rs.Open strSql, Conn, adOpenStatic, adLockReadOnly
    txtArcNo.Text = Rs!ArcNo
    txtArcName.Text = Rs!ArcName
    txtKeyword.Text = IIf(IsNull(Rs!Keyword), "", Rs!Keyword)
    DtDate.Value = IIf(IsDate(Rs!ArcDate), Rs!ArcDate, Null)
    txtContent.Text = IIf(IsNull(Rs!Content), "", Rs!Content)
    txtMemo.Text = IIf(IsNull(Rs!Memo), "", Rs!Memo)
    Rs.Close
    Set Rs = Nothing
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set FrmArchivesUpdate = Nothing
End Sub

Private Sub cmdOk_Click()
  On Error GoTo ErrorHandle
  Dim sID As String
  Dim sClassID As String
  Dim strSql As String
  Dim Rs As New ADODB.Recordset
  Dim itmX As ListItem
  Dim Tmp_Key As String

  If Trim(txtArcNo.Text) = "" Then
    MsgBox "请输入档案编号", vbExclamation + vbOKOnly, "操作提示"
    txtArcNo.SetFocus
    Exit Sub
  End If
  If Trim(txtArcName.Text) = "" Then
    MsgBox "请输入档案名称", vbExclamation + vbOKOnly, "操作提示"
    txtArcName.SetFocus
    Exit Sub
  End If

  '获取当前班级内码
  sClassID = Right(FrmArchives.TreeView1.SelectedItem.Key, _
                   Len(FrmArchives.TreeView1.SelectedItem.Key) - 1)
  If ModifyFlag = 0 Then      '添加记录
    '判断编号是否重复（新增档案的编号应该与现有档案的编号不重复）
    strSql = "select count(*) as s_count from Archives " & _
             "where ArcNo='" & txtArcNo.Text & "'"
    Rs.Open strSql, Conn, adOpenStatic, adLockReadOnly
    If Rs!s_count > 0 Then    '编号已经存在，要求重新输入
      MsgBox "档案编号 " & txtArcNo.Text & " 已经存在", _
              vbExclamation + vbOKOnly, "操作提示"
      txtArcNo.SetFocus
      Rs.Close
      Set Rs = Nothing
      Exit Sub
    End If

    '如果Rs对象已打开，则先关闭
    If Rs.State = adStateOpen Then Rs.Close
    '编号不重复，正式添加记录，打开班级档案记录集（空记录集）
    strSql = "SELECT top 0 * FROM Archives"
    Rs.Open strSql, Conn, adOpenStatic, adLockOptimistic
    '调用Update_Data过程，添加班级档案
    Call Update_Data(Rs, sClassID, ModifyFlag)
    sID = Rs!ID   '获取所添加档案的内码
    
    '添加该档案到FrmArchives窗体中ListView控件上，并使该档案处于选中状态
    Tmp_Key = "b" & sID   '生成ListView节点关键字，格式：字母"b"+学生内码
    '加入档案编号
    Set itmX = FrmArchives.ListView1.ListItems.Add(, Tmp_Key, txtArcNo.Text)
    itmX.SubItems(1) = txtArcName.Text    '加入档案名称
    itmX.Selected = True          '选中所添加的项
  Else                        '修改记录
    '如果修改了档案编号，则需判断编号是否重复（未改编号，则不必判断）
    If UCase(txtArcNo.Text) <> UCase(FrmArchives.txtArcNo.Text) Then
      strSql = "select count(*) as s_count from Archives " & _
               "where ArcNo='" & txtArcNo.Text & "'"
      Rs.Open strSql, Conn, adOpenStatic, adLockReadOnly
      If Rs!s_count > 0 Then    '编号已经存在，要求重新输入
        MsgBox "档案编号 " & txtArcNo.Text & " 已经存在", _
                vbExclamation + vbOKOnly, "操作提示"
        txtArcNo.SetFocus
        Rs.Close
        Set Rs = Nothing
        Exit Sub
      End If
    End If
  
    '正式修改记录
    '获取修改档案的内码
    sID = Right(FrmArchives.ListView1.SelectedItem.Key, _
                Len(FrmArchives.ListView1.SelectedItem.Key) - 1)
    '如果Rs对象已打开，则先关闭
    If Rs.State = adStateOpen Then Rs.Close
    '查询获取要修改档案的记录集（仅一条记录）
    strSql = "SELECT * FROM Archives WHERE ID='" & sID & "'"
    Rs.Open strSql, Conn, adOpenStatic, adLockOptimistic
    If Not Rs.EOF Then
      '调用Update_Data过程，修改班级档案
      Call Update_Data(Rs, sClassID, ModifyFlag)
    End If
    
    '修改该档案在FrmArchives窗体中ListView控件上的显示信息
    FrmArchives.ListView1.SelectedItem.Text = txtArcNo.Text
    FrmArchives.ListView1.SelectedItem.SubItems(1) = txtArcName.Text
  End If
  Rs.Close
  Set Rs = Nothing

  '根据档案内码显示其详细信息（刷新显示）
  Call FrmArchives.ShowArcDetail(sID)

  Unload Me
  
  On Error GoTo 0
  Exit Sub
  
ErrorHandle:
  MsgBox Error(Err.Number), vbExclamation + vbOKOnly, "操作提示"
End Sub

Private Sub cmdCancel_Click()
  Unload Me
End Sub