common.bas

图书管理软件,基本功能已具备

Attribute VB_Name = "Common"
'***************************************************************
'*公司名：华夏学院晨光网络公司
'*系统名：红杉图书信息管理系统
'*模块名：主模块
'*模块ID：Common
'*
'*-------------------------------------------------------------
'*  [年月日]        [制造者]
'*-------------------------------------------------------------
'*  2005/3/18       cuitianlong
'*
'***************************************************************
Option Explicit

Public C_CNN           As New ADODB.Connection '定义连接对象
Public C_UserGroup     As Boolean              '权限  True:一般用户  Flase:非一般用户
Public C_UserName      As String               '用户名(全局变量便于窗体间传值)
Public C_LoginName     As String               '登陆用户名(记录操作员名称)
Public Const MAX_PATH = 260                    '最大系统路径长度
Public WinPath         As String               'Windows目录
Public WinSysPath      As String               'WindowsSystem目录

'---WritePrivateProfileString函数声明
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'---GetPrivateProfileString函数声明
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'---GetWindowsDirectory函数声明
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'---GetSystemDirectory函数声明
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'****************************************************************
'*  主函数
'*
'*  [参数]
'*      无
'*  [返回]
'*      无
'*  [使用示例]
'*      Main()
'****************************************************************
Sub Main()
    '---工程标题
    App.Title = Got_Apptitle
    
    C_CNN.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & Got_DBPath
    '打开数据源，确定数据库位置
    DataEnvironment1.Connection1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & Got_DBPath
    '打开数据源，进行报表连接
    RL_Logining.Show '闪屏启动
    
    '共通处理终了
End Sub

'****************************************************************
'*  窗体居中
'*
'*  [参数]
'*      窗体
'*  [返回]
'*      无
'*  [使用示例]
'*      Call Cmn_Form_Center(Me)
'****************************************************************
Public Sub Cmn_Form_Center(frm As Form)
    On Error Resume Next
    
    frm.Top = (Screen.Height - (frm.Height + Screen.Height / 30)) \ 2 '窗体垂直居中
    frm.Left = (Screen.Width - frm.Width) \ 2 '窗体水平居中
End Sub

'****************************************************************
'*  SELECT语句执行函数
'*
'*  [参数]
'*      Sql:Sql语句
'*      Rc:记录集
'*  [返回]
'*      True:成功
'*      False:失败
'*  [使用示例]
'*      RTN = Cmn_Ado_Select_Nolock(sql,rc)
'****************************************************************
Public Function Cmn_Ado_Select_Nolock(ByVal sql As String, rc As ADODB.Recordset) As Boolean
    On Error GoTo SysErr_Cmn_Ado_Select_Nolock '设置错误陷阱
    
    Cmn_Ado_Select_Nolock = False
    
    Set rc = New ADODB.Recordset '定义记录集
    If rc.State = 1 Then rc.Close '判断记录集状态，如果打开则关闭记录集
    rc.Open sql, C_CNN, adOpenKeyset, adLockReadOnly '执行SQL语句操作数据
    
    Cmn_Ado_Select_Nolock = True
    
    Exit Function
SysErr_Cmn_Ado_Select_Nolock:
    '执行函数错误时的代码
End Function

'***************************************************************
'*  INSERT、UPDATE、DELETE语句执行函数
'*
'*  [参数]
'*      sql:SQL语句
'*  [返回]
'*      True:成功
'*      False:失败
'*  [使用示例]
'*      RTN = Cmn_Ado_Execute(sql)
'***************************************************************
Public Function Cmn_Ado_Execute(ByVal sql As String) As Boolean
   On Error GoTo SysErr_Cmn_Ado_Execute '设置错误陷阱
    
    Cmn_Ado_Execute = False
    C_CNN.Execute sql '执行SQL语句操作数据
    Cmn_Ado_Execute = True
    
    Exit Function
SysErr_Cmn_Ado_Execute:
    '执行函数错误时的代码
End Function

'***************************************************************
'*  ADO连接关闭
'*
'*  [参数]
'*      记录集参数
'*  [返回]
'*      无
'*  [使用示例]
'*      Call Cmn_Ado_DisRecordset(rc)
'**************************************************************
Public Sub Cmn_Ado_DisRecordset(rc As ADODB.Recordset)
    On Error GoTo err_trap
    
    If rc.State = 1 Then
        rc.Close
        Set rc = Nothing
    End If
    
    Exit Sub
err_trap:
    '执行函数错误时的代码
End Sub

'***************************************************************
'*  文本框获得焦点
'*
'*  [参数]
'*      控件对象
'*  [返回]
'*      无
'*  [使用示例]
'*      Call Cmn_Txt_GotFocus(text)
'***************************************************************
Public Sub Cmn_Txt_GotFocus(text As Control)
    On Error GoTo Cmn_Txt_GotFocus
    
    text.BackColor = vbYellow '背景颜色设置为黄色
    Exit Sub
Cmn_Txt_GotFocus:
    MsgBox "Cmn_Txt_GotFocus()---出错", vbCritical, "错误"
End Sub

'***************************************************************
'*  文本框失去焦点
'*
'*  [参数]
'*      控件对象
'*  [返回]
'*      无
'*  [使用示例]
'*      Call Cmn_Txt_LostFocus(text)
'***************************************************************
Public Sub Cmn_Txt_LostFocus(text As Control)
    On Error GoTo Cmn_Txt_LostFocus
    
    text.BackColor = vbWhite '背景颜色设置为白色
    Exit Sub
Cmn_Txt_LostFocus:
    MsgBox "Cmn_Txt_LostFocus()---出错", vbCritical, "错误"
End Sub

'***************************************************************
'*  文本框检测
'*
'*  [参数]
'*      1:控件对象
'*      2:整形变量
'*      3:整形变量
'*      4:字符串变量
'*      5:字符串变量
'*  [返回]
'*      True:成功
'*      False:失败
'*  [使用示例]
'*      Call Check_Txt(text,minlen,maxlen,msgboxtip,msgboxname)
'***************************************************************
Public Function Check_Txt(text As Control, minlen As Integer, maxlen As Integer, msgboxtip As String, msgboxname As String) As Boolean
    On Error GoTo Check_Txt
    Check_Txt = False
    
    Dim S_Text As String
    
    S_Text = Trim(text.text)
    
    '---输入检测长度
    If Len(S_Text) = minlen Then
        MsgBox msgboxtip + "不能为空", vbInformation, msgboxname
        text.SetFocus
        Exit Function
    End If
    
    If Len(S_Text) > maxlen Then
        MsgBox msgboxtip + "长度超过最大范围", vbInformation, msgboxname
        text.SetFocus
        Exit Function
    End If
    
    '---正确返回值设置
    Check_Txt = True
    
    Exit Function
Check_Txt:
    MsgBox "Check_Txt()---出错", vbCritical, "错误"
End Function

'***************************************************************
'*  WriteOneString
'*
'*  [参数]
'*      1:字符串变量
'*      2:字符串变量
'*      3:字符串变量
'*      4:字符串变量
'*  [返回]
'*      无
'*  [使用示例]
'*      Call WriteOneString(lFileName,section,Key,Value)
'***************************************************************
Public Function WriteOneString(ByVal lFileName As String, ByVal section As String, ByVal Key As String, ByVal Value As String)
    
    Dim buff As String * 254
    buff = Value & Chr(0)
    WriteOneString = WritePrivateProfileString(section, Key, buff, lFileName)
    
End Function

'***************************************************************
'*  ReadOneString
'*
'*  [参数]
'*      1:字符串变量
'*      2:字符串变量
'*      3:字符串变量
'*  [返回]
'*      字符串
'*  [使用示例]
'*      Call ReadOneString(lFileName,section,Key)
'***************************************************************
Public Function ReadOneString(ByVal lFileName As String, ByVal section As String, ByVal Key As String) As String
    
    Dim X As Long, buff As String * 254, i As Integer
    X = GetPrivateProfileString(section, Key, "", buff, 254, lFileName)
    i = InStr(buff, Chr(0))
    ReadOneString = Trim(Left(buff, i - 1))
    
End Function

'****************************************************************
'*  Got_Apptitle
'*
'*  [参数]
'*      无
'*  [返回]
'*      字符串
'*  [使用示例]
'*      Call Got_Apptitle
'****************************************************************
Public Function Got_Apptitle() As String

    Dim INI_Path  As String
    Dim S_Section As String
    Dim S_Key     As String
    Dim S_Path    As String
    Dim Buffer    As String
    Dim rtn       As Long
    
    Buffer = Space(MAX_PATH)                      '路径最大长度
    rtn = GetSystemDirectory(Buffer, Len(Buffer)) '得到系统目录
    WinSysPath = Left(Buffer, rtn)                '将取得的路径去掉无用的字符后传递给WinSysPath
    
    S_Path = WinSysPath '将WinSysPath的值传递给S_Path

    INI_Path = S_Path & "\RLSET.ini" '设置INI文件存在的路径
    S_Section = "APP_SETUP"          '设置在INI文件中查找的范围
    S_Key = "Apptitle"               '设置在INI文件中查找的关键字
    
    Got_Apptitle = Trim(ReadOneString(INI_Path, S_Section, S_Key))

End Function

'****************************************************************
'*  Got_DBPath
'*
'*  [参数]
'*      无
'*  [返回]
'*      字符串
'*  [使用示例]
'*      Call Got_DBPath
'****************************************************************
Public Function Got_DBPath() As String

    Dim INI_Path  As String
    Dim S_Section As String
    Dim S_Key     As String
    Dim S_Path    As String
    Dim Buffer    As String
    Dim rtn       As Long
    
    Buffer = Space(MAX_PATH)                      '路径最大长度
    rtn = GetSystemDirectory(Buffer, Len(Buffer)) '得到系统目录
    WinSysPath = Left(Buffer, rtn)                '将取得的路径去掉无用的字符后传递给WinSysPath
    
    S_Path = WinSysPath '将WinSysPath的值传递给S_Path

    INI_Path = S_Path & "\RLSET.ini" '设置INI文件存在的路径
    S_Section = "CONNECT"            '设置在INI文件中查找的范围
    S_Key = "DBConnect"              '设置在INI文件中查找的关键字
    
    Got_DBPath = Trim(ReadOneString(INI_Path, S_Section, S_Key))
    
End Function