[讨论]新制数据库通用操作模块,欢迎大家测试和改进.

zodane

''''''''''''''''''''''''''''''''''''''''''''数据管理类''''''''''''''''''''''''''''''''''''''''''''''''''''''
'描述: 进行数据库各项操作的集成.功能比常规的操作强大 支持多数据库连接.图片存取,(需要数据库的SQL语法基础).(支持数据库实时操作与后台conn.excute 语句操作 .)
'作者:铁血(QQ:44378791)
'版本号:1.01(07/2/28)
'日期:2007年2月28日.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private mConn() As ADODB.Connection
Private mRs() As ADODB.Recordset
Private j() As String
Private Count As Integer
Private cs() As String
Private Ds() As String

Public Property Get Conn(Index As Integer) As ADODB.Connection  '外界引用的连接变量
    Set Conn = mConn(Index)
End Property


Public Property Get rs(Index As Integer) As ADODB.Recordset  '外界引用的RS .
    Set rs = mRs(Index)
End Property
Public Property Set rs(Index As Integer, ByVal vData As ADODB.Recordset)
    Set mRs(Index) = vData
End Property

'可在外部用CONN.execute 执行.
Public Function AddNew(conna As ADODB.Connection, Rsa As ADODB.Recordset,
fname As String, w As Long) As String  '得到字符型的数据库操作语句.(新建)
  Rsa.Open "select * from " & "fname", conna, 3, 1
  Dim Begine As String
  Begine = Rsa.Fields(0).Name
  AddNew = "Insert Into " & fname & "( " & Begine & " )" & " Values"
  AddNew = AddNew & "( " & w & " )"
  Rsa.Close
End Function
Public Function DelCut(fname As String, Rcdname As String, Value As Variant) As String
  DelCut = "Delete From " & fname & " Where " & Rcdname & " = " & Value
End Function

Public Sub AddTrue(conna As ADODB.Connection, Rsa As ADODB.Recordset, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & "fname", conna, 3, 3
  Rsa.AddNew
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).Value = w(i)
  Next
  Rsa.Update
  Rsa.Close
End Sub
'''删除单条记录'''''''''''(运行时直接删除).
Public Function DelRcd(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal FormName As String, ByVal RecName As String, ByVal RecValue As Variant) As Boolean
On Error GoTo Finish
Rsa.Open "delete * from " + FormName + " where " + RecName + " = '" + RecValue + "'", conna, 3, 1
DelRcd = True
Exit Function
Finish:
DelRcd = False
End Function

Public Sub ChangeA(Rsa As ADODB.Recordset, ParamArray w() As Variant)
  Dim i As Integer
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).Value = w(i)
  Next
End Sub

'以下俩个函数适用于实时操作的数据库
Public Sub ChangeB(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal RecName As String, ByVal RecValue As Variant, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & fname & " where " + RecName + " = " + RecValue, conna, 3, 3
  Rsa.AddNew
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).Value = w(i)
  Next
  Rsa.Update
  Rsa.Close
End Sub

Public Sub ChangeB(conna As ADODB.Connection, Rsa As ADODB.Recordset, ByVal RecName As String, ByVal RecValue As Variant, fname As String, ParamArray w() As Variant)
  Dim i As Integer
  Rsa.Open "select * from " & fname & " where " + RecName + " = '" + RecValue + "'", conna, 3, 3
  For i = 1 To Rsa.Fields.Count
    Rsa.Fields(i).Value = w(i - 1)
  Next
  Rsa.Update
  Rsa.Close
End Sub

Public Sub LoadData(Rsa As ADODB.Recordset, ParamArray w() As Variant) '读数据库
  Dim i As Integer
  For i = 1 To Rsa.Fields.Count
    w(i - 1) = Rsa.Fields(i).Value
  Next i
End Sub

Public Sub AddBase(Dname As String) '建立一个新数据库的连接.
  Dim i As Integer, j As Integer
  Count = Count + 1
  For i = 1 To Count
    ReDim Preserve Conn(1 To Count)
    Set Conn(Count) = New ADODB.Connection
    ConnOpen Dname
    ReDim Preserve rs(1 To Count)
    Set rs(Count) = New ADODB.Recordset
  Next i
End Sub

Private Sub ConnOpen(DataName As String)  ' 打开数据连接
    Dim strConn As String '数据库连接字符串
    Dim dbpath As String
    ' On Error GoTo err
        dbpath = App.Path
        If Right(dbpath, 1) <> "\" Then dbpath = dbpath + "\"
        dbpath = dbpath & DataName
        strConn = &quotrovider=Microsoft.Jet.OLEDB.4.0;Data Source= " & dbpath & ";Persist Security Info=False"
        Conn(Count).Open strConn
        Conn(Count).CursorLocation = adUseClient
    Exit Sub
    'err:
     ' MsgBox "数据库连接失败！"
End Sub
Private Sub ConnClose()  '关闭连接并释放内存
   On Error Resume Next
   Dim i As Integer
   For i = 1 To Count
     If Conn(i).State = adStateOpen Then Conn.Close
     Set Conn(i) = Nothing
     Set rs(i) = Nothing
   Next i
End Sub

''''以下三个函数为数据库中的图片操作.
Public Sub GetPic(rs As ADODB.Recordset, Pic As PictureBox, i As Integer)   '读取图片
    On Error Resume Next
    Set StmPic = New ADODB.Stream
    StrPIctemp = "c:\temp.tmp"    '临时文件,用来保存读出的图片
    With StmPic
        .Type = adTypeBinary
        .Open
        .Write rs.Fields(i)       '写入数据库中的数据至Stream中
        .SaveToFile StrPIctemp, adSaveCreateOverWrite  '将Stream中数据写入临时文件中
        .Close
    End With
    Pic.Picture = LoadPicture(StrPIctemp)  '用Picture控件显示图像
End Sub
'在数据库中取得图片的二进制数据流.(这个函数中的图片数据可以在多种场合中灵活的出现).
Public Function GetPicData(rs As ADODB.Recordset, T As Integer) As String
    Dim StrPIctemp As String
    Set StmPic = New ADODB.Stream
    StrPIctemp = "c:\temp.tmp"    '临时文件,用来保存读出的图片
    With StmPic
        .Type = adTypeBinary
        .Open
        .Write rs.Fields(T)     '写入数据库中的数据至Stream中
        .SaveToFile StrPIctemp, adSaveCreateOverWrite  '将Stream中数据写入临时文件中
        .Close
    End With
    GetPicData = StrPIctemp
   ' Set StrPIctemp = Nothing
    Set StmPic = Nothing
End Function
Public Sub SavePic(rs As ADODB.Recordset, i As Integer)  '保存图片
    Dim StrPIctemp As Variant
    Set StmPic = New ADODB.Stream
    StmPic.Type = adTypeBinary    '指定流是二进制类型
    StmPic.Open                     '将数据获取到Stream对象中
    StmPic.LoadFromFile (dlgopen.FileName) '将选择的图像加载到打开的StmPic中
    rs.Fields(i).Value = StmPic.Read   '从StmPic对象中读取数据
    StmPic.Close
End Sub
'星河程序群(19597340)+ 论坛千分以上会员和业余爱好者.