数据库连接通用模块.bas

民间标会的会员管理用的软件。是为一个顾客定做的！

Attribute VB_Name = "mdCom"
Option Explicit

'取得系统临时文件夹的位置



Private m_Drive    As String
Private m_Source   As String
Private m_User     As String
Private m_Server   As String
Private m_Password As String

'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\Administrator\桌面\常用文件\个人记帐系统.mdb;Persist Security Info=False
'Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=酒店管理;Data Source=owen
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public conStr     As String  '连接字符串
Private Cn As ADODB.Connection
Private Rs As ADODB.Recordset
'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Documents and Settings\Administrator\桌面\常用文件\个人记帐系统.mdb;Persist Security Info=False

'QQ:114587904
'2006-03-08


Sub ExecSQL(ByVal strSQL As String) '执行SQL语句
Set Cn = New ADODB.Connection

Cn.Open conStr
Cn.Execute strSQL
Cn.Close

Set Cn = Nothing
End Sub


Function GetRecord(strSQL As String) As ADODB.Recordset '执行SQL并返回
Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset

Cn.Open conStr

Rs.Open strSQL, Cn, adOpenKeyset
Set GetRecord = Rs

'如果返回记录集，那么记录集对象不能释放
'Rs.Close
'Cn.Close
'Set Rs = Nothing
'Set Cn = Nothing
End Function



 
 '向字段写入二进制文件
Sub SetBinary(ByVal Table As String, ByVal Field As String, _
            ByVal Condition As String, ByVal FileName As String)

Set Cn = New ADODB.Connection '数据库连接对象
Dim Rs      As New ADODB.Recordset  '记录集对象
Dim mstream As New ADODB.Stream     '流对象
                    
Cn.Open conStr
'Rs.CursorLocation = adUseClient
Rs.Open "Select " & Field & " from " & Table & " Where " & Condition, Cn, adOpenKeyset, adLockOptimistic
If Rs.RecordCount <> 0 Then
    mstream.Type = adTypeBinary
    mstream.Open
    mstream.LoadFromFile FileName
    Rs.Fields(Field).Value = mstream.Read
    Rs.Update
    mstream.Close
Else
    
End If
Release
Set mstream = Nothing
End Sub
 



'这个函数的作用是，从'TABLE'表的'Field'字段取出满足'Condition'条件
'类型为'fileType'二进制文件,并把它保存到用户临时文件夹下.
'返回临时文件名
Function GetBinary(ByVal Table As String, ByVal Field As String, _
Optional Condition As String, Optional fileType As String = "Tmp") As String

Dim mstream As New ADODB.Stream '定义流对象
Dim Rs          As New ADODB.Recordset
Dim tmpPath     As String       '保存系统临时文件夹位置
Dim Temp        As String * 128 '临时变量
Dim Nul         As Integer      '保存字符串中第一个Chr(0)的位置
Dim FileName    As String       '保存最后生成的文件路径
Dim SQL         As String

SQL = "SELECT " & Field & " From " & Table
If Condition <> "" Then SQL = SQL & " Where " & Condition

Rs.CursorLocation = adUseClient
Set Rs = GetRecord(SQL)
If Rs.RecordCount > 0 Then
    mstream.Open                '打开流对象
    mstream.Type = adTypeBinary '设置流对象的读写类型(文本或二进制)
    Temp = String(128, Chr(0))  '
    GetTempPath 128, Temp       '取得系统临时文件夹位置
    Nul = InStr(Temp, Chr(0))   '保存字符串中第一个Chr(0)的位置
    tmpPath = Left(Temp, Nul - 1)
    
    If Right(tmpPath, 1) <> "\" Then tmpPath = tmpPath & "\"
    FileName = "Temp." & fileType
    FileName = tmpPath & FileName                      '生成的完整的文件物理路径
    mstream.Write Rs.Fields(Field).Value               '把字段内容写入流对象里
    mstream.SaveToFile FileName, adSaveCreateOverWrite '最后保存为文件
End If
GetBinary = FileName
End Function

'取得表的某一个字段的列表
Function GetList(ByVal Table As String, ByVal Field As String, ByRef ArrayList() As String, Optional Condit As String = "") As Boolean


Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset
Dim I As Long
Dim SQL As String

SQL = "SELECT " & Field & " From " & Table
If Condit <> "" Then
    SQL = SQL & " Where " & Condit
End If
Rs.CursorLocation = adUseClient
Cn.Open conStr
Rs.Open SQL, Cn, adOpenKeyset
If Rs.RecordCount > 0 Then
    GetList = True
    Rs.MoveFirst
    Do While Not Rs.EOF
    ReDim Preserve ArrayList(I) As String
        ArrayList(I) = Rs.Fields(0).Value
        I = I + 1
        Rs.MoveNext
    Loop
Else
    GetList = False
End If

Release

End Function

'取得某一字段的值但不返回记录集，返回变体类型

Function GetValue(ByVal SQL As String) As Variant

Set Cn = New ADODB.Connection
Set Rs = New ADODB.Recordset

Cn.Open conStr
Rs.Open SQL, Cn, adOpenForwardOnly, adLockReadOnly
MsgBox Rs.Fields(0).Value

If Rs.EOF = False Or Rs.BOF = False Then GetValue = Rs.Fields(0).Value
'Else
'    GetValue = Null
'End If

Release
End Function

Sub Release() '此做用是释放数据库连接
On Error Resume Next

    If Rs.State <> 0 Then
        Rs.Close
        Set Rs = Nothing
    End If


    If Cn.State <> 0 Then
        Cn.Close
        Set Cn = Nothing
    End If

End Sub



Public Property Get Driver() As DriverType

If m_Drive = "Microsoft.Jet.OLEDB.4.0;" Then
    Driver = DV_Access
Else
    Driver = DV_Sql
End If

End Property

Public Property Let Driver(ByVal vNewValue As DriverType)

Select Case vNewValue
Case 0

    m_Drive = "Microsoft.Jet.OLEDB.4.0;"
Case 1

    m_Drive = "SQLOLEDB.1"
End Select

End Property

Public Property Get UserID() As String
    UserID = m_User
End Property

Public Property Let UserID(ByVal vNewValue As String)
    m_User = vNewValue
End Property

Public Property Get Password() As String
Password = m_Password
End Property

Public Property Let Password(ByVal vNewValue As String)
m_Password = vNewValue
End Property

Public Property Get DataSource() As String
DataSource = m_Source
End Property

Public Property Let DataSource(ByVal vNewValue As String)

m_Source = vNewValue
conStr = "Provider=" & m_Drive & m_Server
conStr = conStr & "Data Source=" & m_Source & ";"


End Property

Public Property Get Server() As String
Server = m_Server
End Property

Public Property Let Server(ByVal vNewValue As String)
m_Server = vNewValue
End Property