VBA running out of memory - ms-access

Question

I have an access database with about 5000 records and each has a bmp stored in the database as an OLE. I am using Lebans OLEtoDisk, http://www.lebans.com/oletodisk.htm, to replace the objects with a file path, however, the code can only get through about 150 records and then I get an error "out of memory." I cannot figure out what is clogging up the memory. The OLEtoDisk functions use the clipboard, but I clear it after every record. Anyone have any ideas, or maybe just a way to clear all memory?
Here is the code I am using. First is the command button click event:
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
Here is the code that resides in a module
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

Answer 1

...but I clear it after every record
Try DoEvents after this code.