海狸先生、李寻欢、竹筁等高手，请问如何读出OLE字段中的内容并还原为磁盘文件?

tmtony

这里我的《专家门诊——ACCESS开发答疑200问》一书中的实例. 可完全解决你的问题.













210



如何读取使用插入对象插入的OLE字段的内容



适用版本：97、2000、2002、2003





人气 95％



难度系数 êêêêê

问题详述

通过VBA编程使用DAO或ADO方式将文件写入表OLE字段与直接在OLE字段中按右键菜单，选择“插入对象”选择文件插入这两种方式实际上是不同的。

（1）使用VBA编程插入的文件，在OLE字段上双击不会打开相应的容器程序。

（2）使用插入对象方法插入的文件，无法直接通过DAO或ADO方法读出，因为插入的文件有OLE头文件，而不仅是插入的文件的内容。

众所周知，使用VBA编程写入OLE字段的文件或对象可以再使用VBA代码还原成一个文件，那如何实现将用"插入对象"方式插入OLE字段的对象，通过VBA代码汇出到一个文件，汇出的文件扩展名需与插入前的扩展名一样，而且汇出的文件格式完整，并能够正常打开呢？

tmtony

专家解答

通过判断OLE字段的头文件，分析它的结构，然后再去掉头文件的内容，把真正的OLE字段里的文件内容导出到一个文件。具体代码如下。

先创建一个公共模块。

Option Compare Database

Option Explicit

Type PT

  Width As Integer

  Height As Integer

End Type

Type OBJECTHEADER

  Signature As Integer    ' 类型标志(0x1c15).

  HeaderSize As Integer   ' 头文件大小 (sizeof(struct OBJECTHEADER) +cchName + cchClass).

  ObjectType As Long      ' OLE 对象类型代码 (OT_STATIC, OT_LINKED,OT_EMBEDDED).

  NameLen As Integer      ' 对象名的字符数(CchSz(szName) + 1).

  ClassLen As Integer     ' 类名的字符数(CchSz(szClass) + 1).

  NameOffset As Integer   ' 结构中对象名的偏移量(sizeof(OBJECTHEADER)).

  ClassOffset As Integer  ' 结构中类名的偏移量 (ibName +cchName).

  ObjectSize As PT        ' 对象本身的大小

End Type

Type OLEHEADER

  OleVersion As Long

  Format As Long

  TypeLen As Long

End Type

Dim strArr() As String * 1

Public Function ReadbolbToFile(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

        ReadbolbToFile = False

        ChunkSize = 2048                    '定义块大小为 2KB

        If IsNull(blobColumn) Then Exit Function

   

        DataLen = blobColumn.ActualSize         '获得图像大小

        If DataLen < 8 Then Exit Function   '图像大小小于8Byte时认为不是图像信息

            FileNumber = FreeFile               '产生随机的文件号

        Open FILENAME For Binary Access Write As FileNumber     '打开存放图像数据文件

        

        Const BUFFER_SIZE = 8192

       Dim tempFileName As String

       Dim Handle As Integer

       Dim Buffer As String

       Dim BytesNeeded As Long

       Dim Buffers As Long

       Dim Remainder As Long

       Dim ObjHeader As OBJECTHEADER

       Dim sOleHeader As String

       Dim ObjectOffset As Long

       Dim BitmapOffset As Long

       Dim BitmapHeaderOffset As Integer

       Dim r As Integer

       Dim i As Long

        

Dim objHead        As OBJECTHEADER

  Dim oleHead        As OLEHEADER

  Dim j           As Integer

  Dim iStrings       As Integer

  Dim lObject        As Long

  Dim lFileSize      As Long

  Dim l              As Long

  Dim strNL          As String

  Dim strDir         As String

  Dim strMsg         As String

  Dim strDummy       As String

  Dim objName        As String

  Dim strFilename    As String

  Dim strPath        As String

  Dim strExtention   As String

  Dim strByte        As String * 1

  Dim lValue         As Long

  Dim iAction        As Integer

  '

  If blobColumn.ActualSize = 0 Then Exit Function

  '

  strNL = Chr$(13) & Chr$(10)

  '

  strDir = Dir("C:\WINDOWS\TEMP", vbDirectory)

  'If strDir = "TEMP" Then

  '  strDir = "C:\WINDOWS\TEMP\"

  'Else

    strDir = "C:\"

  'End If

  '

  Open strDir & "object.tmp" For Binary As #2

    Put #2, , blobColumn.Value

    Seek #2, 12 + 1

    Get #2, , objHead                       ' 得到对象头

    strMsg = "========== OBJECT-HEADER ==========" & strNL

    strMsg = strMsg & "Signature:" & Chr$(9) & Hex$(objHead.Signature) & strNL

    strMsg = strMsg & "HeaderSize:" & Chr$(9) & Format(objHead.HeaderSize) & strNL

    strMsg = strMsg & "ObjectType:" & Chr$(9) & Format(objHead.ObjectType)

    If objHead.ObjectType = 2 Then strMsg = strMsg & " (embedded)"

    If objHead.ObjectType = 3 Then strMsg = strMsg & " (static)"

    strMsg = strMsg & strNL

    strMsg = strMsg & "NameLength:" & Chr$(9) & Format(objHead.NameLen) & strNL

    strMsg = strMsg & "ClassLength:" & Chr$(9) & Format(objHead.ClassLe

tmtony

读取OLE字段的内容到文件中。

Public Function ReadbolbToFile0(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

        ReadbolbToFile0 = False

        ChunkSize = 2048                    '定义块大小为 2KB

        If IsNull(blobColumn) Then Exit Function

   

        DataLen = blobColumn.ActualSize         '获得图像大小

        If DataLen < 8 Then Exit Function   '图像大小小于8 Byte时认为不是图像信息

            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                             '循环读出所有块

              '  If lngI = Chunks Then

              '      ChunkSize = 1974

              '  End If

               

                ChunkAry = blobColumn.GetChunk(ChunkSize)   '在数据库中连续读数据块

                Put FileNumber, , ChunkAry()    '将数据块写入文件中

        Next lngI

        Close FileNumber            '关闭文件

        ReadbolbToFile0 = True

        Exit Function

ErrorHandle:

        ReadbolbToFile0 = False

        MsgBox Err.Description, vbCritical, "读图像数据出错!"

End Function

然后创建一个窗体来测试这个公共模块，窗体的代码如下。

Option Compare Database

Option Explicit

Private Sub cmdGetBmpFile_Click()

Dim rstTemp As New ADODB.Recordset

rstTemp.Open "select * from tblOleFile where FFileName='测试Bmp文件'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

ReadbolbToFile rstTemp("FFileOle"), "c:\测试Bmp文件.bmp"

rstTemp.Close

End Sub

Private Sub cmdGetExcelFile_Click()

Dim rstTemp As New ADODB.Recordset

rstTemp.Open "select * from tblOleFile where FFileName='测试Excel文件'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

ReadbolbToFile rstTemp("FFileOle"), "c:\测试Excel文件.xls"

rstTemp.Close

End Sub

Private Sub cmdGetWordFile_Click()

Dim rstTemp As New ADODB.Recordset

rstTemp.Open "select * from tblOleFile where FFileName='测试Word文件'", CurrentProject.Connection, adOpenDynamic, adLockOptimistic

ReadbolbToFile rstTemp("FFileOle"), "c:\测试Word文件.doc"

rstTemp.Close

End Sub

注意，这样读取出来的文件大小可能与原来文件大小会有一些差异，但文件打开后的内容是一致的，没有数据丢失的现象。

专家点评

上述方法虽然能正确读取文件的内容，但必须预先知道文件存储的格式，如果不知道文件写入到OLE字段的格式，那读取出来就无法以适当的文件扩展名保存该文件。不过，通过读取文件头中有关信息或许可知道文件的大致类型，这需要做进一步的深入研究。

gaoqiwen

我现在使用的函数：简单实用，不过需要知道文件的类型；需引用ADO2.5以上。望各版主指点。Public Function SaveFile(FileName As String, Field As ADODB.Field)

On Error GoTo FunErr

   

    Dim DStream As New ADODB.stream

    DStream.Type = adTypeBinary

    DStream.Open

    DStream.Write Field.Value

    DStream.SaveToFile FileName, adSaveCreateOverWrite

   

FunExit:

    Exit Function

   

FunErr:

    MsgBox Err.Number & vbNewLine & Err.Description

    Resume FunExit

End Function[em04]

van_zeng

学习一下