access vba实现OLE对象保存到本地

参考oletodisk的实现方法，更新为在64位office上野可以运行，函数模块代码如下：

Option Compare Database
Option Explicit


'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 through A2003
'
'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.


'Distribution:

' Plain and simple you are free to use this source within your own
' applications, whether private or commercial, without cost or obligation, other that keeping
' the copyright notices intact. No public notice of copyright is required.
' You may not resell this source code by itself or as part of a collection.
' You may not post this code or any portion of this code in electronic format.
' The source may only be downloaded from:
' www.lebans.com
'
'Name:      GetContentsStream
'
'Version:   2.89
'
'Purpose:
'
'?) Export data inserted into OLE object field.
'    The original application that served as an OLE Server to insert
'    the object is NOT required.
'
' 2) Perform an inventory of OLE field within an external table.
'    Returns inventory information including Linked path/filename if applicable.
'
'瓲
'
'Author:    Stephen Lebans
'
'Email:     Stephen@lebans.com
'
'Web Site:  www.lebans.com
'
'Date:      Nov 17, 2007, 12:34:56 PM
'
'Dependencies:  StrStorage.dll(Standard Windows DLL - DOES NOT require Registration.
'               modGetContents Stream
'               modListTables
'               clsCommonDialog
'               cDIBSection
'
'Inputs:    See inline Comments for explanation

'Output:    See inline Comments for explanation
'
'Credits:   Anyone who wants some!
'
'BUGS:      Please report any bugs to my email address.
'
'What's Missing:
'           Enhanced Error Handling
'
'How it Works:
'           Keep reading!

' Ver Jan 16 - 2008
' Working on fixing Bug for embedded OT_STATIC MetafilePict
' Added support for FoxitReader.Document embedded objects(PDF)

' Ver Nov 17, 2007
' Added support for WordPad documents.

' Ver June 7, 2007
' Added support for Kodak Imaging TIFF documents.


' Ver March 20
' Added support for PaperPort MAX documents and
' HP DeskScan embedded images(Bitmaps).

' This module exposes two functions.
'Public Function fGetContentsStream(ByRef arrayOLE() As Byte, _
'FileExtension As String, _
'Optional FileNamePackage As String = "") As Boolean

' The first parameter, arrayOLE, is an array of Byte values that contain the entire
' contents of an OLE object field. We pass the the first element of the
' array be Reference, arrayOLE(0), which really means we are passing
' the address of the start of the array.

' The second parameter, FileExtension, is a empty string variable you pass that will
' be filled in with the file extension of the extracted object.

' The third parameter, FileNamePackage, is a empty string variable you pass that will
' be filled in with the original file name of the extracted object when the object
' was embedded as a Package.


'Have Fun!
'
'
'
' ******************************************************

              
Private Type RECT
    Left As Long
    top As Long
    right As Long
    Bottom As Long
End Type

Private Type SIZEL
    cx As Long
    cy As Long
End Type

Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgblReserved As Byte
End Type

Private Type BITMAPINFOHEADER '40 bytes
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long 'ERGBCompression
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type


Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type


Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Type DIBSECTION
    dsBm As BITMAP
    dsBmih As BITMAPINFOHEADER
    dsBitfields(2) As Long
    dshSection As Long
    dsOffset As Long
End Type


' Here is the header for the Bitmap file
' as it resides in a disk file
Private Type BITMAPFILEHEADER    '14 bytes
  bfType As Integer
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type

Private Type METAFILEPICT
 mm As Long
 xExt As Long
 yExt As Long
 hMF As Long
End Type


Private Const CON_CHUNK_SIZE As Long = 32768
Private Const OBJECT_SIGNATURE = &H1C15
Private Const OBJECT_HEADER_SIZE = 20
Private Const CHECKSUM_SIGNATURE = &HFE05AD00
Private Const CHECKSUM_STRING_SIZE = 4
Private Const SIG_BMP = &H4D42


Private Type PT
   width As Integer
   Height As Integer
End Type
'
'
' OBJECTHEADER : Contains relevant information about object.
'
Private Type OBJECTHEADER
   Signature As Integer         ' Type signature (0x1c15).
   HeaderSize As Integer        ' Size of header (sizeof(struct
                                ' OBJECTHEADER) + cchName +
                                '  cchClass).
   ObjectType As Long           ' OLE Object type code (OT_STATIC,
                                '  OT_LINKED, OT_EMBEDDED).
   NameLen As Integer           ' Count of characters in object
                                '  name (CchSz(szName) + 1).
   ClassLen As Integer          ' Count of characters in class
                                '  name (CchSz(szClass) + 1).
   NameOffset As Integer        ' Offset of object name in
                                '  structure (sizeof(OBJECTHEADER)).
   ClassOffset As Integer       ' Offset of class name in
                                '  structure (ibName + cchName).
   ObjectSize As PT             ' Original size of object (see
                                '  code below for value).
'   OleInfo(256) As Byte
End Type

'/* Object types */
Public Const OT_LINK As Long = 1&
Public Const OT_EMBEDDED = 2&
Public Const OT_STATIC = 3&



Private Type MSPHOTOEDITOR_CONTENTS_HEADER
    bmBitDepth As Integer
    bmWidth As Integer
    bmHeight As Integer
End Type

' Pass first element of Byte array - ex. a(0)
' Pass size of array in bytes
' Return length of valid data in the passed array of bytes
' Array will contain complete CONTENTS Stream of Structured Storage

 
' debugging with Visual C++
'Lib "C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll"

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare PtrSafe Function LoadLibrary Lib "kernel32" _
Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long

Private Declare PtrSafe Function FreeLibrary Lib "kernel32" _
(ByVal hLibModule As Long) As Long

Private Declare PtrSafe Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Private Declare PtrSafe Function GetTempFileName _
Lib "kernel32" Alias "GetTempFileNameA" _
(ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long

Private Declare PtrSafe Function GetLongPathName Lib "kernel32.dll" Alias _
"GetLongPathNameA" (ByVal lpszShortPath As String, _
      ByVal lpszLongPath As String, _
      ByVal cchBuffer As Long) As Long

Public Declare PtrSafe Function GetFullPathName Lib "kernel32" _
     Alias "GetFullPathNameA" _
     (ByVal lpFileName As String, _
      ByVal nBufferLength As Long, _
      ByVal lpBuffer As String, _
      ByVal lpFilePart As String) As Long




Private Const Pathlen = 256
Private Const MaxPath = 256

' Structured Storage Signature = 'D0CF11E0
Private Const SSsig As Long = &HE011CFD0

' Allow user to set FileName instead
' of using API Temp Filename or
' popping File Dialog Window
Private mSaveFileName As String

' Instance returned from LoadLibrary call
Private hLibStrStorage As Long

' * Move this into a class so we can init/destroy properly
Private ds As cDIBSection


Public Function fGetContentsStream(ByRef arrayOLE() As Byte, _
FileExtension As String, _
Optional FileNamePackage As String = "") As Boolean
' arrayOLE must contain the entire contents of the OLE field.
' Returns arrayOLE resized to fit and contain the
' CONTENTS Stream of the OLE Structured Storage passed to this function.
' Exceptions are for the "Package" type and Bitmap's embedded with MS Paint.

' Hold working copy of arrayOLE
Dim arrayB() As Byte

' Size of "Package"
Dim lPackSize As Long

' File Extension of Package
Dim FileNamePackageExt As String
' Original File Name and Path of Package
Dim FileNameandPathPackage As String

' Current position in arrayOLE
Dim lPos As Long

' Temp vars
Dim bCurValue As Byte
Dim iOffset As Integer
Dim i As Integer
Dim x As Long
Dim s As String
Dim blRet As Boolean
Dim lngRet As Long
Dim y As Long

' Length of array returned from functions in Structured Storage DLL.
Dim lLen As Long

' Access OLE Wrapper
Dim objHeader As OBJECTHEADER

' Offset to start of structured storage file
Dim lOffSet As Long

' Class name of embedded OLE object
Dim arrayClassName(0 To 1023) As Byte

' OLE object temp vars
Dim sClassName As String
Dim sStreamName As String
Dim sBuf As String
Dim sExt As String

Dim mfp As METAFILEPICT
Dim bm As BITMAPINFOHEADER


On Error GoTo ERR_fGetContentsStream

' Get Offset to start of Structured Storage
CopyMemory objHeader, arrayOLE(0), OBJECT_HEADER_SIZE
lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen

' If Linked object then exit
If objHeader.ObjectType = OT_LINK Then
    fGetContentsStream = False
    Exit Function
End If

' Let's see if the StrStorage.DLL is available.
'blRet = LoadLib()
'If blRet = False Then
'    ' Cannot find StrStorage.dll file
'    fGetContentsStream = False
'    Exit Function
'End If

' If OLE object was draged and dropped then
' the ClassLen member with be a NULL string
'If objHeader.ClassLen > 1 Then
    ' Convert byte Ascii data to VB string
    sClassName = ""
    For i = 0 To objHeader.ClassLen - 2
        sClassName = sClassName & Chr(arrayOLE(objHeader.ClassOffset + i))
    Next i
'Else

' Add support for ClassLen = 0 - Drag and Dropped OLE object
'End If
    
' Call seperate function if object is of type STATIC
If objHeader.ObjectType = OT_STATIC Then
sClassName = "OT_STATIC"
End If

' Logic tree based on ClassName of embedded object
Select Case Left(sClassName, 7)

Case "OT_STAT"
' Two possibilities.
' Static MetafilePict or Static DIB
' Standard OLE wrapper but it is always the same size
' because the Class name is blank and Object name is always "Picture".
' 29 Bytes Access OLE Header wrapper.

' The following 12 Bytes are private header data
' This brings us to offset 41.
' The next 3 bytes will either be = "DIB or "MET"
' DIB
' After "DIB" + terminating NULL char we jump over next
' 8 bytes of private data.

' The next 4 bytes are the size of the Bitmap.
'
' The next 40 Bytes are the BITMAPINFOHEADER structure
' The next 4 bytes are always the value 40 - SIZEOF BITMAPINFOHEADER

' The next X bytes are the BITMAPINFOHEADER

' So once we get to the LONG SIZEOF bitmap data we can build
' the disk basked BMP file.
' The next X bytes are the actual Bitmap Data
'
'

' Start of Package header
' Jan - 2008 Offset out by 1 - was 41
lPos = 38
'' Skip nexy 4 bytes - Package size including padding
'lPos = lPos + 4
' Skip next 2 bytes - Embedded constant - 2 ?
'lPos = lPos + 2

' Checking for 0 so must initialize to any value but 0.
bCurValue = 1

Dim lSize As Long
Dim FileHeaderBM As BITMAPFILEHEADER

Dim sType As String
' DIB or METAFILEPICT
Do While bCurValue <> 0
    bCurValue = arrayOLE(lPos)
    sType = sType & Chr(bCurValue)
    lPos = lPos + 1
Loop

' Jump over next 8 bytes of private data
lPos = lPos + 8

If sType = "DIB" Then
    ' Get size of Bitmap Data
    CopyMemory lSize, arrayOLE(lPos), 4
    ' Make sure is less than arrayOLE
    If lSize > UBound(arrayOLE) Then
        ' Error
        fGetContentsStream = False
        Exit Function
    End If
    ' 14 is the size of the Bitmap disk File Header
    ReDim arrayB(0 To lSize + 14 - 1)
    
    ' Jump over 4 bytes of lSize
    lPos = lPos + 4
    
    ' Copy starting at end of BMP File Header(+14)
    CopyMemory arrayB(14), arrayOLE(lPos), lSize
    
    ' Are we 8 bits or less with a ColorTable
    CopyMemory bm, arrayB(14), Len(bm)
    
    Select Case bm.biBitCount
    
    Case 24, 16
    iOffset = 0
    
    Case 8
    ' Some apps mistakenly write &HFF here instead of 256(&H0100)
    ' Further they only actually use 255 colors instead of 256
    If bm.biClrUsed = 255 Then
        iOffset = 255 * 4
    Else
        iOffset = 256 * 4
    End If
    
    Case 4
    iOffset = 16
    
    Case Else
    iOffset = 0
    
    End Select
    
    ' Build BMP File Header
    ' Signature
    With FileHeaderBM
        ' Signature
        .bfType = &H4D42
        ' Size of entire Bitmap disk file.
        ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
        .bfSize = Len(FileHeaderBM) + lSize
        ' Offset from start of file to start of Bitmap data
        .bfOffBits = Len(FileHeaderBM) + Len(bm) + iOffset
    End With

    ' Signature
    CopyMemory arrayB(0), FileHeaderBM.bfType, 2
    ' Size of Bitmap file
    CopyMemory arrayB(2), FileHeaderBM.bfSize, 4
    'CopyMemory arrayOLE(6), ByVal 0&, 4
    ' Next 4 bytes Reserved
    arrayB(6) = 0
    arrayB(7) = 0
    arrayB(8) = 0
    arrayB(9) = 0
    ' Offset to start of Bitmap data
    ' Always File Header len(14) + BITMAPINFOHEADER len(40)
    CopyMemory arrayB(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
 
    ' Size our main array
    ReDim arrayOLE(0 To UBound(arrayB))
    ' Copy temp array to our main array
    arrayOLE = arrayB
    FileExtension = "bmp"
    sExt = "bmp"


Else
    ' METAFILEPICT
    ' Get size of Bitmap Data
        CopyMemory lSize, arrayOLE(lPos), 4
        ' Make sure is less than arrayOLE
        If lSize > UBound(arrayOLE) Then
            ' Error
            fGetContentsStream = False
            Exit Function
        End If
    ' 8 is the length of the METAFILEPICT structure
    ' because this OLE format only uses WORD(2 bytes)
    ' for each structure element
    ReDim arrayB(0 To (lSize - 8) - 1)
    
    ' Jump over 4 bytes of lSize
    lPos = lPos + 4
    
    ' Fill in our public METAFILEPICT structure
    CopyMemory mfp.mm, arrayOLE(lPos), 2
    CopyMemory mfp.xExt, arrayOLE(lPos + 2), 2
    CopyMemory mfp.yExt, arrayOLE(lPos + 4), 2
    
    ' Jump over 8 bytes of METAFILEPICT structure
    lPos = lPos + 8
       
    ' Copy starting at end of BMP File Header(+14)
    CopyMemory arrayB(0), arrayOLE(lPos), lSize - 8
    
    ' Convert WMF to DIB
    blRet = ds.WMFtoBMP(arrayB(), mfp.mm, mfp.xExt, mfp.yExt)
    If blRet = False Then
        fGetContentsStream = False
        Exit Function
    End If
    
    ' ArrayB now contains the Byte data for the DIB
    ' Create the disk Based Bitmap file
    
    ' 40 is the size of the BITMAPINFOHEADER
    ' 14 is the size of the Bitmap disk File Header
    ReDim arrayOLE(0 To UBound(arrayB()) + 40 + 14)
    
    ' Jump over 4 bytes of lSize
    'lPos = lPos + 4
    
    ' Copy starting at end of BMP File Header(+14) plus BITMAPINFOHEADER(+40)
    CopyMemory arrayOLE(14 + 40), arrayB(0), UBound(arrayB()) + 1
    
    ' Build BITMAPINFOHEADER
    With bm
        .biBitCount = 24
        .biClrImportant = 0
        .biClrUsed = 0
        .biCompression = 0
        .biHeight = ds.dib_height
        .biPlanes = 1
        .biSize = 40
        .biSizeImage = UBound(arrayB()) + 1 '(ds.dib_width * ds.BytesPerScanLine) * ds.dib_height
        .biWidth = ds.dib_width
        .biXPelsPerMeter = 0
        .biYPelsPerMeter = 0
        
    End With
    
    ' Copy BITMAPINFOHEADER
    CopyMemory arrayOLE(14), ByVal bm, Len(bm)  ' always 40 for this project
    
    ' Build BMP File Header
    ' Fill in our Bitmap FileHeader.
With FileHeaderBM
    ' Signature
    .bfType = &H4D42
    ' Size of entire Bitmap disk file.
    ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
    .bfSize = Len(FileHeaderBM) + Len(bm) + bm.biSizeImage
    ' Offset from start of file to start of Bitmap data
    .bfOffBits = Len(FileHeaderBM) + Len(bm)
End With
    ' Signature
    CopyMemory arrayOLE(0), FileHeaderBM.bfType, 2
    ' Size of Bitmap file
    CopyMemory arrayOLE(2), FileHeaderBM.bfSize, 4
    'CopyMemory arrayOLE(6), ByVal 0&, 4
    ' Next 4 bytes Reserved
    arrayOLE(6) = 0
    arrayOLE(7) = 0
    arrayOLE(8) = 0
    arrayOLE(9) = 0
    ' Offset to start of Bitmap data
    ' Always File Header len(14) + BITMAPINFOHEADER len(40)
    CopyMemory arrayOLE(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
    
    
    FileExtension = "bmp"
    sExt = "bmp"
End If

fGetContentsStream = True

Exit Function
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''


Case "Package"
' Copy of original file exists.
' Please note all string values are terminated with the NULL char(0).
' Standard OLE wrapper but it is always the same size
' because the Class name and Object name are always "Package".
' 36 Bytes Access OLE Header wrapper.

' The following 28 Bytes are private header data
' This brings us to offset 64.
' Here is another part of the header info. The first 4 bytes
' are the size of the package, including padding.

' The next two bytes are always the integer value of 2.
' I'll guess this is a constant value for embedded Packages.

' The next X bytes are a copy of the original file name, including
' teminating NULL character.

' The next X bytes are a copy of the original file name including
' path and teminating NULL character.
'
'
' The next 4 bytes are unknown values. This Long value always seems to be 3.

' The next 2 bytes, an Integer, contain the length of string
' immediately to follow, which is a copy of the path string above.

' The next X bytes are a copy of the original file name including
' path and teminating NULL character.


' The next 4 bytes, a Long, contain the actual file size of the original
' embedded file.

' The next x bytes contain the file that was originally embedded. This is an exact
' copy of the original file.


' Start of Package header
lPos = 64
' Skip nexy 4 bytes - Package size including padding
lPos = lPos + 4
' Skip next 2 bytes - Embedded constant - 2 ?
lPos = lPos + 11

' Checking for 0 so must initialize to any value but 0.
bCurValue = 1

' Package original File Name
Do While bCurValue <> 0
    bCurValue = arrayOLE(lPos)
    FileNamePackage = FileNamePackage & Chr(bCurValue)
    lPos = lPos + 1
Loop

bCurValue = 1
' Package original full path and File Name
Do While bCurValue <> 0
    bCurValue = arrayOLE(lPos)
    FileNameandPathPackage = FileNameandPathPackage & Chr(bCurValue)
    lPos = lPos + 1
Loop

' Unknown 4 bytes
lPos = lPos + 4

' Integer - number of bytes of following string
' which contains fill path and filename
CopyMemory iOffset, arrayOLE(lPos), 2

' Jump over our iOffset
lPos = lPos + 2

' Jump over 2 bytes - Unknown
lPos = lPos + 2

' Jump over string
lPos = lPos + iOffset

' Grab complete size of embedded file
CopyMemory lPackSize, arrayOLE(lPos), 4

' Jump over lPacksize Offset
lPos = lPos + 4

' Resize to fit embedded file
' Error check
If lPackSize >= UBound(arrayOLE) Then
    fGetContentsStream = False
    Exit Function
End If

ReDim arrayB(0 To lPackSize - 1)

' I just have never trusted overlapping memory locations
CopyMemory arrayB(0), arrayOLE(lPos), lPackSize
ReDim arrayOLE(0 To lPackSize - 1)
arrayOLE = arrayB
FileExtension = "pak"
sExt = "pak"
fGetContentsStream = True

Exit Function
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''


Case "HP.Desk"
' Scan HP DeskScan.2
sExt = "hpd"
sStreamName = "Ole10Native"
FileExtension = "bmp"
''''''''''''''''''''''''''''''''''''''''''


Case "Visio.D"
' MS Word document
sExt = "vsd"
sStreamName = "VisioDocument"
FileExtension = "vsd"
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''

Case "Paint.P"   'Paint.Picture
sExt = "bmp"
FileExtension = "bmp"

sStreamName = ""
' Save off Bitmap file so we can simply exit
' and return the original data minus the
' Access OLE header and the 12 byte Checksum.

' Delete Access OLE wrapper
y = objHeader.HeaderSize + 31
'copy back minus header and checksum
For x = 0 To UBound(arrayOLE) - (objHeader.HeaderSize + 31)
    arrayOLE(x) = arrayOLE(y)
    y = y + 1
Next x

' Get Total Size.
' For PaintBrushBitmap files it is an actual Disk based Bitmap file
' not the MS Photo Editor private Bitmap or the PSP entire file.
' It is the 3rd through 6th bytes that form the LONG value representing the
' complete file size for the Bitmap.

CopyMemory x, arrayOLE(2), 4

ReDim Preserve arrayOLE(0 To x - 1) As Byte

' Success!
fGetContentsStream = True
sExt = "bmp"
Exit Function
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

' Need more work on error logic
Case Else
' Not supported yet
Err.Raise vbObjectError + 566, "modGetContentsStream.fGetContentsStream", _
    "Sorry...this OLE object contains an unsupported format" & vbCrLf & _
    "Please select a different Record to Export"
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''
'fGetContentsStream = False
'sExt = ""
'Exit Function

End Select

' For any objects that we need to use the Structured Storage DLL's
' to retrieve the contents of the OLE object then we need to
' delete Access OLE wrapper of size objHeader.Size
' lOffSet var is previously filled in:
'lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
' MSPhotoEdScan.3 for some reason needs 4 bytes removed from
' its offset to start of Structured Storage SIG.
' I'll look in to it later and hardwire a fix for now.

If sClassName = "MSPhotoEdScan.3" Then lOffSet = lOffSet - 4
y = 0
For x = lOffSet To UBound(arrayOLE) - lOffSet
    arrayOLE(y) = arrayOLE(x)
    y = y + 1
Next x



'If sStreamName <> "CONTENTS" Then
'    ' Extract Office doc
'    lLen = ExtractOfficeDocument(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
'Else
'' Call our function in the StrStorage DLL
'    lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
'End If


' Need to log errors so that a Dialog is not popping up
' for every record that errors
If lLen = 0 Then
Err.Raise vbObjectError + 526, "modGetContentsStream.fGetContentsStream", _
    "Sorry...this OLE object does not have a CONTENTS Stream" & vbCrLf & _
    "Please select a different Record to Export"
    Exit Function
End If

' Resize our returned memory
ReDim Preserve arrayOLE(0 To lLen - 1) As Byte


' ***************************************************
'   DEBUG

'fGetContentsStream = True
'Exit Function


' ***************************************************


' Further processing is required for certain objects
Select Case sExt

' Add Visio etc.
Case "doc", "xls", "ppt", "vsd", "rtf"
' Do nothings as File Extension is already set.
' Also arrayOLE is ready to be saved to disk
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''


' PDF
Case "pdf", "snp"
' Do nothings as File Extension is already set.
' Also arrayOLE is ready to be saved to disk
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

' PDF
Case "tiff"
' Remove header of 234 bytes
' Remaining data ' is the complete TIFF file.
' lLen is length of CONTENTS stream returned in GetContentsStream
ReDim arrayB(0 To lLen - (234 + 1)) As Byte

CopyMemory arrayB(0), arrayOLE(234), lLen - (234 + 1)
ReDim arrayOLE(0 To lLen - (1 + 234)) As Byte
CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 234)

''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''



' PaperPort Document
' 64 ByteHeader needs to be removed
Case "max"
' Remove header of 64 bytes
' Remaining data ' is the complete Bitmap file.
' lLen is length of CONTENTS stream returned in GetContentsStream

' April 18/2008
' In some instances there is NO HEADER TO REMOVE
' Examine first 3 bytes. If equal to MAX FILE SIGNATURE then DO NOT remove header!!!

If arrayOLE(0) = 86 And arrayOLE(1) = 105 And arrayOLE(2) = 71 Then
' do nothing - DO NOT REMOVE HEADER

Else

    ReDim arrayB(0 To lLen - (64 + 1)) As Byte

    CopyMemory arrayB(0), arrayOLE(64), lLen - (64 + 1)
    ReDim arrayOLE(0 To lLen - (1 + 64)) As Byte
    CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 64)


End If
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''



' HP DeskScan stored as Bitmap
' Header needs to be removed
Case "hpd"
' Remove header of 4 bytes
' Remaining data ' is the complete Bitmap file.
' lLen is length of CONTENTS stream returned in GetContentsStream
ReDim arrayB(0 To lLen - (4 + 1)) As Byte

CopyMemory arrayB(0), arrayOLE(4), lLen - (4 + 1)
ReDim arrayOLE(0 To lLen - (1 + 4)) As Byte
CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 4)


''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

Case "psp"
' Paint Shop Pro
' CONTENTS stream is the complete PSP file
' plus an  Header we
FileExtension = "psp"
' Need to remove 36 Byte OLE/PSP header. Remaining data
' is the complete original PSP file.
' lLen is length of CONTENTS stream returned in GetContentsStream
ReDim arrayB(0 To lLen - 1) As Byte

CopyMemory arrayB(0), arrayOLE(36), lLen - 36
ReDim arrayOLE(0 To lLen - 1) As Byte
CopyMemory arrayOLE(0), arrayB(0), lLen - 1
'arrayOLE = arrayB

' Added functionality to remove padding at end of file.
' To calculate real PSP file size would involve basically
' having to build a PP reader to parse all of the
' blocks and their headers.
' We'll cheat instead. The extra padding is at the
' end of the fill and consists of all 0's.
  x = UBound(arrayOLE)
 
Do While arrayOLE(x) = 0
    x = x - 1
Loop

' Bug
' I canot remove all 0's at end of file
' because last byte could legally be 0.
' Let's leave the last 4 zero bytes
ReDim Preserve arrayOLE(0 To x + 4) As Byte
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''


Case "bmp" ' I need to build a disk based BMP file
' from the packed DIB contained in the array.
'MS Photo Editor
' CONTENTS stream returns a packed DIB. A Header specifies Bitmap Height and Width and
' Bits per pixel. At offset &h336 Dec822 BEGINS the Bitmap data. This offset is
' calculated as follows:
' 14 bytes FILEHEADER
' 40 bytes BITMAPINFOHEADER
' 768 bytes Color Table( 3 byte RGB triplet * 256)

' So above looks exactly like a standard disk based Bitmap file.
' Unfortuntately, it is not. First while the space is allocated
' for the FILEHEADER and BITMAPINFOHEADER structures, they do
' not contain valid data. For our purposes, only 3 values exist.
' Get MS Photo Editor CONTENTS Stream header - 18 Bytes
' The header contains the Image BitsperPixel, Width, Height
' I have only seen 2 values in the the BitsperPixel byte.
' 2 = 8 bits per pixel
' 1 = 24 bits per pixel(I think greyscale
' Jan/2006 Now I'm seeing a 3
' Perhaps this means 24 Bits but not DWORD aligned
'
' I need to test images of different BitsperPixel values.

Dim ph As MSPHOTOEDITOR_CONTENTS_HEADER
' Fill our header
CopyMemory ph, arrayOLE(0), Len(ph)


' Standard GDI Bitmap related structures
Dim MyBitmapInfoHeader As BITMAPINFOHEADER
Dim FileHeader As BITMAPFILEHEADER


' Length of physical ColorTable
' which is the number of RGBQUADS
' required to hold the required number of colors.
' Only used for Bit Depths less than 16 bits.
' Note: The MS Photo Editor CONTENTS stream packs the
' Color Table using 3 byte RGB triplets instead of the
' 4 byte RGBQUADs specified for a disk based Bitmap file.
Dim lngLenColorTable As Long

' Init to 0
lngLenColorTable = 0

' Number of bytes for each complete row of the bitmap
Dim BytesPerScanLine As Long

' Start filling in our Bitmap related structures
Debug.Print ph.bmBitDepth
With MyBitmapInfoHeader
If ph.bmBitDepth = 1 Then .biBitCount = 8
If ph.bmBitDepth = 2 Then .biBitCount = 8
If ph.bmBitDepth = 3 Then .biBitCount = 24

.biClrImportant = 0
.biClrUsed = 0
.biCompression = 0 'BI_RGB ' no compression
.biHeight = ph.bmHeight
.biWidth = ph.bmWidth
.biPlanes = 1
.biSize = Len(MyBitmapInfoHeader)

' Each pixel is comprised of 3 bytes, Red, Green & Blue(RGB).
' Each row of pixels must end on a memory address evenly divided by 4.
' This is commonly refered to as DWORD aligned.
BytesPerScanLine = (MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8) + 3) And &HFFFFFFFC

' Size of the Bitmap data only.
.biSizeImage = (BytesPerScanLine * Abs(MyBitmapInfoHeader.biHeight))   ' 0 ' 0 OK for BI_RGB(uncompressed)

' Most applications do not use these values
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
End With

' Calc color table size
If MyBitmapInfoHeader.biBitCount = 8 Then lngLenColorTable = 256 * 4
' It's residing as RGB triplets not Quads in arrayOLE. We must translate this to
' RGBQUAD to reside on disk.

    
' Fill in our Bitmap FileHeader.
With FileHeader
    ' Signature
    .bfType = &H4D42
    ' Size of entire Bitmap disk file.
    ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
    .bfSize = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable) + MyBitmapInfoHeader.biSizeImage
    ' Offset from start of file to start of Bitmap data
    .bfOffBits = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable)
End With


' ********************************************************
' Trouble with structure alignment padding
' Copy our structures to our output array.
' Because of VB structure alignment pading
' we have to be careful and fill the structure
' members individually.
' Signature
CopyMemory arrayOLE(0), FileHeader.bfType, 2
' Size of Bitmap file
CopyMemory arrayOLE(2), FileHeader.bfSize, 4
'CopyMemory arrayOLE(6), ByVal 0, 4
' Next 4 bytes Reserved
arrayOLE(6) = 0
arrayOLE(7) = 0
arrayOLE(8) = 0
arrayOLE(9) = 0
' Offset to start of Bitmap data
CopyMemory arrayOLE(10), FileHeader.bfOffBits, 4

' Must use second Byte array. Copying the Color Table is overwriting
' the start of the Bitmap data. The amount overwritten is equal to
' Len(FileHeader) + Len(MyBitmapInfoHeader)-18
' 18 bytes is the size of the private MS Photo Editor Header
' found at the very start of the CONTENTS Stream.
' Since the BM FileHeader = 14 Bytes and the BitmapInfoHeader
' = 40 bytes in length we need to move the Color Table and Bitmap data
' 54 - 18 = 36 bytes
' backwards in the current array. So we need to resize the array
' increasing by 36 bytes.


' Before we creating or Bitmap file we have an issue to resolve.
' MS Photo Editor stores the DIB as a Bottom UP DIB while most
' applications use Top Down and some apps will not even load Bottom Up format.
' Let's copy and mirror both the ColorTable and Bitmap data.


'***  BUG ***
' I have run into a file where the size of the
' CONTENTS stream did not equal a packed DIB layout
' FILEHEADER + BitmapInfoHeader + ColorTable + Bitmap data
' To get around this let's try resizing arrayOLE
' based on the BitmapInfoHeader.
'ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte

If lngLenColorTable > 0 Then
    CopyMemory arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), arrayOLE(18), 768 ' RGB TripletlngLenColorTable
End If


' Now move the existing data back starting at the ColorTable
' if any and the Bitmap data.
' We can use CopyMemory as it is masquerading as RtlMoveMemory
' Copy ColorTable(if any)and move Bitmap data back 256 bytes to
' allow for the Bitmap file spec of 4 bytes per pixel(RGBQUAD)
' for each entry in the ColorTable.

' * DWORD alignment issue. Bitmap data must be DWORD aligned. This simply
' means that each row of the Bitmap data must end on an address
' evenly divisable by 4. If it is not then you simply pad the row
' until it is. Since this is the MS published spec I just figured
' that MS Photo Editor would follow the spec. It does not.
' To get around this I will have to copy the data one row
' at a time from the OLE byte array.

Dim BPSLineNotAligned As Long
BPSLineNotAligned = MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8)


' Temp storage for copy of Bitmap data
ReDim arrayB(0 To (MyBitmapInfoHeader.biHeight * BPSLineNotAligned) - 1)
    
CopyMemory arrayB(0), arrayOLE(822), (MyBitmapInfoHeader.biHeight * BPSLineNotAligned)

' The offset to the start of the Byte RGB data from the start of the file.
lOffSet = FileHeader.bfOffBits

' Jan 5/2005 7:05 pm don't redim until after I copied arrayOLE to arrayB ********
ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte

' For every row of Bitmap
For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
    CopyMemory arrayOLE(lOffSet + (x * BytesPerScanLine)), _
    arrayB(UBound(arrayB) - ((x * BPSLineNotAligned) + BPSLineNotAligned - 1)), BPSLineNotAligned
Next x


' Is there a Color Table?
If lngLenColorTable <> 0 Then
    
    Dim r As Byte
    Dim b As Byte
    Dim g As Byte
    
    ' Need to fix RGB to BGR issue on RGB Triplet ColorTable data
    ReDim arrayB(0 To lngLenColorTable - 1)
    CopyMemory arrayB(0), arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), 768
    
    y = 0
    lOffSet = Len(FileHeader) + Len(MyBitmapInfoHeader)
    
    
    ' 2 Possiblities
    ' If ph.bmBitDepth = 2 then it's a normal Colortable
    ' If ph.bmBitDepth = 1 then it's a Greyscale Colortable
    ' which needs to be created
    If ph.bmBitDepth = 2 Then
    
        For x = 0 To 768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
            r = arrayB(x)
            g = arrayB(x + 1)
            b = arrayB(x + 2)
            arrayOLE(lOffSet + (y * 4)) = b
            arrayOLE(lOffSet + (y * 4) + 1) = g
            arrayOLE(lOffSet + (y * 4) + 2) = r
            arrayOLE(lOffSet + (y * 4) + 3) = 0
            y = y + 1
        Next x
    
    Else
        For x = 0 To 255 Step 1 '768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
            r = y 'arrayB(x)
            g = y 'arrayB(x + 1)
            b = y 'arrayB(x + 2)
            arrayOLE(lOffSet + (y * 4)) = b
            arrayOLE(lOffSet + (y * 4) + 1) = g
            arrayOLE(lOffSet + (y * 4) + 2) = r
            arrayOLE(lOffSet + (y * 4) + 3) = 0
            y = y + 1
        Next x
    
    
    End If
    
    
End If


' Copy BitmapInfoHeader
CopyMemory arrayOLE(Len(FileHeader)), MyBitmapInfoHeader, Len(MyBitmapInfoHeader)

' Sat 6:17pm
' Change RGB triplet data to Quad RGB.
' put backin to see if we can handle both 8 bit and 24 bit
If MyBitmapInfoHeader.biBitCount = 24 Then

    Dim rquad As RGBQUAD
    
    ' The Byte RGB data needs to be reversed to BGR
    lOffSet = FileHeader.bfOffBits
    
    ' For every row of Bitmap
    For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
        ' For each pixel(triplet of RGB values)
        For y = 0 To MyBitmapInfoHeader.biWidth - 1
            With rquad
                .rgbBlue = arrayOLE(lOffSet + (y * 3))
                .rgbRed = arrayOLE((y * 3) + 2 + lOffSet)
    
                ' Reverse B and R
                arrayOLE((y * 3) + lOffSet) = .rgbRed
                arrayOLE((y * 3) + 2 + lOffSet) = .rgbBlue
            End With
    
        ' increment 3 bytes per pixel is built into the above logic
        Next y
    
    ' increment bytes per row (3 bytes per pixel + padding to end up on DWORD alignment
    lOffSet = lOffSet + BytesPerScanLine
    Next x

End If
''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

Case Else
' Unsupported Format

''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''

End Select

' Success
fGetContentsStream = True


EXIT_fGetContentsStream:

' Add error handling

Exit Function

ERR_fGetContentsStream:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
fGetContentsStream = False
Resume EXIT_fGetContentsStream

End Function

窗体代码如下：

Option Compare Database
Option Explicit

Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" _
(ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

' The following function will attempt to
' extract and save the current OLE object to disk.
' It will also launch whatever Application is currently
' registered for this file type on your system.

Private Sub cmdSave_Click()
On Error GoTo Err_cmdSave_Click

Dim a() As Byte
Dim b() As Byte
Dim x As Long
Dim lTemp As Long
Dim sl As String
Dim blRet As Boolean
Dim sExt As String
Dim sFileExist As String

' This is an optional param we pass to fGetContentsStream.
' It will contain the original file name of the
' object when embedded as a Package.
Dim PackageFileName As String

Dim iFileHandle As Integer

lTemp = LenB(Me.OLEPic.Value)
ReDim a(0 To lTemp - 1)
ReDim b(0 To lTemp - 1)

' Copy the contents of the OLE field to our byte array
a = Me.OLEPic.Value

' Make a copy of the original data
b = a

blRet = fGetContentsStream(a(), sExt, PackageFileName)
If blRet = True Then

    If sExt = "pak" Then
        ' If a file was dragged from the Explorer window
        ' it will have a Package object Filename of NULL
        ' inserted by Shell.DLL
        ' Catch and give a temp file name
        If Len(PackageFileName & vbNullString) < 3 Then
                    PackageFileName = "OLE-ExtractDraggedFromExplorer" & "." & "bmp"
        End If
        
        iFileHandle = FreeFile
        sl = "H:\" & PackageFileName
        sFileExist = Dir(sl)
        If Len(sFileExist & vbNullString) > 0 Then
            Kill sl
        End If
        
        Open sl For Binary Access Write As iFileHandle
        Put iFileHandle, , a
        Close iFileHandle
    Else
    
        iFileHandle = FreeFile
        sl = "H:\" & sExt & UBound(a)
        '& "." & sExt
        sFileExist = Dir(sl)
        If Len(sFileExist & vbNullString) > 0 Then
         Kill sl
        End If
        Open sl For Binary Access Write As iFileHandle
        Put iFileHandle, , a
        Close iFileHandle
    End If
    
    
    Dim StartRegisteredApp As Boolean
    
    'StartRegisteredApp = True
    ' Do we open the exported OLE object in the
    ' Application registered for this file type on this system?
    If StartRegisteredApp = True Then
    ' Some apps require vbNullString for the first parameter,
    ' other apps require "open" for the first parameter
     ShellExecuteA Application.hWndAccessApp, vbNullString, sl, vbNullString, vbNullString, 1
    End If '                                    "open"
End If

' Below is for debugging.

'iFileHandle = FreeFile
'sl = "C:\OLE-field-ALL" & ".dat"
'sFileExist = Dir(sl)
'If Len(sFileExist & vbNullString) > 0 Then
' Kill sl
'End If
'
'Open sl For Binary Access Write As iFileHandle
'Put iFileHandle, , b
'Close iFileHandle
'
'iFileHandle = FreeFile
'sl = "C:\OLE-field-CONTENTS" & ".dat"
'sFileExist = Dir(sl)
'If Len(sFileExist & vbNullString) > 0 Then
' Kill sl
'End If
'
'Open sl For Binary Access Write As iFileHandle
'Put iFileHandle, , a
'Close iFileHandle

Exit_cmdSave_Click:
' Release structured storage library
    Exit Sub

Err_cmdSave_Click:
    MsgBox Err.Description
    Resume Exit_cmdSave_Click

End Sub

类模块代码如下：

Option Compare Database
Option Explicit


Private Type RECT
    Left As Long
    top As Long
    right As Long
    Bottom As Long
End Type

Private Type SIZEL
    cx As Long
    cy As Long
End Type

Private Type ENHMETAHEADER
        iType As Long
        nSize As Long
        rclBounds As RECT
        rclFrame As RECT
        dSignature As Long
        nVersion As Long
        nBytes As Long
        nRecords As Long
        nHandles As Integer
        sReserved As Integer
        nDescription As Long
        offDescription As Long
        nPalEntries As Long
        szlDevice As SIZEL
        szlMillimeters As SIZEL
End Type


Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgblReterved As Byte
End Type


'Private Enum ERGBCompression
 Private Const BI_RGB = 0&
  Private Const BI_RLE4 = 2&
  Private Const BI_RLE8 = 1&
  Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
'End Enum


Private Type BITMAPINFOHEADER '40 bytes
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long 'ERGBCompression
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type


Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type


Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Type DIBSECTION
    dsBm As BITMAP
    dsBmih As BITMAPINFOHEADER
    dsBitfields(2) As Long
    dshSection As Long
    dsOffset As Long
End Type

Private Type METAFILEPICT
 mm As Long
 xExt As Long
 yExt As Long
 hMF As Long
End Type

' From winuser.h
Private Const IMAGE_BITMAP = 0
Private Const IMAGE_ICON = 1
Private Const IMAGE_CURSOR = 2
Private Const IMAGE_ENHMETAFILE = 3

Private Const LR_DEFAULTCOLOR = &H0
Private Const LR_MONOCHROME = &H1
Private Const LR_COLOR = &H2
Private Const LR_COPYRETURNORG = &H4
Private Const LR_COPYDELETEORG = &H8
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADTRANSPARENT = &H20
Private Const LR_DEFAULTSIZE = &H40
Private Const LR_VGACOLOR = &H80
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const LR_CREATEDIBSECTION = &H2000
Private Const LR_COPYFROMRESOURCE = &H4000
Private Const LR_SHARED = &H8000

Private Const vbSrcCopy = &HCC0020
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE
Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK

' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBmp As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, ByVal lpvBits As Long, ByRef lpbi As BITMAPINFO, ByVal uUsage As Long) As Long
Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInstance As Long, ByVal Name As Long, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
Private Declare PtrSafe Function apiGetObject Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)

Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" _
Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long

' Create an Information Context
Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long

Private Declare PtrSafe Function apiPlayEnhMetaFile Lib "gdi32" Alias "PlayEnhMetaFile" (ByVal hdc As Long, ByVal hEMF As Long, lpRect As RECT) As Long

'Private Declare PtrSafe Function SetWinMetaFileBits Lib "gdi32" _
'(ByVal cbBuffer As Long, lpbBuffer As Byte, _
'ByVal hdcRef As Long, lpmfp As METAFILEPICT) As Long

Private Declare PtrSafe Function SetWinMetaFileBits Lib "gdi32" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As LongPtr, lpmfp As METAFILEPICT) As LongPtr


Private Declare PtrSafe Function apiDeleteEnhMetaFile Lib "gdi32" Alias "DeleteEnhMetaFile" _
(ByVal hEMF As Long) As Long

Private Declare PtrSafe Function apiCloseEnhMetaFile Lib "gdi32" Alias "CloseEnhMetaFile" _
(ByVal hdc As Long) As Long

Private Declare PtrSafe Function GetEnhMetaFileHeader Lib "gdi32" _
(ByVal hEMF As Long, ByVal cbBuffer As Long, lpemh As ENHMETAHEADER) As Long

Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" _
  Alias "DeleteDC" (ByVal hdc As Long) As Long
  
Private Declare PtrSafe Function apiCreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" _
    (ByVal crColor As Long) As Long

Private Declare PtrSafe Function apiFillRect Lib "user32" Alias "FillRect" _
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long


' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14

'  Device Parameters for GetDeviceCaps()
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y

' Handle to the current DIBSection:
Private m_hDib As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_bmi As BITMAPINFO
' Holds current JPEG's FileName
Private m_CurrentJpegFileName As String
' Array to hold original compressed Jpeg
' to be used for BLOB storage in Table
Private bArray() As Byte

' Temp var
Dim lngRet As Long



Public Function CreateDIB( _
  ByVal lhdc As Long, _
  ByVal lWidth As Long, _
  ByVal lHeight As Long, _
  ByVal lChannels As Long, _
  ByRef hDib As Long _
  ) As Boolean
   
  With m_bmi.bmiHeader
    .biSize = Len(m_bmi.bmiHeader)
    .biWidth = lWidth
    .biHeight = lHeight
    .biPlanes = 1
    If lChannels = 3 Then
      .biBitCount = 24
    Else
      .biBitCount = 32
    End If
    .biCompression = BI_RGB
    .biSizeImage = BytesPerScanLine * .biHeight
  End With
  
  'The m_lPtr is passed in byref.. so that it returns the the pointer to the bitmapinfo bits
  'the m_lptr is then stored as a reference to the uncompressed image data
  'the m_lptr is filled with image data when the ijlread method is invoked.
  hDib = CreateDIBSection(lhdc, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
  
  CreateDIB = (hDib <> 0)

End Function


Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long, Optional ByVal lChannels As Long = 3) As Boolean
  
  CleanUp
  
  m_hDC = CreateCompatibleDC(0)
  
  If (m_hDC <> 0) Then
    If (CreateDIB(m_hDC, lWidth, lHeight, lChannels, m_hDib)) Then
      m_hBmpOld = SelectObject(m_hDC, m_hDib)
      Create = True
    Else
      Call DeleteObject(m_hDC)
      m_hDC = 0
    End If
  End If

End Function


Public Function Load(ByVal Name As String) As Boolean
  Dim hBmp As Long
  Dim pName As Long
  Dim aName As String

  Load = False

  CleanUp

  m_hDC = CreateCompatibleDC(0)
  If m_hDC = 0 Then
    Exit Function
  End If

  aName = StrConv(Name, vbFromUnicode)
  pName = StrPtr(aName)

  hBmp = LoadImage(0, pName, IMAGE_BITMAP, 0, 0, (LR_CREATEDIBSECTION Or LR_LOADFROMFILE))
  If hBmp = 0 Then
    Call DeleteObject(m_hDC)
    m_hDC = 0
    MsgBox "Can't load BMP image"
    Exit Function
  End If

  m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)

  ' get image sizes
  Call GetDIBits(m_hDC, hBmp, 0, 0, 0, m_bmi, DIB_RGB_COLORS)

  ' make 24 bpp dib section
  m_bmi.bmiHeader.biBitCount = 24
  m_bmi.bmiHeader.biCompression = BI_RGB
  m_bmi.bmiHeader.biClrUsed = 0
  m_bmi.bmiHeader.biClrImportant = 0
  
  m_hDib = CreateDIBSection(m_hDC, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
  If m_hDib = 0 Then
    Call DeleteObject(hBmp)
    Call DeleteObject(m_hDC)
    m_hDC = 0
    Exit Function
  End If

  m_hBmpOld = SelectObject(m_hDC, m_hDib)

  m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)

  ' get image data in 24 bpp format (convert if need)
  Call GetDIBits(m_hDC, hBmp, 0, m_bmi.bmiHeader.biHeight, m_lPtr, m_bmi, DIB_RGB_COLORS)

  Call DeleteObject(hBmp)

  Load = True

End Function


Public Property Get BytesPerScanLine() As Long
  ' Scans must align on dword boundaries:
  BytesPerScanLine = (m_bmi.bmiHeader.biWidth * (m_bmi.bmiHeader.biBitCount / 8) + 3) And &HFFFFFFFC
End Property


Public Property Get dib_width() As Long
  dib_width = m_bmi.bmiHeader.biWidth
End Property


Public Property Get dib_height() As Long
  dib_height = m_bmi.bmiHeader.biHeight
End Property


Public Property Get dib_channels() As Long
  dib_channels = m_bmi.bmiHeader.biBitCount / 8
End Property

Public Property Get CurrentJpegFileName() As String
CurrentJpegFileName = m_CurrentJpegFileName
End Property

Public Sub PaintPicture( _
  ByVal lhdc As Long, _
  Optional ByVal lDestLeft As Long = 0, _
  Optional ByVal lDestTop As Long = 0, _
  Optional ByVal lDestWidth As Long = -1, _
  Optional ByVal lDestHeight As Long = -1, _
  Optional ByVal lSrcLeft As Long = 0, _
  Optional ByVal lSrcTop As Long = 0, _
  Optional ByVal eRop As Long) ' = vbSrcCopy)

  If (lDestWidth < 0) Then lDestWidth = m_bmi.bmiHeader.biWidth
  If (lDestHeight < 0) Then lDestHeight = m_bmi.bmiHeader.biHeight
Dim lngRet As Long
  lngRet = BitBlt(lhdc, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)
'lngRet = BitBlt(lhDC, lDestLeft, lDestTop, 640, 480, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)

End Sub

Public Function LoadJpegFileIntoArray() As Boolean

On Error GoTo Err_CmdLoad_Click

Dim blRet As Boolean

 ' jpg_scale = 1
  Dim strfName As String
  strfName = Me.CurrentJpegFileName  ' m_cDib.FileDialog 'c:\test2.jpg"
  ' Read JPEG image
 
Dim lPtr As Long
Dim lSize As Long
Dim iFile As Integer
Dim sFile As String
'Dim bArray() As Byte
    
   ' Copy the current Jpeg file data directly to the buffer
   iFile = FreeFile
   Open strfName For Binary Access Read Lock Write As #iFile
   lSize = LOF(iFile)
   ReDim bArray(0 To lSize - 1) As Byte
   Get #iFile, , bArray()
   Close #iFile
   
      
    LoadJpegFileIntoArray = True
Exit_CmdLoad_Click:
    Exit Function

Err_CmdLoad_Click:
LoadJpegFileIntoArray = False
    MsgBox Err.Description
    Resume Exit_CmdLoad_Click
    
End Function


Public Property Get JPegAsByteArray() As Variant
JPegAsByteArray = bArray

End Property

Public Property Get hdc() As Long
  hdc = m_hDC
End Property


Public Property Get hDib() As Long
  hDib = m_hDib
End Property


Public Property Get DIBSectionBitsPtr() As Long
  DIBSectionBitsPtr = m_lPtr
End Property


Public Function DIBtoPictureData(ctl As Control)
 Dim lngRet As Long
 Dim ds As DIBSECTION
     
     lngRet = apiGetObject(hDib, Len(ds), ds)
     
    '.bfSize = Len(FileHeader) + Len(ds.dsBmih) + ds.dsBmih.biSizeImage
        
    ' Update the Image Control display
    ' We do this by simply copying the mBitmapAdd's contents to
    ' the control's PictureData prop
    
    Dim varTemp() As Byte
    ReDim varTemp(ds.dsBmih.biSizeImage + 40)
    apiCopyMemory varTemp(40), ByVal Me.DIBSectionBitsPtr, ds.dsBmih.biSizeImage
    apiCopyMemory varTemp(0), ds.dsBmih, 40
    
     ctl.PictureData = varTemp


End Function

Public Sub CleanUp()
  
  If (m_hDC <> 0) Then
    If (m_hDib <> 0) Then
      Call SelectObject(m_hDC, m_hBmpOld)
      Call DeleteObject(m_hDib)
    End If
    Call DeleteObject(m_hDC)
  End If
  
  m_hDC = 0
  m_hDib = 0
  m_hBmpOld = 0
  m_lPtr = 0

  m_bmi.bmiColors.rgbBlue = 0
  m_bmi.bmiColors.rgbGreen = 0
  m_bmi.bmiColors.rgbRed = 0
  m_bmi.bmiColors.rgblReterved = 0
  m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
  m_bmi.bmiHeader.biWidth = 0
  m_bmi.bmiHeader.biHeight = 0
  m_bmi.bmiHeader.biPlanes = 0
  m_bmi.bmiHeader.biBitCount = 0
  m_bmi.bmiHeader.biClrUsed = 0
  m_bmi.bmiHeader.biClrImportant = 0
  m_bmi.bmiHeader.biCompression = 0

End Sub


Private Sub Class_Terminate()
  CleanUp
End Sub


Public Function FileDialog(LoadSave As Boolean) As String
' Calls the API File Dialog Window
' Returns full path to new File.
' If LoadSave = TRUE then call File Load Dialog

On Error GoTo Err_fFileDialog

' Call the File Common Dialog Window
Dim clsDialog As Object
Dim strTemp As String
Dim strfName As String

Set clsDialog = New clsCommonDialog

' Fill in our structure
' I'll leave in how to select Jpeg to
' show you how to build the Filter
clsDialog.Filter = "JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Jpe (*.JPE)" & Chr$(0) & "*.JPE" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "Jpeg (*.JPEG)" & Chr$(0) & "*.JPEG" & Chr$(0)
clsDialog.Filter = clsDialog.Filter & "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)

'clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)


If LoadSave Then
' Display the Open File Dialog
clsDialog.DialogTitle = "Please Select a JPEG File to Load"
clsDialog.ShowOpen
Else
clsDialog.DialogTitle = "Please Enter/Select a FileName to save the JPEG File"
clsDialog.ShowSave
End If

' See if user clicked Cancel or even selected
' the very same file already selected
strfName = clsDialog.FileName
If Len(strfName & vbNullString) = 0 Then
Set clsDialog = Nothing
Exit Function
'' Raise the exception
 ' Err.Raise vbObjectError + 513, "clsPrintToFit.fFileDialog", _
 ' "Please type in a Name for a New File"
End If

' Return File Path and Name
FileDialog = strfName
' Update our property
m_CurrentJpegFileName = strfName

Exit_fFileDialog:

Err.Clear
Set clsDialog = Nothing
Exit Function

Err_fFileDialog:
FileDialog = ""
m_CurrentJpegFileName = ""
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
Resume Exit_fFileDialog

End Function



Public Function WMFtoBMP(bWMF() As Byte, mm As Long, xExt As Long, yExt As Long) As Boolean
Dim hEMF As LongPtr
Dim lngIC As Long

' Instance of EMF Header structure
 Dim mh As ENHMETAHEADER
 
' Current Screen Resolution
Dim lngXdpi As Long
Dim lngYdpi As Long

' Used to convert Metafile dimensions to pixels
Dim sngConvertX As Single
Dim sngConvertY As Single
Dim sngMetaResolutionX As Single
Dim sngMetaResolutionY As Single

Dim rc As RECT

Dim mfp As METAFILEPICT


' Init our vars
  CleanUp

' Convert EMF byte array to memory EMF
With mfp
    .hMF = 0
    .mm = mm
    .xExt = xExt
    .yExt = yExt
End With

hEMF = SetWinMetaFileBits(UBound(bWMF) + 1, bWMF(0), 0&, mfp)
If hEMF = 0 Then
    'Call DeleteObject(m_hDC)
    'm_hDC = 0
    WMFtoBMP = False
    Exit Function
End If

' Convert EMF size to pixels
'
lngRet = GetEnhMetaFileHeader(hEMF, Len(mh), mh)
If lngRet = 0 Then
    WMFtoBMP = False
    Exit Function
End If

With mh.rclFrame
    ' The rclFrame member Specifies the dimensions,
    ' in .01 millimeter units, of a rectangle that surrounds
    ' the picture stored in the metafile.
    ' I'll show this as seperate steps to aid in understanding
    ' the conversion process.
    
' Convert to MM
sngConvertX = (.right - .Left) * 0.01
sngConvertY = (.Bottom - .top) * 0.01
 End With
 
' Convert to CM
sngConvertX = sngConvertX * 0.1
sngConvertY = sngConvertY * 0.1
' Convert to Inches
sngConvertX = sngConvertX / 2.54
sngConvertY = sngConvertY / 2.54


' Get current Screen DPI
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
'If the call to CreateIC didn't fail, then get the Screen X resolution.
If lngIC <> 0 Then
    lngXdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
    lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
    'Release the information context.
    apiDeleteDC (lngIC)
Else
    ' Something has gone wrong. Assume an average value.
    lngXdpi = 120
    lngYdpi = 120
End If

' Convert the szlMillimeters to inches. This member
' Specifies the resolution of the reference device, in millimeters.
' Convert Inches to Pixels
'sngMetaResolutionX = (mh.szlMillimeters.cx * 0.01) / 2.54
sngMetaResolutionX = (mh.szlDevice.cx / ((mh.szlMillimeters.cx * 0.1) / 2.54))
sngMetaResolutionY = (mh.szlDevice.cy / ((mh.szlMillimeters.cy * 0.1) / 2.54))

Create CLng(sngConvertX * sngMetaResolutionX), CLng(sngConvertY * sngMetaResolutionY)

' **********************
' I have seen cases where the xExt and yExt values are not correct.
' I may consider playing the MWF into an EMF DC so that
' I could allow the GDI to determine the
' actual extents of the Image. Next revision.


' Case CF_ENHMETAFILE
 ' If it is an Enhanced Metafile then we
 ' Need to  "PLAY" the Metafile
 ' back into the Device COntext instead
 ' of using the SelectObject API

rc.top = 0
rc.Left = 0
rc.Bottom = m_bmi.bmiHeader.biHeight
rc.right = m_bmi.bmiHeader.biWidth
lngRet = apiPlayEnhMetaFile(m_hDC, hEMF, rc)
 
' Delete the EMF
lngRet = apiDeleteEnhMetaFile(hEMF)

' Resize array
GetDIBBytes bWMF()
    
'// Success
WMFtoBMP = True
End Function



Public Function GetDIBBytes(bBytes() As Byte)
Dim lngRet As Long
Dim lSize As Long
 
 
lSize = m_bmi.bmiHeader.biSizeImage - 1
ReDim bBytes(0 To lSize) As Byte

apiCopyMemory bBytes(0), ByVal m_lPtr, m_bmi.bmiHeader.biSizeImage
        
End Function

可实现的功能如下：

 点击保存后，可以将粘贴在OLE对象框内的图像保存在本地