2

我有一个包含大约 5000 条记录的访问数据库,每条记录都有一个 bmp 作为 OLE 存储在数据库中。我正在使用 Lebans OLEtoDisk,http://www.lebans.com/oletodisk.htm,用文件路径替换对象,但是,代码只能通过大约 150 条记录,然后我得到一个错误“内存不足。” 我无法弄清楚是什么阻塞了内存。OLEtoDisk 函数使用剪贴板,但我在每次记录后清除它。任何人都有任何想法,或者只是一种清除所有记忆的方法?

这是我正在使用的代码。首先是命令按钮点击事件:

Option Compare Database
Option Explicit

Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long

Sub EmptyClipboard()
    Call apiOpenClipboard(0&)
    Call apiEmptyClipboard
    Call apiCloseClipboard
End Sub


Private Sub cmdCreateIPicture_Click()
DoCmd.SetWarnings False
' *********************
' You must set a Reference to: "OLE Automation" for this function to work. Goto the Menu and select Tools->References
' Scroll down to: Ole Automation and click in the check box to select this reference.

Dim lngRet, lngBytes, hBitmap As Long
Dim hpix As IPicture
Dim intRecordCount As Integer

intRecordCount = 0
Me.RecordsetClone.MoveFirst
Do While Not Me.RecordsetClone.EOF
    If intRecordCount Mod 25 = 0 Then
        EmptyClipboard
        DoEvents
        Excel.Application.CutCopyMode = False
        Debug.Print "cleared"
    End If
    Me.Bookmark = Me.RecordsetClone.Bookmark
    Me.OLEBound19.SetFocus
    DoCmd.RunCommand acCmdCopy
    hBitmap = GetClipBoard
    Set hpix = BitmapToPicture(hBitmap)
    SavePicture hpix, "C:\Users\PHammett\Images\" & intRecordCount & ".bmp"
    DoCmd.RunSQL "INSERT INTO tblImageSave2 (newPath,oldPath) VALUES (""C:\Users\PHammett\Images\" & intRecordCount & """,""" & Me.RecordsetClone!Path & """);"
    apiDeleteObject (hBitmap)
    Set hpix = Nothing
    EmptyClipboard
    Me.RecordsetClone.MoveNext
    intRecordCount = intRecordCount + 1
Loop
DoCmd.SetWarnings True
End Sub

这是驻留在模块中的代码

Option Compare Database
Option Explicit

Private Const vbPicTypeBitmap = 1

Private Type IID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PictDesc
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As IID, ByVal fPictureOwnsHandle As Long, Ipic As IPicture) As Long

'windows API function declarations
'does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatVailable Lib "user32" (ByVal wFormat As Integer) As Long

'open the clipbarod to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'empty the keyboard
Private Declare Function EmptyClipboard Lib "user32" () As Long

'close the clipobard
Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function CopyEnhMetaFila Lib "gdi32" Alias "CopyEnhMetaFilaA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP

Public Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = 0&) As IPictureDisp
    'Copyr ight: Lebans Holdings 1999 Ltd.
    '           May not be resold in whole or part. Please feel
    '           free to use any/all of this code within your
    '           own application without cost or obligation.
    '           Please include the one line Copyright notice
    '           if you use this function in your own code.
    '
    'Name:      BitmapToPicture &
    '           GetClipBoard
    '
    'Purpose:   Provides a method to save the contents of a
    '           Bound or Unbound OLE Control to a Disk file.
    '           This version only handles BITMAP files.
    '           '
    'Author:    Stephen Lebans
    'Email:     Stephen@lebans.com
    'Web Site:  www.lebans.com
    'Date:      Apr 10, 2000, 05:31:18 AM
    '
    'Called by: Any
    '
    'Inputs:    Needs a Handle to a Bitmap.
    '           This must be a 24 bit bitmap for this release.
    Dim lngRet As Long
    Dim Ipic As IPicture, picdes As PictDesc, iidIPicture As IID

    picdes.Size = Len(picdes)
    picdes.Type = vbPicTypeBitmap
    picdes.hBmp = hBmp

    picdes.hPal = hPal
    iidIPicture.Data1 = &H7BF80980
    iidIPicture.Data2 = &HBF32
    iidIPicture.Data3 = &H101A
    iidIPicture.Data4(0) = &H8B
    iidIPicture.Data4(1) = &HBB
    iidIPicture.Data4(2) = &H0
    iidIPicture.Data4(3) = &HAA
    iidIPicture.Data4(4) = &H0
    iidIPicture.Data4(5) = &H30
    iidIPicture.Data4(6) = &HC
    iidIPicture.Data4(7) = &HAB

    'create the picture from the bitmap handle
    lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, Ipic)
    Set BitmapToPicture = Ipic
End Function

Public Function GetClipBoard() As Long
    ' Adapted from original Source Code by:
    '* MODULE NAME:     Paste Picture
    '* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.
    '*                  15 November 1998
    '*
    '* CONTACT:         Stephen@BMSLtd.co.uk
    '* WEB SITE:        http://www.BMSLtd.co.uk
    Dim hClipBoard As Long
    Dim hBitmap As Long
    Dim hBitmap2 As Long

    hClipBoard = OpenClipboard(0&)

    If hClipBoard <> 0 Then
        hBitmap = GetClipboardData(CF_BITMAP)

        If hBitmap = 0 Then GoTo exit_error

        hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
        hClipBoard = EmptyClipboard
        hClipBoard = CloseClipboard

        GetClipBoard = hBitmap2
    End If

    Exit Function
exit_error:
    GetClipBoard = -1
End Function

Public Function ClearClipboard()
    EmptyClipboard
    CloseClipboard
End Function
4

1 回答 1

1

...但我在每条记录后清除它

在此代码之后尝试DoEvents 。

于 2013-01-18T17:55:35.150 回答