Out of Memory Error While Working With Clipboard (1 Viewer)

C

Cullihall

Registered User.
Local time
Today, 10:13
Joined
Oct 28, 2009
Messages
33
I'm attempting to save a screen shot of a form as a bitmap. My code works correctly sometimes but somethimes it doesn't. Here's the code:

Code: 
Option Compare Database
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, _
RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const CF_BITMAP = 2
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public strFormName As String
 
Public Function SaveBitmap()
Dim Hwnd As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid, acCtrlButton As Control
Dim strAppPath As String, strFileName As String, exportFlder As String, fullExportFlder As String
Dim curWkEnd As String
' Set variables
exportFlder = "\WRS Export"
' Get the application path
strAppPath = CurrentProject.Path
'Get the week ending date for current week
curWkEnd = DateAdd("d", -Weekday(Date) + 7, Date)
Select Case strFormName
Case "SkuCountMainForm"
' Set the folder variables
fullExportFlder = strAppPath & exportFlder & "\Sku Counts"
' Set the filename variable
strFileName = fullExportFlder & "\Sku Count " & Format(curWkEnd, "mm dd yy") & ".bmp"
Case "ICPerformanceForm"
' Open the form
DoCmd.OpenForm strFormName
' Set focus to the form detail
Forms!IcPerformanceForm.Form.FileCboBx.SetFocus
'Wait 2 seconds
Sleep (2000)
' Set the folder variables
fullExportFlder = strAppPath & exportFlder & "\PerfMetrics"
' Set the filename variable
strFileName = fullExportFlder & "\Performance Metrics " & Format(curWkEnd, "mm dd yy") & ".bmp"
End Select
'Close the hidden timer form
DoCmd.Close acForm, "DetectIdleTime", acSaveNo
' Check to see if the folders exist
If Dir(strAppPath & exportFlder, vbDirectory) = "" Then
MkDir (strAppPath & exportFlder) ' It does not exist so create the folder
End If
If Dir(fullExportFlder, vbDirectory) = "" Then
MkDir (fullExportFlder) ' It does not exist so create the folder
End If
' Check if the file exists and delete if it does
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(strFileName) Then
fs.DeleteFile strFileName
End If
' Hide the buttons before capturing screen shot
For Each acCtrlButton In Forms(strFormName).Controls
If acCtrlButton.ControlType = acCommandButton Then
'Skip if it's the active control because we can't set this attribute for the active control
If acCtrlButton.Caption = Forms(strFormName).ActiveControl.Caption Then
GoTo nextCtrl
End If
acCtrlButton.Visible = False
End If
nextCtrl:
Next acCtrlButton
Forms(strFormName).Repaint
'''''' Select the form
''''' DoCmd.SelectObject acForm, strFormName
keybd_event VK_MENU, 0, 0, 0 'press Alt
keybd_event VK_SNAPSHOT, 0, 0, 0 'press PrintScrn
'''''DoEvents
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0 'release it
OpenClipboard (0&) 'OpenClipboard
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = GetClipboardData(CF_BITMAP)
End With
 
DoEvents
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
 
' The file doesn't exist so name it normally
stdole.SavePicture IPic, strFileName
 
' Set the file attributes to hidden and protected system file
Dim f
Set f = fs.GetFile(strFileName)
f.Attributes = vbHidden
f.Attributes = f.Attributes + vbSystem
 
' Make the buttons visible again
On Error Resume Next
For Each acCtrlButton In Forms(strFormName).Controls
If acCtrlButton.ControlType = acCommandButton Then
'Skip if it's the active control because we can't set this attribute for the active control
If acCtrlButton.Caption = Forms(strFormName).ActiveControl.Caption Then
GoTo nextCtrl1
End If
acCtrlButton.Visible = True
End If
nextCtrl1:
Next acCtrlButton
'Wait 2 seconds
Sleep (2000)
' Close the form
If strFormName = "ICPerformanceForm" Then
DoCmd.Close acForm, strFormName
End If
'Open and hide the timer form
DoCmd.OpenForm "DetectIdleTime", acNormal, , , , acHidden
CloseClipboard
MsgBox "File saved as: " & strFileName, vbInformation + vbOKOnly
End Function

Most of the time the error happens the first time the code is run. The 'Out of memory' error occurs on this line...
Code: 
stdole.SavePicture IPic, strFileName

Thanks in advance.
 

Attachments

  • Example.mdb
    200 KB · Views: 365
Last edited:
T

tranchemontaigne

Registered User.
Local time
Today, 07:13
Joined
Aug 12, 2008
Messages
203
review your code and see if you have error handling in all your code modules. I've noticed that if a function or procedure terminates abnormally, MS Access doesn't always release memory. I have no guarantees that this will help in yoru particular cirumstance. As an aside, I've never figured out how to overcome this error with a recursive function that needs to call itself many many times.
________
Extreme vaporizer
 
Last edited:
C

Cullihall

Registered User.
Local time
Today, 10:13
Joined
Oct 28, 2009
Messages
33
tranchemontaigne said:
review your code and see if you have error handling in all your code modules. I've noticed that if a function or procedure terminates abnormally, MS Access doesn't always release memory. I have no guarantees that this will help in yoru particular cirumstance. As an aside, I've never figured out how to overcome this error with a recursive function that needs to call itself many many times.
Click to expand...

Thanks tranchemontaigne.

The code that will follow is the only code in the whole database.

Here's what I have found out.

If the clipboard is empty when the code runs, it actually does add the screen shot to the clipboard but it fails on the line:
stdole.SavePicture IPic, strFileName ' Save the file so it doesn't save the file.

After it fails, if I run the code again (now the clipboard isn't empty at the start), it adds the screen shot to the clipboard and saves the file as it should do.

I've cleaned up the code so now it contains only relevant to the issue.

Code: 
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, _
RefIID As Guid, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Const VK_MENU = &H12
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const CF_BITMAP = 2
Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
 
Public Function SaveBitmap()
Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid, strFileName As String
strFileName = "C:\Test.bmp" ' Set the filename variable
keybd_event VK_MENU, 0, 0, 0       'press Alt
keybd_event VK_SNAPSHOT, 0, 0, 0   'press PrintScrn
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0 'release it
OpenClipboard (0) ' Open the clipboard
With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
End With
With Pic
    .Size = Len(Pic)
    .Type = 1
    .hBmp = GetClipboardData(CF_BITMAP)
End With
 
DoEvents
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic ' Create the picture object
stdole.SavePicture IPic, strFileName ' Save the file
EmptyClipboard 'Empty the clipboard
CloseClipboard ' Close the clipboard
End Function

I would appreciate anybody's insight.
 
C

Cullihall

Registered User.
Local time
Today, 10:13
Joined
Oct 28, 2009
Messages
33
Hi. I'd like to let everyone know that I managed to find a work around for this issue. I'm not quite sure why this was necessary for it to work but here it is.

I changed the opening of the clipboard to be inside the 'With Pic' block.
I then added a msgbox that will ask the user to click 'OK'. When the user clicks ok, the code goes back and takes the screen shot again and then runs to the end.

Here's the working code:

Code: 
Public Function SaveBitmap()
Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As Guid, strFileName As String
Dim theCnt As Integer, theMsg As String
theCnt = 0
strFileName = "C:\Test.bmp" ' Set the filename variable.
startOver:
theCnt = theCnt + 1
keybd_event VK_MENU, 0, 0, 0                    'press Alt
keybd_event VK_SNAPSHOT, 0, 0, 0                'press PrintScrn
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0  'release it
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0      'release it
DoEvents
With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
End With
With Pic
Call OpenClipboard(0&)
    .Size = Len(Pic)
    .Type = 1
    .hBmp = GetClipboardData(CF_BITMAP)
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic ' Create the picture object
If theCnt = 1 Then
    theMsg = MsgBox("Click ok to save the file.", vbOKOnly + vbInformation)
    DoEvents
    If theMsg = 1 Then GoTo startOver
End If
On Error GoTo errorEncountered
stdole.SavePicture IPic, strFileName ' Save the file
errorEncountered:
If Err.Number <> 0 Then
MsgBox " Error# " & Err & " " & """" & Err.Description & """"
End If
Call EmptyClipboard ' Empty the clipboard
Call CloseClipboard ' Close the clipboard
End Function
 
You must log in or register to reply here.

Similar threads

S
Solved Save Screenshot to Table
Replies
13
Views
271
Spalle
S
S
Solved MS Access Navigationform moveable
Replies
1
Views
294
isladogs
isladogs
Gasman
Sorting Addresses etc
Replies
13
Views
406
ebs17
E
H
FTP blocking
Replies
6
Views
387
JaimeHeller
J
H
FTP to Upload documents
Replies
7
Views
642
Harris@Z
H

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Top Bottom