module1.bas

远程访问sql server 的源码

Attribute VB_Name = "Module1"
Option Explicit
Public gcnnConnection As ADODB.Connection
Public blnConnected As Boolean

Public Sub newSaveToDB(ByRef fld As ADODB.Field, DiskFile As String)
'功    能：ADO 2.5的保存图片等文件到数据库,利用Stream
'参    数：
'     输入：Fld            ADODB.Field     要写入的数据库字段
'           DiskFile        String         文件的原始路径

    Dim mStream As ADODB.Stream
    
    Set mStream = New ADODB.Stream
    mStream.Type = adTypeBinary
    mStream.Open
    
    If DiskFile <> "" Then
        mStream.LoadFromFile DiskFile
        fld = mStream.Read
    End If
    
    mStream.Close
    Set mStream = Nothing
End Sub

Public Sub newGetFromDB(ByVal PFld As ADODB.Field, ByVal DiskFile As String)
'功    能：ADO 2.5的保存数据库中的图片等文件到磁盘文件,利用Stream
'参    数：
'     输入：PFld            ADODB.Field     要读取的数据库字段
'           DiskFile        String         要保存的文件路径
    Dim mStream As ADODB.Stream
    
    Set mStream = New ADODB.Stream
    mStream.Type = adTypeBinary
    mStream.Open
    
    If DiskFile <> "" Then
        mStream.Write PFld
        mStream.SaveToFile DiskFile, adSaveCreateOverWrite
    End If
    
    mStream.Close
    Set mStream = Nothing
End Sub

Public Function gADOConnection(ByVal cnnConnection As ADODB.Connection) As Boolean
'功    能：连接数据库并执行判断是否连接成功
'参    数：
'      输入：cnnConnection      ADODB.Connection   要创建的连接
'      输出：gADOConnection     Boolean             返回的判断结果

    Dim itsConnectionString As String
    Dim lngErrNum As Long
    
    On Error GoTo ADOErr
    
    itsConnectionString = "DSN=Students ; User ID=sa ;Password=begin_sa"
    cnnConnection.ConnectionString = itsConnectionString
    cnnConnection.Open
    gADOConnection = True
    
ADOErr:
    lngErrNum = err.Number
    If lngErrNum <> 0 Then
        gADOConnection = False
    End If
End Function

Public Function GetRecordSet(strSql As String) As ADODB.Recordset
'功    能：获取ADO记录集
'参    数：
'          输入： strSQL        String     用于查询SQL数据库的SQL语句
'          输出： GetRecordSet  Recordset  返回的记录集

    Dim rsTemp As ADODB.Recordset
    Set rsTemp = New ADODB.Recordset
    
    'If Not (gcnnConnection Is Nothing) Then
    '    gcnnConnection.Close
    '    Set gcnnConnection = Nothing
    'End If
    Set gcnnConnection = New ADODB.Connection
    
    blnConnected = gADOConnection(gcnnConnection)
    
    If blnConnected = True Then
        rsTemp.CursorType = adOpenKeyset
        rsTemp.LockType = adLockOptimistic
        rsTemp.Source = strSql
        Set rsTemp.ActiveConnection = gcnnConnection
        rsTemp.Open
        
        Set GetRecordSet = rsTemp
    Else
        Set GetRecordSet = Nothing
    End If
End Function

'该函数用来将二进制文件读入一个Byte型的数组中去
'然后，通过该函数来完成对数据库的写入
Function GetFileData(ByVal strPath As String, ByRef byteArray() As Byte) As Boolean
    Dim hFileHandle
    
    ReDim byteArray(FileLen(strPath))
    hFileHandle = FreeFile
    Open strPath For Binary Access Read Lock Write As #hFileHandle
    Get #hFileHandle, , byteArray
    GetFileData = True
    Close #hFileHandle
End Function

'该函数用来将二进制文件写入一个Byte型的数组中去
'然后，通过该函数来完成将数据库的图片记录保存到磁盘上的工作
Function SaveToFile(ByVal strPath As String, ByRef varData() As Byte) As Boolean
    Dim hFileHandle As Long
    
    hFileHandle = FreeFile
    Open strPath For Binary Access Write Lock Write As #hFileHandle
    Put #hFileHandle, , varData
    Close #hFileHandle
    SaveToFile = True
End Function

Public Sub oldGetFromDB(ByRef PFld As ADODB.Field, ByRef DiskFile As String)
'功能：ADO 2.0的保存数据库中的图片等文件到磁盘文件
'参数：
'     输入：PFld            ADODB.Field     要读取的数据库字段
'           DiskFile        String         要保存的文件路径

    Dim varData() As Byte '定义数据块数组
    
    On Error GoTo err:
    
    '调用GetChunk方法，将数据库图片文件赋给Byte型数组
    varData = PFld.GetChunk(PFld.ActualSize)
    
    If DiskFile <> vbNullString Then
        '调用函数，将二进制文件存放到磁盘
        SaveToFile DiskFile, varData
    End If
    Exit Sub
err:
    MsgBox err.Number & " " & err.Description
End Sub

Public Sub oldSaveToDB(ByRef fld As ADODB.Field, DiskFile As String)
'功    能：ADO 2.0的保存图片等文件到数据库
'参 数:
'     输入：Fld            ADODB.Field     要写入的数据库字段
'           DiskFile        String         文件的原始路径
    
    Dim varArray() As Byte
    On Error GoTo err:
    
    If DiskFile <> vbNullString Then
        If GetFileData(DiskFile, varArray()) Then
            'GetFileData方法对varArray是传址调用，在此可以将该数组
            '的二进制文件写入到数据库中去
            fld.AppendChunk varArray
        End If
    End If
    Exit Sub
err:
    MsgBox err.Number & " " & err.Description
End Sub