const.bas

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

Attribute VB_Name = "Const"
Option Explicit
'声明变量
Public Conn As New ADODB.Connection '声明并创建ADO Connection对象
Public CurLoginUserNo As String     '保存当前登录的用户编号
Public CurLoginUserName As String   '保存当前登录的用户名称
Public ModifyFlag As Integer        '修改状态标志：1－修改记录，0－增加记录

'启动对象
Sub Main()
  On Error GoTo ErrorHandle
   
  '防止多次运行同一个程序
  If App.PrevInstance Then
    MsgBox "程序已运行", vbExclamation + vbOKOnly, "操作提示"
    End
  End If

  '设置使用客户端游标
  Conn.CursorLocation = adUseClient
  '设置连接字符串ConnectionString属性
  Conn.ConnectionString = "Provider=SQLOLEDB.1; " & _
                          "Data Source=jl; Initial Catalog=ClassManage; " & _
                          "User ID=sa; Password=123456"
  Conn.Open     '打开到数据库的连接
  FrmLogin.Show   '调用登录窗体

  On Error GoTo 0   '取消错误捕获
  Exit Sub
  
ErrorHandle:
  '判断连接的状态
  If Conn.State <> adStateOpen Then
    '如果连接不成功，则显示提示信息，退出程序
    MsgBox "数据库连接失败", vbExclamation + vbOKOnly, "操作提示"
  Else
    MsgBox Error(Err.Number), vbExclamation + vbOKOnly, "操作提示"
  End If
  End
End Sub


'在TreeView1控件中的TmpKey节点下加入该节点的所有下级数据
Public Sub Add_ClassToTree(TreeView1 As TreeView, ByVal TmpKey As String)
  Dim sID As String       '节点内码
  Dim TmpNode As Node           '定义节点对象
  Dim CurKey As String          '当前处理节点的关键字（直接下级的关键字）
  Dim strSql As String
  Dim rs1 As New ADODB.Recordset    'TmpKey的所有下一级班级或院系记录集
  Dim rs2 As New ADODB.Recordset    '判断用

  '从TmpKey关键字中读取当前班级或院系的内码，并赋值给sID
  sID = Right(TmpKey, Len(TmpKey) - 1)
  '查询Classes表，获得当前班级或院系的下一级数据
  strSql = "select ClassID,ClassName from Classes " & _
           "where UpperID='" & sID & "' order by ClassName"
  rs1.Open strSql, Conn, adOpenStatic, adLockReadOnly
  '循环遍历处理当前班级或院系的所有下级数据
  Do Until rs1.EOF
    '如果rs2对象已打开，则先关闭
    If rs2.State = adStateOpen Then rs2.Close
    '生成下级节点对应的关键字，格式为：字母"a"+ 内码
    CurKey = "a" & rs1!ClassID
    '判断该下级节点下是否还有下一级数据
    strSql = "select count(*) as s_count from Classes " & _
             "where UpperID='" & rs1!ClassID & "'"
    rs2.Open strSql, Conn, adOpenStatic, adLockReadOnly
    If rs2!s_count > 0 Then
      '如果有下一级数据，则把该下级节点CurKey加入到树中，并显示为文件夹图标，
      '同时，以该下级节点为参数递归调用
      Set TmpNode = TreeView1.Nodes.Add(TmpKey, tvwChild, CurKey, rs1!ClassName, _
                                                          "imgClosedFolder")
      TmpNode.ExpandedImage = "imgOpenedFolder"
      Call Add_ClassToTree(TreeView1, CurKey)
    Else
      '如果没有下一级数据，则仅需把该下级节点CurKey加入到树中，
      '并显示为叶节点图标
      Set TmpNode = TreeView1.Nodes.Add(TmpKey, tvwChild, CurKey, rs1!ClassName, _
                                    "imgDeselectedFile", "imgSelectedFile")
    End If
    rs2.Close
    Set rs2 = Nothing
    
    rs1.MoveNext
  Loop
  rs1.Close
  Set rs1 = Nothing
End Sub

'生成20个数字字符的字符串形式的（随机）内码
Public Function GetRndCode() As String
    Dim ss1 As String
    Dim ss2 As String
    
    '以当前的系统日期时间，产生14个数字的字符串（随机）
    ss1 = Format(Now, "yyyymmddhhMMss")
    '产生6位随机数的字符串
    Randomize
    ss2 = CStr(Int((999999 - 100000 + 1) * Rnd + 100000))
    
    '合并形成字符串形式内码
    GetRndCode = ss1 & ss2
End Function

'把数据库中Image字段中的内容取出并形成一个文件
Public Sub GetImage(ImageFile As String, _
           Rs As ADODB.Recordset, ByVal ImageField As String)
  Dim BlockSize As Long
  Dim TempFile As String
  Dim FieldSize  As Long
  Dim NumBlocks As Long         '定义数据块个数
  Dim LeftOver As Long          '定义剩余字节长度
  Dim SourceFile As Long        '定义自由文件号
  Dim byteChunk() As Byte
  Dim i As Long                 '定义循环变量

  BlockSize = 100
  FieldSize = Rs.Fields(ImageField).ActualSize
  If FieldSize <= 0 Then
    Exit Sub
  End If
  '提供一个尚未使用的文件号
  SourceFile = FreeFile
  '打开文件
  Open ImageFile For Binary Access Write As SourceFile
  '计算数据块
  NumBlocks = FieldSize \ BlockSize
  LeftOver = FieldSize Mod BlockSize    '得到剩余字节数
  '分块读取数据，并写入到文件中
  If LeftOver <> 0 Then
    ReDim byteChunk(LeftOver)
    byteChunk() = Rs.Fields(ImageField).GetChunk(LeftOver)
    Put SourceFile, , byteChunk()
  End If
  For i = 1 To NumBlocks
    ReDim byteChunk(BlockSize)
    byteChunk() = Rs.Fields(ImageField).GetChunk(BlockSize)
    Put SourceFile, , byteChunk()
  Next i
  Close SourceFile              '关闭文件
End Sub

'把文件保存到数据库中的Image字段中
Public Sub SaveImage(ByVal ImageFile As String, _
           Rs As ADODB.Recordset, ByVal ImageField As String)
  Dim BlockSize As Long
  Dim FileLength As Long        '标识文件长度
  Dim byteData() As Byte        '定义数据块数组
  Dim NumBlocks As Long         '定义数据块个数
  Dim LeftOver As Long          '定义剩余字节长度
  Dim SourceFile As Long        '定义自由文件号
  Dim i As Long                 '定义循环变量

  BlockSize = 100
  '提供一个尚未使用的文件号
  SourceFile = FreeFile
  '打开文件
  Open ImageFile For Binary Access Read As SourceFile
  '得到文件长度
  FileLength = LOF(SourceFile)
  '判断文件是否存在
  If FileLength = 0 Then
    Close SourceFile
    MsgBox ImageFile & "无内容或不存在!", vbExclamation + vbOKOnly, "操作提示"
  Else
    NumBlocks = FileLength \ BlockSize      '得到数据块的个数
    LeftOver = FileLength Mod BlockSize     '得到剩余字节数
    Rs.Fields(ImageField).Value = Null
    ReDim byteData(BlockSize)         '重新定义数据块的大小
    For i = 1 To NumBlocks
      Get SourceFile, , byteData()        '读到内存块中
      Rs.Fields(ImageField).AppendChunk byteData()    '写入字段中
    Next i
    ReDim byteData(LeftOver)          '重新定义数据块的大小
    Get SourceFile, , byteData()          '读到内存块中
    Rs.Fields(ImageField).AppendChunk byteData()    '写入字段中
    Close SourceFile              '关闭源文件
    Rs.Update               '更新记录集
  End If
End Sub

'把ADO记录集中的数据导出为一个Excel文件，
'注意：要使用该项功能，本机中必须安装Excel 2000或以上版本，
'然后再在程序中引用"Microsoft Excel 9.0 Object Library"，
'如果本机安装的是Excel 2003，则引用的是"Microsoft Excel 11.0 Object Library"。
Public Sub ExportToExcel(RsData As ADODB.Recordset, FileNameSaveAs As String)
  Dim iRowCount As Integer
  Dim iColCount As Integer
  Dim xlApp As New Excel.Application  'Excel应用程序对象
  Dim xlBook As Excel.Workbook    'Excel工作薄对象
  Dim xlSheet As Excel.Worksheet    'Excel工作表（页）对象
  Dim xlQuery As Excel.QueryTable   'Excel查询表对象

  iRowCount = RsData.RecordCount    '记录总数（行数）
  iColCount = RsData.Fields.Count   '字段总数（列数）

  '创建对象
  Set xlApp = CreateObject("Excel.Application")
  xlApp.Visible = False
  Set xlBook = xlApp.Workbooks().Add
  Set xlSheet = xlBook.Worksheets("sheet1")

  '工作表查询表对象加入数据（记录集）
  Set xlQuery = xlSheet.QueryTables.Add(RsData, xlSheet.Range("A1"))
  xlQuery.FieldNames = True         '显示字段名
  xlQuery.Refresh
  '设置格式
  With xlSheet
    '设置标题为黑体字
    .Range(.Cells(1, 1), .Cells(1, iColCount)).Font.Name = "黑体"
    '标题字体加粗
    .Range(.Cells(1, 1), .Cells(1, iColCount)).Font.Bold = True
    '设置标题水平居中对齐
    .Range(.Cells(1, 1), .Cells(1, iColCount)).HorizontalAlignment = xlHAlignCenter
    '设置标题垂直居中对齐
    .Range(.Cells(1, 1), .Cells(1, iColCount)).VerticalAlignment = xlVAlignCenter
    '设置表格边框样式
    .Range(.Cells(1, 1), .Cells(iRowCount + 1, iColCount)).Borders.LineStyle = xlContinuous
  End With

  '保存工作薄，Excel应用程序对象退出
  xlApp.Application.Visible = False
  xlBook.SaveAs (FileNameSaveAs)
  xlApp.Quit
  
  '释放对象
  Set xlApp = Nothing       '交还控制给Excel
  Set xlBook = Nothing
  Set xlSheet = Nothing
End Sub