VBA 메모리가 부족합니다.

Question

약 5000 개의 레코드가있는 액세스 데이터베이스가 있고 각각 데이터베이스에 OLE로 저장된 bmp가 있습니다. 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 

Answer 1

에있는 코드입니다 ...하지만 난 모든 레코드

시도 후 그것을 취소 이 코드 뒤에 DoEvents.