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:
Most of the time the error happens the first time the code is run. The 'Out of memory' error occurs on this line...
Thanks in advance.
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
Last edited: