Private mAdoConn As New ADODB.Connection Private mAdoRst As New ADODB.Recordset Private mstrDbName As String Private mstrTableName As String Private mstrImageColumnName As String '图片字的名称。 Private mstrImageTypeColumnName As String '图片类型字段的名称。 Private mstrImageIdColumnName As String '图片ID字段的名称。 Private mstrFileName() As String '数组,里面包含文件名和路径。 Private mlngImageId() As Long '数组,里面包含图片ID Private mlngNumberOfFiles As Long Const BLOCKSIZE = 102400
Public Property Let DbName(ByVal strVal As String) mstrDbName = strVal End Property
Public Property Let TableName(ByVal strVal As String) mstrTableName = strVal End Property
Public Property Let NameOfImageColumn(ByVal strVal As String) mstrImageColumnName = strVal End Property
Public Property Let NameOfImageTypeColumn(ByVal strVal As String) mstrImageTypeColumnName = strVal End Property
Public Property Let NameOfImageIdColumn(ByVal strVal As String) mstrImageIdColumnName = strVal End Property
Public Property Get ImageFile(ByVal ImageId As Integer) As String Dim intPos As Integer Dim blnFindId As Boolean Dim i As Integer
blnFindId = False For i = 0 To mlngNumberOfFiles - 1 If mlngImageId(i) = ImageId Then intPos = 5 + Len(ImageId) + 3 ImageFile = Right(mstrFileName(i), intPos) 'reformat the location of file. blnFindId = True End If Next i
If blnFindId = False Then Err.Clear Err.Raise vbObjectError + 23, "Get ImageFile", "Can't find image file!" End If
End Property
Public Sub OpenConnection() '********************************************************** '作用:打开数据库连接。 '**********************************************************
On Error GoTo Error_handler If mstrDbName = "" Then GoTo Error_handler If mAdoConn.State = adStateOpen Then mAdoConn.Close mAdoConn.ConnectionString = "DRIVER={SQL Server};SERVER=(local);UID=sa;PWD=;WSID=JIA;DATABASE=" & mstrDbName mAdoConn.ConnectionTimeout = 15 mAdoConn.Open Exit Sub
Error_handler: Call HandleError End Sub
Public Sub CreateTempImageFile(ByVal ImageId As Integer) Dim strImageType As String Dim i As Integer '********************************************************** '作用:打开记录集,提取二进制数据,并把数据存入文件。注意文件名使用图片ID生成。 '输入:图片ID。 '********************************************************** If mAdoConn.State = adStateClosed Then Exit Sub
Call OpenRecordset(ImageId)
If mAdoRst.State = adStateClosed Then Exit Sub
On Error GoTo Error_handler
For i = 0 To mlngNumberOfFiles - 1 '检测图片文件是否已经存在。 If mlngImageId(i) = ImageId Then Exit Sub Next i
Private Sub OpenRecordset(ByVal ImageId As Integer) Dim SqlText As String '********************************************************** '作用:打开记录集。 '输入:图片ID。 '**********************************************************
On Error GoTo Error_handler If mAdoRst.State = adStateOpen Then mAdoRst.Close SqlText = "SELECT " & mstrImageColumnName & "," & _ mstrImageTypeColumnName & " FROM " & mstrTableName & _ " WHERE " & mstrImageIdColumnName & "=" & ImageId
Private Sub ReadFromDB(fld As ADODB.Field, ByVal DiskFile As String, _ FldSize As Long) Dim NumBlocks As Integer Dim LeftOver As Long Dim byteData() As Byte '字节数组,用于长的可变二进制数据LongVarBinary。 Dim strData As String '字符串,用于长的可变二进制数据LongVarChar。 Dim DestFileNum As Integer Dim pic As Variant Dim i As Integer '********************************************************** '作用:提取二进制数据并把数据放入文件。 '输入:图片字段,文件名/位置和数据尺寸。 '**********************************************************
If Len(Dir(DiskFile)) > 0 Then '删除已经存在的目标文件。 Kill DiskFile End If
DestFileNum = FreeFile Open DiskFile For Binary As DestFileNum NumBlocks = FldSize / BLOCKSIZE LeftOver = FldSize Mod BLOCKSIZE
Select Case fld.Type Case adLongVarBinary '用于图片数据类型。 byteData() = fld.GetChunk(LeftOver) pic = fld.GetChunk(LeftOver) Put DestFileNum, , byteData()
For i = 1 To NumBlocks byteData() = fld.GetChunk(BLOCKSIZE) Put DestFileNum, , byteData() Next i
Case adLongVarChar '用于文本数据类型。 For i = 1 To NumBlocks strData = String(BLOCKSIZE, 32) strData = fld.GetChunk(BLOCKSIZE) Put DestFileNum, , strData Next i
strData = String(LeftOver, 32) strData = fld.GetChunk(LeftOver) Put DestFileNum, , strData Case Else Err.Clear Err.Raise vbObjectError + 22, "Read from DB", "Not a Chunk Required column!" End Select
Close DestFileNum
End Sub
Private Sub HandleError() Dim adoErrs As ADODB.Errors Dim errLoop As ADODB.Error Dim strError As String Dim i As Integer '********************************************************** '作用:处理可能的错误。 '**********************************************************
If mAdoConn.State = adStateClosed Then GoTo Done i = 1 Set adoErrs = mAdoConn.Errors For Each errLoop In adoErrs '枚举错误集。 With errLoop strError = strError & vbCrLf & " ADO Error #" & .Number strError = strError & vbCrLf & " Description " & .Description strError = strError & vbCrLf & " Source " & .Source i = i + 1 End With Next
Done: Err.Raise vbObjectError + 21, "", strError End Sub
Private Sub Class_Initialize() mlngNumberOfFiles = 0 End Sub
Private Sub Class_Terminate() Dim i As Integer On Error GoTo Error_handler If mAdoRst.State = adStateOpen Then mAdoRst.Close '关闭记录集。 If mAdoConn.State = adStateOpen Then mAdoConn.Close '关闭连接。 Set mAdoRst = Nothing Set mAdoConn = Nothing Exit Sub