2
我有一个包含约5000条记录的访问数据库，每个数据库都有一个bmp作为OLE存储在数据库中。我使用Lebans OLEtoDisk，http://www.lebans.com/oletodisk.htm，用文件路径替换对象，但是，代码只能读取约150条记录，然后出现“内存不足”错误。我无法弄清楚什么堵塞了记忆。 OLEtoDisk函数使用剪贴板，但每次记录后我都清除它。任何人有任何想法，或者只是一种方法来清除所有的内存？VBA内存不足
这是我使用的代码。首先是命令按钮单击事件：
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: [email protected]
'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: [email protected]
'* 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
我已经将问题缩小到剪贴板未正确清理。我已经尝试了一堆来自各地的不同代码，但没有任何工作。 – DasPete