frmarchives.frm

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

      HideSelection   =   0   'False
      LabelEdit       =   1
      Style           =   7
      ImageList       =   "ImageList1"
      Appearance      =   1
   End
End
Attribute VB_Name = "FrmArchives"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub ClearArcDetail()
  txtArcNo.Text = ""        '档案编号
  txtArcName.Text = ""        '档案名称
  txtKeyword.Text = ""        '关键字
  txtDate.Text = ""         '制定日期
  txtContent.Text = ""        '主要内容
  txtMemo.Text = ""       '备注
  Lbl_Download.Visible = False    '隐藏"下载"标签
End Sub

Public Sub ShowArcDetail(sID As String)
  Dim strSql As String
  Dim Rs As New ADODB.Recordset
  
  '根据档案内码查询该档案的详细信息
  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)
  txtDate.Text = IIf(IsNull(Rs!ArcDate), "", Rs!ArcDate)
  txtContent.Text = IIf(IsNull(Rs!Content), "", Rs!Content)
  txtMemo.Text = IIf(IsNull(Rs!Memo), "", Rs!Memo)

  '如果Rs对象已打开，则先关闭
  If Rs.State = adStateOpen Then Rs.Close
  '判断该档案下是否有可下载的文件，以此决定"下载"标签是否可见
  '如果该档案doc字段（image类型）为null值的记录数为0，则存在可下载文件
  strSql = "select count(*) as s_count from Archives " & _
           "where Doc is null and ID='" & sID & "'"
  Rs.Open strSql, Conn, adOpenStatic, adLockReadOnly
  If Rs!s_count = 0 Then      '存在可下载文件，"下载"标签可见
    Lbl_Download.Visible = True
  Else              '不存在可下载文件，"下载"标签不可见
    Lbl_Download.Visible = False
  End If
  Rs.Close
  Set Rs = Nothing
End Sub

Private Sub Form_Load()
  Dim TmpNode As Node

  '加入根结点（学校）
  Set TmpNode = TreeView1.Nodes.Add(, , "a0", "长沙环境保护职业技术学院", "imgGlobalFolder")
  TmpNode.Selected = True
  TmpNode.Expanded = True
  TreeView1.LabelEdit = tvwManual
  TreeView1.HideSelection = False

  '设置ListView控件列（增加列标题，显示格式等）
  ListView1.ColumnHeaders.Add , , "档案编号", ListView1.Width / 3
  ListView1.ColumnHeaders.Add , , "档案名称", ListView1.Width * 2 / 3
  ListView1.View = lvwReport              '设置外观为报表样式
  ListView1.LabelEdit = lvwManual
  ListView1.FullRowSelect = True
  ListView1.HideSelection = False

  '调用通用函数将所有班级或院系添加到TreeView1中
  Call Add_ClassToTree(TreeView1, "a0")
  '调用TreeView1控件的点击事件
  Call TreeView1_Click

  Left = 0
  Top = 0
End Sub

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

Private Sub TreeView1_Click()
  Dim sClassID As String
  Dim strSql As String
  Dim Rs As New ADODB.Recordset
  Dim itmX As ListItem
  Dim Tmp_Key As String

  '清空ListView各项
  ListView1.ListItems.Clear
  '获取班级内码
  sClassID = Right(TreeView1.SelectedItem.Key, Len(TreeView1.SelectedItem.Key) - 1)
  '查询该班级所有档案的内码、编号和名称，以编号排序
  strSql = "SELECT ID, ArcNo, ArcName FROM Archives " & _
           "WHERE ClassId='" & sClassID & "' order by ArcNo"
  Rs.Open strSql, Conn, adOpenStatic, adLockReadOnly
  '遍历该班级所有档案，将档案数据加入ListView1中
  Do Until Rs.EOF
    '生成ListView1中当前节点的关键字
    Tmp_Key = "b" & Rs!ID
    '将档案项（关键字，编号）加入ListView1中
    Set itmX = ListView1.ListItems.Add(, Tmp_Key, Rs!ArcNo)
    '设置该项档案的名称
    itmX.SubItems(1) = Rs!ArcName
    
    Rs.MoveNext
  Loop
  Rs.Close
  Set Rs = Nothing
  
  '如果存在班级档案，选择第一个该班档案，显示其详细信息；
  '如果不存在，清空详细信息显示
  If ListView1.ListItems.Count > 0 Then
    ListView1.SelectedItem.Selected = True
    Call ListView1_Click        '调用控件ListView1的点击事件
  Else
    Call ClearArcDetail         '清空档案明细
  End If
End Sub

Private Sub ListView1_Click()
  Dim sID As String

  If ListView1.ListItems.Count > 0 Then
    '获取档案内码
    sID = Right(ListView1.SelectedItem.Key, Len(ListView1.SelectedItem.Key) - 1)
    Call ShowArcDetail(sID)           '调用过程，显示该档案的详细信息
  End If
End Sub

Private Sub Lbl_Trans_Click()
  On Error GoTo ErrorHandle
  Dim sID As String
  Dim strSql As String
  Dim Rs As New ADODB.Recordset

  If ListView1.ListItems.Count = 0 Then
    MsgBox "请先添加档案", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If

  '使用CommonDialog控件获得上传文件的文件名
  CommonDialog1.FileName = ""
  CommonDialog1.Filter = "所有Word文档(*.doc; *.dot; *.rtf)|*.doc; *.dot; *.rtf|" & _
                         "所有Excel文档(*.xls; *.xlt)|*.xls; *.xlt|" & _
                         "所有文件(*.*)|*.*"
  CommonDialog1.ShowOpen
  If CommonDialog1.FileName = "" Then
    Exit Sub
  End If
  
  '获取当前档案的内码
  sID = Right(ListView1.SelectedItem.Key, Len(ListView1.SelectedItem.Key) - 1)
  '查询获取当前档案记录集
  strSql = "SELECT ID,Doc,DocName FROM Archives WHERE ID='" & sID & "'"
  Rs.Open strSql, Conn, adOpenStatic, adLockOptimistic
  If Not Rs.EOF Then
    '调用SaveImage将文件保存到记录集的doc字段（文件->记录集的字段）
    Call SaveImage(CommonDialog1.FileName, Rs, "Doc")
    '保存文件名（不含路径）
    Rs!DocName = CommonDialog1.FileTitle
    Rs.Update   '更新记录集
  End If
  Rs.Close
  Set Rs = Nothing

  '使"下载"标签可见，并提示成功上传
  Lbl_Download.Visible = True
  MsgBox "上传成功！", vbInformation + vbOKOnly, "操作提示"

  On Error GoTo 0
  Exit Sub

ErrorHandle:
  MsgBox Error(Err.Number), vbExclamation + vbOKOnly, "操作提示"
End Sub

Private Sub Lbl_Download_Click()
  On Error GoTo ErrorHandle
  Dim sID As String
  Dim strSql As String
  Dim Rs As New ADODB.Recordset

  If ListView1.ListItems.Count = 0 Then
    MsgBox "请先添加档案", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If

  '获取当前档案的内码
  sID = Right(ListView1.SelectedItem.Key, Len(ListView1.SelectedItem.Key) - 1)
  '查询获取当前档案记录集
  strSql = "SELECT ID,Doc,DocName FROM Archives WHERE ID='" & sID & "'"
  Rs.Open strSql, Conn, adOpenStatic, adLockOptimistic
  If Not Rs.EOF Then
    If Rs.Fields("Doc").ActualSize > 0 Then   '如果Doc字段有数据
      '使用CommonDialog控件获得下载（存盘）文件名
      CommonDialog1.FileName = IIf(IsNull(Rs!DocName), "", Rs!DocName)
      CommonDialog1.Filter = "所有文件(*.*)|*.*"
      CommonDialog1.ShowSave
      If CommonDialog1.FileName = IIf(IsNull(Rs!DocName), "", Rs!DocName) Then
        Rs.Close
        Exit Sub
      End If
      
      '调用GetImage将Doc字段内容保存到文件（记录集字段->文件）
      Call GetImage(CommonDialog1.FileName, Rs, "Doc")
    End If
  End If
  Rs.Close
  Set Rs = Nothing
  MsgBox "下载成功！", vbInformation + vbOKOnly, "操作提示"

  On Error GoTo 0
  Exit Sub

ErrorHandle:
  MsgBox Error(Err.Number), vbExclamation + vbOKOnly, "操作提示"
End Sub

Private Sub cmdAdd_Click()
  ModifyFlag = 0                '以添加记录方式，打开班级档案编辑窗体
  FrmArchivesUpdate.Show 1
End Sub

Private Sub cmdEdit_Click()
  If ListView1.ListItems.Count = 0 Then
    MsgBox "没有可修改的记录", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If
  If ListView1.SelectedItem.Selected = False Then
    MsgBox "请选择要修改的记录", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If
  
  ModifyFlag = 1                '以修改记录方式，打开班级档案编辑窗体
  FrmArchivesUpdate.Show 1
End Sub

Private Sub cmdDel_Click()
  Dim sID As String
  
  If ListView1.ListItems.Count = 0 Then
    MsgBox "没有可删除的记录", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If
  If ListView1.SelectedItem.Selected = False Then
    MsgBox "请选择要删除的记录", vbExclamation + vbOKOnly, "操作提示"
    Exit Sub
  End If

  '确认删除
  If MsgBox("确实要删除当前档案吗？", vbQuestion + vbYesNo, "操作提示") = vbNo Then
    Exit Sub
  End If
  '正式删除
  '获取档案内码
  sID = Right(ListView1.SelectedItem.Key, Len(ListView1.SelectedItem.Key) - 1)
  '使用连接对象删除当前档案记录
  Conn.Execute "delete from Archives where ID='" & sID & "'"
  '把当前档案信息从控件ListView1中去除
  ListView1.ListItems.Remove ListView1.SelectedItem.Index
  
  '如果删除后还存在班级档案，选择下一个该班档案，显示其详细信息；
  '如果不存在，清空详细信息显示
  If ListView1.ListItems.Count > 0 Then
    ListView1.SelectedItem.Selected = True
    Call ListView1_Click
  Else
    Call ClearArcDetail
  End If
End Sub

Private Sub cmdClose_Click()
  Unload Me
End Sub