modbase.bas

通用书店管理系统

Attribute VB_Name = "ModBase"
Option Explicit

    Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
    Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
    Public Const HKEY_CLASSES_ROOT = &H80000000
    Public Const HKEY_CURRENT_USER = &H80000001
    Public Const HKEY_LOCAL_MACHINE = &H80000002
    Public Const HKEY_USERS = &H80000003
    Public Const HKEY_PERFORMANCE_DATA = &H80000004
    Public Const HKEY_CURRENT_CONFIG = &H80000005
    Public Const HKEY_DYN_DATA = &H80000006
    Public Const REG_SZ = 1&
'----------------------------------------------------------------------------

Public Enum ExpValidateString
  vbExpInteger
  vbExpDecimal
  vbExpChar
  vbExpDefault
  vbExpDate
End Enum

'用Connectionstring 设置与数据库的连接
Public Function SetConnect() As Boolean
    On Error GoTo err
    Dim strConnect As String
    SetConnect = False
    If cN.State <> adStateClosed Then
        cN.Close
    End If

    Call SetDBString     ' 设置与数据库的连接
'    strDBString = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';Data Source=" & App.Path & "\Database\BookShop.mdb;Persist Security Info=True;Jet OLEDB:Database Password=555"
    cN.Open strDBString
    SetConnect = True
    Exit Function
err:
    MsgBox err.Description
End Function

Public Function SetDBString()
    Dim strTemp As String * 300, strKey As String
    Dim intI As Integer
    Dim strUid As String
    Dim blnNeedWriteReg As Boolean
    
    blnNeedWriteReg = False
    If InStr(1, Command(), "mdb") = 0 Then ' 命令行参数如果有mdb则参数为数据库文件名
    
        strKey = "software\" & App.CompanyName & "\" & App.ProductName & "\DBOption"
    '    loadreg = 0
        If Registry.GetKeyValue(HKEY_LOCAL_MACHINE, strKey, "DataBase", strTemp) Then
            strTemp = Trim(strTemp)
            intI = InStr(1, strTemp, Chr(0))
            ' strDBFile和strPwd 是全局变量
            If intI > 0 Then
                strDBFile = Left(strTemp, intI - 1)
            Else
                strDBFile = Trim(strTemp)
            End If
        Else    ' lzw 2002-06-19 如果注册表没有则默认为当前目录
            blnNeedWriteReg = True
            strDBFile = App.Path & "\bookshop.mdb"
        End If
    Else
         ' lzw 2002-06-19 命令行参数等于数据库路径
        blnNeedWriteReg = True
        strDBFile = Command()
    End If
    
    If blnNeedWriteReg Then     ' 将数据库路径保存在注册表中
        Call Registry.UpdateKey(HKEY_LOCAL_MACHINE, strKey, "DataBase", strDBFile)
    End If
    
    If Registry.GetKeyValue(HKEY_LOCAL_MACHINE, strKey, "Uid", strTemp) Then
        strUid = Trim(strTemp)
    End If
    
    If Registry.GetKeyValue(HKEY_LOCAL_MACHINE, strKey, "Pwd", strTemp) Then
        strPWD = Trim(strTemp)
    Else ' lzw 2002-06-19
        strPWD = "555"
    End If

    'strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';Data Source=" & App.Path & "\Database\BookShop.mdb;Persist Security Info=True;Jet OLEDB:Database Password=555"
    strDBString = "Provider=Microsoft.Jet.OLEDB.4.0;Password='';Data Source=" & strDBFile & ";Persist Security Info=True;Jet OLEDB:Database Password=" & strPWD
End Function

' 数据库压缩
Public Sub CompactJetDatabase()
    On Error GoTo CompactErr
    Dim errN As Long
    Dim strBackupFile As String
    Dim strTempFile As String

    If MsgBox("该功能只能由系统管理员操作。" & _
        vbCrLf & "      系统运行一段时间后，可执行数据库压缩功能，以提高整个系统的效率。" & _
        vbCrLf & "      建议所有用户都退出系统后才执行该功能。" & _
        vbCrLf & vbCrLf & "      是否继续？", vbOKCancel + vbDefaultButton2, "警告：") = vbCancel Then
        Exit Sub
    End If
        
    Set cN = Nothing    ' 关闭数据库连接
    
    If Len(Dir(App.Path & "\backup", vbDirectory)) = 0 Then
        MkDir App.Path & "\backup"
        'MsgBox "数据备份目录不存在！"
        'Exit Sub
    End If
    
    '检查数据库文件是否存在
    If Len(Dir(strDBFile)) = 0 Then
        MsgBox "数据库文件不存在！"
        Exit Sub
    End If
     
     ' 执行备份

     strBackupFile = App.Path & "\backup\backup.mdb"
     If Len(Dir(strBackupFile)) Then Kill strBackupFile

     FileCopy strDBFile, strBackupFile


     ' 创建临时文件名
     strTempFile = App.Path & "\backup\" & "temp.mdb"
     If Len(Dir(strTempFile)) Then Kill strTempFile

     '通过DBEngine 压缩数据库文件

     DBEngine.CompactDatabase strDBFile, strTempFile, , , ";pwd=" & strPWD

     ' 删除原来的数据库文件

     Kill strDBFile

     ' 拷贝刚刚压缩过临时数据库文件至原来位置

     FileCopy strTempFile, strDBFile


     ' 删除临时文件

     Kill strTempFile   ' 暂时不删除 lzw remark

CompactErr:
    errN = err.Number
    If errN <> 0 Then
        If errN = 70 Then
            MsgBox "权限拒绝，可能其他人正在使用数据库，请确保数据库只有你一个人在用！"
        Else
            MsgBox errN & " " & err.Description
        End If
    End If
    
    MsgBox "以下将退出整个系统，你可以重新启动。", vbOKOnly, "警告："
    
    End
    Exit Sub

    End Sub


'-------------------------------------------------------------------------
'  捕获窗体句柄,关闭该窗体
Public Sub KillForm(strFrmName As String)
    Dim lngwinHwnd As Long
    Dim lngRetVal As Long
    lngwinHwnd = FindWindow(vbNullString, strFrmName)
    If lngwinHwnd = 0 Then
        MsgBox GetLastError()
        Exit Sub
    End If
    Call SetForegroundWindow(lngwinHwnd)
    lngRetVal = PostMessage(lngwinHwnd, WM_CLOSE, 0&, 0&)
    If lngRetVal = 0 Then
        MsgBox GetLastError()
        Exit Sub
    End If
End Sub

'功能:  捕获窗体句柄,显示该窗体

Public Function ShowMDIChildForm(strFrmName As String) As Boolean
    Dim frm As Form
    
    ShowMDIChildForm = False
    For Each frm In Forms
        If frm.Caption = strFrmName Then
            frm.Show
            frm.SetFocus
            ShowMDIChildForm = True
            Exit For
        End If
    Next frm
End Function


'--------------------------------------------------------------------------------
'功能：    限制在文本框或其它一些控件中能否输入数字或一些特定的字符

'参数说明：
'          KeyIn           输入的键值
'          DefaultString   已定义的有效字符 vbExpInteger="0123456789"
'                                        vbExpDecimal = "0123456789.+-"
'                                        vbExpChar = "abcdefghijklmnopqrstuvwxyz"
'                                        vbDefault = ""
'          ValidateString  有效的字符
'          strText         已经输入的字符串
'          IntLimit        输入字符串的总长度 IntLimit= -1 表示不限定长度
'          IsValidate      作为有效还是无效的字符 IsValidate=True 作为有效字符
'          Editable        能否使用 [Backspace] 键 Editable=True  能使用 [Backspace] 键

'返回值：  (Integer)
'          返回有效的字符值
'--------------------------------------------------------------------------------

Public Function ValiText(KeyIn As Integer, DefaultString As ExpValidateString, ValidateString As String, _
                         strText As String, Optional IntLimit = -1, _
                         Optional IsValidate = True, Optional Editable = True) As Integer
    Dim ValidateList As String
    Dim KeyOut As Integer
    
    If IntLimit <> -1 Then
        If Len(strText) > (IntLimit - 1) And KeyIn <> 8 And KeyIn <> 13 Then
           ValiText = 0
           MsgBox "输入数据已经超出定义的长度，请检查输入是否有误！！！", vbInformation
           Exit Function
        End If
    End If
    
    Select Case DefaultString
      Case vbExpInteger
           ValidateString = "0123456789" & ValidateString
      Case vbExpDecimal
           ValidateString = "0123456789.+-" & ValidateString
      Case vbExpChar
           ValidateString = "abcdefghijklmnopqrstuvwxyz" & ValidateString
      Case vbExpDate
           ValidateString = "0123456789-/." & ValidateString
      Case vbExpDefault
           ValidateString = ValidateString
    End Select
    
    '传入的字符是作为有效字符还是作为无效字符输入
    If IsValidate Then
        If Editable = True Then
           ValidateList = UCase(ValidateString) & Chr(8)
        Else
           ValidateList = UCase(ValidateString)
        End If
        If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
           KeyOut = KeyIn
        Else
           KeyOut = 0
           Beep
        End If
        ValiText = KeyOut
    Else
        If Editable = True Then
           ValidateList = UCase(ValidateString)
        Else
           ValidateList = UCase(ValidateString) & Chr(8)
        End If
        If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
           KeyOut = 0
           Beep
        Else
           KeyOut = KeyIn
        End If
        ValiText = KeyOut
    End If
    
End Function


'---------------------------------------------------------------------
' 函数名:   SeToolBar
' 功能:     设置MDIForm的工具条的状态
' 参数说明:
'---------------------------------------------------------------------
Public Function SetToolBar(strStatus As String)
    On Error GoTo err
    Dim strC As String
    Dim i As Integer
    
    For i = 1 To Len(strStatus)
        Select Case i
        Case 5, 8, 12
        Case Else
            strC = Mid(strStatus, i, 1)
            If strC = "1" Then
                frmMain.tbToolBar.Buttons(i).Enabled = True
            Else
                frmMain.tbToolBar.Buttons(i).Enabled = False
            End If
        End Select
    Next i
    Exit Function
err:
    MsgBox err.Description
End Function


'--------------------------------------------------------------------------------
'功能：    显示进度条
'参数说明：
'          intBarValue      进度条当前值
'          blnShow          显示进度条
'返回值：
'--------------------------------------------------------------------------------


Public Sub ShowBar(ByVal intBarValue As Integer, blnShow As Boolean)
        
    'Verify property settings
    On Error GoTo ErrorHandler
    
    If Not blnShow Then
       frmMain.prgBar.Value = intBarValue
       frmMain.prgBar.Visible = False
       Exit Sub
    End If
    
    '设置属性
    frmMain.prgBar.Visible = blnShow
    frmMain.prgBar.Value = intBarValue
    DoEvents
    
        
    Exit Sub
ErrorHandler: