从表的OLE字段中读写文件

'---------------------------------【问题症状】----------------------------------------

如何读写OLE字段, 即保存文件到表中OLE字段中,并可读出来,释放到文件

'---------------------------------【专家解答】----------------------------------------

方法一:

tmtony:

保存文件到字段:

Public Function SaveFileToField(ByRef fld As ADODB.Field, DiskFile As String) As Boolean

On Error GoTo ErrorHandle

    Const BLOCKSIZE = 4096
    Dim byteData() As Byte '定义数据块数组
    Dim NumBlocks As Long '定义数据块个数
    Dim FileLength As Long '标识文件长度
    Dim LeftOver As Long '定义剩余字节长度
    Dim SourceFile As Long '定义自由文件号
    Dim I As Long '定义循环变量
    SourceFile = FreeFile '提供一个尚未使用的文件号
    Open DiskFile For Binary Access Read As SourceFile '打开文件
    FileLength = LOF(SourceFile) '得到文件长度
    If FileLength = 0 Then '判断文件是否存在
    Close SourceFile
    MsgBox DiskFile & "无 内 容 或 不 存 在 !"
    Else
    NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
    LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
    fld.Value = Null
    ReDim byteData(BLOCKSIZE) '重新定义数据块的大小
    For I = 1 To NumBlocks
    Get SourceFile, , byteData() ' 读到内存块中
    fld.AppendChunk byteData() '写入FLD
    Next I
    ReDim byteData(LeftOver) '重新定义数据块的大小
    Get SourceFile, , byteData() '读到内存块中
    fld.AppendChunk byteData() '写入FLD
   
    Close SourceFile '关闭源文件
    End If
        SaveFileToField = True
        Exit Function
   
ErrorHandle:
        SaveFileToField = False
        MsgBox Err.Description, vbCritical, "写入数据出错!"
   
End Function

保存字段内容到文件:

Public Function GetFileFromField(blobColumn As ADODB.Field, ByVal FILENAME) As Boolean
Dim FileNumber      As Integer      '文件号
Dim DataLen             As Long         '文件长度
Dim Chunks              As Long         '数据块数
Dim ChunkAry()      As Byte         '数据块数组
Dim ChunkSize       As Long         '数据块大小
Dim Fragment        As Long         '零碎数据大小
Dim lngI                As Long '计数器
   
        On Error GoTo ErrorHandle
        GetFileFromField = False
        ChunkSize = 2048                    '定义块大小为 2K
        If IsNull(blobColumn) Then Exit Function
   
        DataLen = blobColumn.ActualSize         '获得图像大小
        If DataLen < 8 Then Exit Function   '图像大小小于8字节时认为不是图像信息
            FileNumber = FreeFile               '产生随机的文件号
        Open FILENAME For Binary Access Write As FileNumber     '打开存放图像数据文件
        Chunks = DataLen \ ChunkSize        '数据块数
        Fragment = DataLen Mod ChunkSize    '零碎数据
        If Fragment > 0 Then            '有零碎数据，则先读该数据
                ReDim ChunkAry(Fragment - 1)
                ChunkAry = blobColumn.GetChunk(Fragment)
                Put FileNumber, , ChunkAry      '写入文件
        End If
   
        ReDim ChunkAry(ChunkSize - 1)             '为数据块重新开辟空间
        For lngI = 1 To Chunks                              '循环读出所有块
                ChunkAry = blobColumn.GetChunk(ChunkSize)   '在数据库中连续读数据块
                Put FileNumber, , ChunkAry()    '将数据块写入文件中
        Next lngI
        Close FileNumber            '关闭文件
        GetFileFromField = True
        Exit Function
ErrorHandle:
        GetFileFromField = False
        MsgBox Err.Description, vbCritical, "读取数据出错!"
End Function

方法二:

笨小漆：
 

如何将文件保存在OLE字段里(OLE写入/读出)？
OLE文件读入和读出

支持的类型使所有文件，当然，你在读入数据的时候，最好做一个字段保存文件的类型，在保存文件的时候，就可以根据类型选择要保存的类型了。

Option Compare Database
Option Explicit

Public Function GetFromFile(strTable As String, strField As String, strFilter As String, objFileName As String) As Boolean

'============================================================
'　过程函数名： CommModule.GetFromFile　类型：Function
'　参数：
'　　　　 strTable (String)　　：准备保存图形数据的表名称
'　　　　 strField (String)　　：准备保存图形数据的字段名称
'　　　　 strFilter (String)　 ：打开表的过滤字符串，用于定位并确保被打开的表的数据的唯一性
'　　　　 objFileName (String) ：准备输入到表里边的图象文件名称
'　返回：如果保存成功，返回True，如果失败，返回False
'-------------------------------------------------------------
'　说明：把图象文件的数据保存到表里边
'-------------------------------------------------------------
'　修订历史：
'=============================================================
Dim recset　　 As ADODB.Recordset, FileData() As Byte, FileNo As Long, FileSize As Long, strSQL As String

　　strSQL = "Select " & strField & " From " & strTable & " Where " & strFilter & ";"
　　Set recset = New ADODB.Recordset
　　recset.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
　　GetFromFile = True
　　If recset(strField).Type <> DB_OLE Or Not IsFileName(objFileName) Then
　　　　GetFromFile = False　　　　 '如果字段不是OLE字段，或者文件不存在，返回错误
　　　　GoTo EndGetFromFile
　　End If
　　If recset.EOF Then　　　　　　　'如果记录不存在，返回错误
　　　　GetFromFile = False
　　　　GoTo EndGetFromFile
　　End If
　　FileSize = GetFileSize(objFileName) '如果被打开的文件大小为零，返回错误
　　If FileSize <= 0 Then
　　　　GetFromFile = False
　　　　GoTo EndGetFromFile
　　End If
　　ReDim FileData(FileSize)　　　　　　'重新初始化数组
　　FileNo = FreeFile　　　　　　　　　 '获取一个空闲的文件号
　　Open objFileName For Binary As #FileNo　'打开文件
　　Get #FileNo, , FileData()　　　　　 '读取文件内容到数组
　　Close #FileNo　　　　　　　　　　　 '关闭文件
　　recset(strField).value = FileData() '保存数据
　　recset.Update　　　　　　　　　　　 '更新数据
　　Erase FileData　　　　　　　　　　　'释放内存
EndGetFromfile:
　　recset.Close　　　　　　　　　　　　'关闭RecordSet
　　Set recset = Nothing　　　　　　　　'释放内存
End Function

Public Function SaveToFile(strTable As String, strField As String, strFilter As String, strFileName As String) As Boolean
'============================================================
'　过程函数名： CommModule.SaveToFile 类型：Function
'　参数：
'　　　　 strTable (String)　　：保存图形数据的表名称
'　　　　 strField (String)　　：保存图形数据的字段名称
'　　　　 strFilter (String)　 ：打开表的过滤字符串，用于定位并确保被打开的表的纪录的唯一性
'　　　　 strFileName (String) ：准备保存的图象的文件名称
'　返回：如果保存成功，返回True，如果失败，返回False
'-------------------------------------------------------------
'　说明：把由GetFromFile函数保存到表中OLE字段的数据还原到文件
'-------------------------------------------------------------
'　修订历史：
'=============================================================
Dim recset　　 As ADODB.Recordset, FileData() As Byte, FileNo As Long, FileSize As Long, strSQL As String

　　strSQL = "Select " & strField & " From " & strTable & " Where " & strFilter & ";"
　　Set recset = New ADODB.Recordset
　　recset.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic
　　SaveToFile = True
　　If recset(strField).Type <> DB_OLE Then
　　　　SaveToFile = False　　　　 '如果字段不是OLE字段，返回错误
　　　　GoTo EndSaveToFile
　　End If
　　If recset.EOF Then　　　　　　　'如果记录不存在，返回错误
　　　　SaveToFile = False
　　　　GoTo EndSaveToFile
　　End If
　　FileNo = FreeFile
　　Open strFileName For Binary As #FileNo
　　ReDim FileData(recset(strField).ActualSize) '重新初始化数组
　　FileData() = recset(strField).GetChunk(recset(strField).ActualSize) '把OLE字段的内容保存到数组
　　Put #FileNo, , FileData()　 '把数组内容保存到文件
　　Close #FileNo
　　Erase FileData
EndSaveTofile:
　　recset.Close
　　Set recset = Nothing
End Function

MsAccess补充：非常感谢，另两点建议，不知妥否： 

1.recset(strField).Type <> DB_OLE Or Not IsFileName(objFileName) 可改为
recset(strField).Type <> 205 Or Dir(objFileName) = ""

2.GetFileSize(objFileName) 可改为
FileLen(objFileName)

zhuyiwen补充：

在ADP中，对应 image 字段。

recset(strField).Type <> DB_OLE Or Not IsFileName(objFileName) 要改为

recset(strField).Type <> adLongVarBinary Or Dir(objFileName) = ""

方法三:

cg1提供：一个mdb文件，可以自动把所有的需要调用的文件解包到指定目录。不用ole字段完全可以做到。

ole控件的名字.Action = acOLEActivate

记得把rar自解压缩包存到窗体的ole控件里面哈

方法四:

将ADO数据库中的图象拷贝到文件中
Private Function GetRandomFileName(sDirTarget As String, _
sPrefix As String, _
sExtention As String) As String

'Generates a unique temp file name for the specified directory
'with the specified extention
On Error Resume Next
Dim fs As FileSystemObject ' **** requires filesystem object
Dim sFName As String
Dim iRnd As Long
Dim iUpperBound As Long, iLowerbound As Long

TRYAGAIN:

Randomize
iUpperBound = 99
iLowerbound = 0
iRnd = Int((iUpperBound - iLowerbound + 1) * Rnd + iLowerbound)

sFName = CStr(iRnd) + CStr(DatePart("d", Now())) _
+ CStr(DatePart("h", Now())) _
+ CStr(DatePart("n", Now()))

sFName = sPrefix + sFName + "." + sExtention

Set fs = New FileSystemObject

If Not fs.FileExists(sDirTarget + "\" + sFName) Then
GetRandomFileName = sDirTarget + sFName
Exit Function
Else
GoTo TRYAGAIN
End If

End Function

Public Function CopyImageField(fld As ADODB.Field, _
fldTO As ADODB.Field)

'This function takes the source field image and copies it
'into the destination field.
'The function first saves the image in the source field to a
'temp file on disc. Then reads this temp file into
'the destination field.
'The temp file is then deleted
On Error Resume Next

Dim iFieldSize As Long
Dim varChunk As Variant
Dim baData() As Byte
Dim iOffset As Long
Dim sFName As String
Dim iFileNum As Long
Dim cnt As Long
Dim z() As Byte

Const CONCHUNKSIZE As Long = 16384

Dim iChunks As Long
Dim iFragmentSize As Long

'Get a unique random filename
sFName = GetRandomFileName(App.Path, "pic", "tmp")

'Open a file to output the data to
iFileNum = FreeFile
Open sFName For Binary Access Write Lock Write As iFileNum

'Copy the logo to a variable in chunks.
iFieldSize = fld.ActualSize
iChunks = iFieldSize / CONCHUNKSIZE
iFragmentSize = iFieldSize Mod CONCHUNKSIZE
If iFragmentSize > 0 Then
' if there is a frag then write it first, else just use chunk
ReDim baData(iFragmentSize)
baData() = fld.GetChunk(iFragmentSize)
Put iFileNum, , baData()
End If

'Fragment added; Now write rest of chunks
ReDim baData(CONCHUNKSIZE)
For cnt = 1 To iChunks
baData() = fld.GetChunk(CONCHUNKSIZE)
Put iFileNum, , baData
Next cnt

'Close file
Close iFileNum

'Now we have the file on disk Load the pic from
'the temp file into the other field

Open sFName For Binary Access Read As #1
ReDim z(FileLen(sFName))
Get #1, , z()
fldTO.AppendChunk z
Close #1

'Delete the file
Kill (sFName)

End Function
返回

'---------------------------------【专家点评】----------------------------------------  

cg1：以下代码是将文件以二进制存储在OLE字段中，与手动(右键单击OLE字段，选"插入对象")将文件嵌入到OLE字段中是不同的。以二进制方法存储文件无法直接在字段中编辑，必须读出存为文件才能编辑，编辑完成后再写入到OLE字段中。

tmtony:如果要读取手动插入的文件,请参考tmtony《Access专家门诊》一书中有关OLE字段内容剖析的文章