数据库连接通用模块(xg).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
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

'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


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



'返回日期对应的月份编号(从0到15)
Function GetMonthNo(ByVal Dt As Date) As Byte

Dim Mt As Integer

Mt = Month(Dt)
Mt = Month(Dt)
Mt = Mt + (Mt - 1) \ 3
If Month(Dt) Mod 3 = 0 Then
    If Day(Dt) > 15 Then Mt = Mt + 1
End If
GetMonthNo = Mt - 1


End Function


Function GetDate(ByVal lYear As Long, ByVal MonthNo As Integer) As Date

Dim MM As Integer

'MonthNo = MonthNo + 1

MM = MonthNo - MonthNo \ 4

Dim DD As String
If (MonthNo + 1) Mod 4 = 0 Then
    DD = 15
Else
    DD = GetLastDay(lYear, MM)
End If
GetDate = CDate(lYear & "-" & MM & "-" & DD)
End Function



Function GetLastDay(ByVal lYear As Long, ByVal iMonth As Integer) As Integer

Dim DD As String

Select Case iMonth

Case 1
    DD = 31
Case 2
   DD = IIf(lYear Mod 4 = 0, 29, 28)
Case 3 To 7
  DD = iMonth Mod 2 + 30
Case 8 To 12
  DD = 31 - iMonth Mod 2
End Select
GetLastDay = CStr(DD)

End Function