How can I capture and save as a bitmap file an Access form 3

[mugginsjm]

Please help. How can I capture and save as a bitmap file an Access form. I need to output some text as an image file. I could screenshot a form with labels but how do you save the clipboard to file? VB can make use of picturebox but this is not supported in VBA..

 

[PHV]

You may paste it in a word document.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[mugginsjm]

I need to create an image file for use in a graphics environment.

 

[PHV]

You get graphic file when saving the word document as html.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[HenryAnthony]

Alt + Print Screen will put it on the clipboard.

 

[traingamer]

Then you can paste in into Paint or your choice of graphics programs and save as needed.

traingamer

 

[mugginsjm]

Thanks everybody but this all needs to be done automatically in code. The programme looks up some records, fills out some labels or textboxes on a form. Then by some means (probably using clipboard) automatically create a bitmap file to send up to a server. If it were possible I could generate a multiline text box if somehow I could translate it to a bitmap.

 

[HenryAnthony]

The way you posed your question it seemed like you did not want to do this in code. This was discussed a while ago but cannot find the post. The solution to storing an image in Access was a BLOB or binary large object. I know little about this other than you can search Microsoft or this forum for more info.

Best regards,

Henry

 

[HenryAnthony]

Here is a link to the article. Good luck!

http://support.microsoft.com/?kbid=103257

 

[mugginsjm]

I had a look at READ and WRITE BLOB. It would appear to be a method of transferring image files to and from access tables as binary data in an OLE field. I'm trying to translate text to a bitmap (programmatically) and save it as an external file.

 

[traingamer]

You can save reports as snapshots. I don't know about forms.

traingamer

 

[mugginsjm]

Unfortunately snapshots require a proprietary viewer. I need to output as bitmap.

 

[HenryAnthony]

Sorry. I am stumped
Not an unusual occurance
Good luck though!

 

[VBslammer]

You can use the GDI API functions to create a picture of any window you want. The tedious part is determining the screen resolution information and trying to output the picture with a small enough file size to prevent network lag or storage limitation issues.

Here's a quick hack that captures the entire screen, and outputs it to a bitmap file. I took several shortcuts to keep the example brief, but it shows some of the methods needed to work with GDI.

Note that Access Forms are difficult to dimension because they have different sections that have to be measured separately, not to mention the title bar height, etc. Pure VB forms have a ScaleHeight and ScaleWidth property that makes the process much simpler, so with Access it takes more API work to get a true RECT size for a form.

[green]'@---------------------- Declarations ------------------@[/green]

Private Const SRCCOPY = &HCC0020

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
    (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, _
   ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC _
   As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
   ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
   
[green]'@------------------------- Types ---------------------@[/green]
Private Type GUID
  Data1    As Long
  Data2    As Integer
  Data3    As Integer
  Data4(7) As Byte
End Type

Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

[green]'@------------------- Example Function ----------------@[/green]

Public Function OutputScreenToBitmap() As Boolean
On Error GoTo ErrHandler
  Dim hWnd As Long
  Dim hBmp As Long
  Dim hBmpPrev As Long
  Dim hDC As Long
  Dim hDCMem As Long
  Dim RetVal As Long
  Dim lngWide As Long
  Dim lngHigh As Long
  Dim Pic As PicBmp
  Dim IPic As IPicture    [green]'requires reference to "Standard OLE Types"[/green]
  Dim RefIID As GUID
  
  [green]' screen dimensions - this really needs to be determined
  ' using additional API methods. This is my screen depth[/green]
  lngWide = 1280
  lngHigh = 1024
  
  [green]' could also use the form's hWnd value to capture the
  ' active form and get its dimensions.[/green]
  hWnd = GetDesktopWindow()
  
  [green]' perform the screen capture[/green]
  hDC = GetDC(hWnd)
  hDCMem = CreateCompatibleDC(hDC)
  hBmp = CreateCompatibleBitmap(hDC, lngWide, lngHigh)
  hBmpPrev = SelectObject(hDCMem, hBmp)
  RetVal = StretchBlt(hDCMem, 0, 0, lngWide, lngHigh, hDC, 0, 0, lngWide, lngHigh, SRCCOPY)
  hBmp = SelectObject(hDCMem, hBmpPrev)
  
  [green]' populate structures needed for output to file[/green]
  With RefIID
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With

  With Pic
    .Size = Len(Pic)
    .Type = &H1
    .hBmp = hBmp
    .hPal = 0&
  End With

  [green]' create the picture and save to file as bitmap[/green]
  RetVal = OleCreatePictureIndirect(Pic, RefIID, 1, IPic)
  stdole.SavePicture IPic, "c:\screenshot.bmp"
  
  [green]' release resources[/green]
  RetVal = ReleaseDC(hWnd, hDC)
  RetVal = DeleteDC(hDC)

  OutputScreenToBitmap = True

ExitHere:
  Exit Function
ErrHandler:
  Debug.Print Err, Err.Description
  Resume ExitHere
End Function

You can probably find some class modules floating around the Internet that encapsulate most of the API work needed to improve this example. Microsoft has some examples of how to capture a screenshot of a form, but they use an outdated .dll file that doesn't even exist on newer operating systems (GDI is preferred now).

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[mugginsjm]

Thank you VBSlammer I appreciate very much your contribution. I had been chasing a solution involving class modules, but this is tidier, I think. Can you give me some pointers as to how to capture a particular form.

 

[VBslammer]

Instead of using the desktop's hWnd, you can get the active form using:
[tt]
Dim frm As Form

Set frm = Screen.ActiveForm
hWnd = frm.hWnd
[/tt]

Once you get the hWnd of the form, you can get its dimensions using:
[tt]
wide = frm.WindowWidth
high = frm.WindowHeight
[/tt]

...but you also have to compensate for the TwipsPerPixelX and TwipsPerPixelY of the screen resolution, as well as the caption bar height of the form, which isn't considered part of an Access form.

To get the screen info, you can use other API calls like these:

  lngDC = GetDC(HWND_DESKTOP)
    
  If lngDC <> 0 Then
    [green]' Find the number of pixels in both directions
    ' on the screen, (640x480, 800x600, 1024x768,
    ' 1280x1024?)[/green]

     ptScreen.x = GetSystemMetrics(SM_CXFULLSCREEN)
     ptScreen.y = GetSystemMetrics(SM_CYFULLSCREEN)
        
     [green]' Get the pixels/inch ratio, as well.[/green]
     ptDPI.x = GetDeviceCaps(lngDC, LOGPIXELSX)
     ptDPI.y = GetDeviceCaps(lngDC, LOGPIXELSY)
        
     ptTwipsPerPixel.x = 1440 / ptDPI.x
     ptTwipsPerPixel.y = 1440 / ptDPI.y
    
     [green]' Release the information context.[/green]
     Call ReleaseDC(HWND_DESKTOP, lngDC)
  End If

It may take some tial-and-error to get the dimensions perfectly, but you should be able to get in the ball park with these API calls.

VBSlammer

"You just have to know which screws to turn." - Professor Bob

 

[mugginsjm]

I'm nearly there with this project. Thanks a lot.

 

[VBslammer]

I found an easier way to capture the form & screen dimensions using the [tt]GetWindowRect()[/tt] API call, so I wrapped the whole solution up into a class module:

[green]'@--------------------------------------------------------------@
'@
'@  §lamKeys §oftware 2005® (VBSlammer)
'@
'@              :
'@  @FILENAME   :   -clsScreenShot.cls
'@  @CREATED    :   -2/20/2005 10:35:49 PM
'@  @PURPOSE    :   -Output a screenshot to file (Full Screen or Active Form)
'@              :
'@  @USAGE      :   Dim oScreenShot As New clsScreenShot
'@              :
'@              :   With oScreenShot
'@              :     .FilePath = "C:\"
'@              :     .FileName = "SampleBitmap1.bmp"
'@              :
'@              :     If .CaptureActiveForm = True Then
'@              :
'@              :       MsgBox .FullPath & " saved successfully!"
'@              :
'@              :     End If
'@              :   End With
'@              :
'@              :
'@  @REFERENCES :   -Standard OLE Types (OLEPro32.dll)
'@              :
'@  @NOTES      :   -Full Screen bitmaps may be in excess of 2MB in size.
'@              :   -If declared "WithEvents" the app can detect runtime
'@              :   -errors and receive notification of output status.
'@              :
'@  @NOTICE     :   -Open Source for public use - no warranty implied.
'@              :   -Include this header with distributed source.
'@              :
'@--------------------------------------------------------------@[/green]
Option Compare Database
Option Explicit

[green]'@----------------------- Constants ----------------------------@[/green]

Private Const SRCCOPY = &HCC0020
Private Const S_OK = &H0

[green]'@----------------------- Variables ----------------------------@[/green]

Private mstrFilePath As String
Private mstrFileName As String
Private mErrorStrings As ErrorStrings

[green]'@------------------------- Events -----------------------------@[/green]

Public Event ErrorOccurred(ByVal ErrNum As Long, ByVal strMsg As String)
Public Event PictureSaved(ByVal strFileName As String, ByVal lngSize As Long, _
                          ByVal shotType As ScreenShotTypes)

[green]'@--------------------- API Functions --------------------------@[/green]

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, _
    ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) 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 ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

[green]'@------------------------- Enums ------------------------------@[/green]

Public Enum ScreenShotTypes
  ActiveForm
  FullScreen
End Enum

Public Enum ScreenShotErrors
  InvalidDeviceContext
  InvalidPath
  NoBitBlt
  NoCreatePicture
  NoDeleteDC
  NoDeleteObject
  NoReleaseDC
  NoSelectObject
End Enum

[green]'@------------------------- Types ------------------------------@[/green]

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Type ErrorStrings
  InvalidDeviceContext As String
  InvalidPath As String
  NoBitBlt As String
  NoCreatePicture As String
  NoDeleteDC As String
  NoDeleteObject As String
  NoReleaseDC As String
  NoSelectObject As String
End Type

[green]'@---------------- Constructor / Destructor --------------------@[/green]

Private Sub Class_Initialize()
  [green]' set default path and filename[/green]
  mstrFilePath = CurrentProject.Path
  mstrFileName = "Screenshot.bmp"
  
  [green]' init error strings[/green]
  With mErrorStrings
    .InvalidDeviceContext = "Could not find a valid device context for: {%1}"
    .InvalidPath = "The chosen path is invalid: {%1}"
    .NoBitBlt = "The BitBlt() API function was not successful."
    .NoCreatePicture = "The OLECreatePictureIndirect() API function was not successful."
    .NoDeleteDC = "Could not delete the device context belonging to: {%1}"
    .NoDeleteObject = "Could not delete the object referenced by: {%1}"
    .NoReleaseDC = "Could not release the device context belonging to: {%1}"
    .NoSelectObject = "Could not select {%1} into memory."
  End With
End Sub

Private Sub Class_Terminate()
  [green]'destructor code here[/green]
End Sub

[green]'@----------------------- Properties ---------------------------@[/green]

Public Property Get FilePath() As String
  FilePath = mstrFilePath
End Property

Public Property Let FilePath(ByVal strFilePath As String)
  If Dir(strFilePath) = "" Then
    RaiseEvent ErrorOccurred(InvalidPath, Replace(mErrorStrings.InvalidPath, "{%1}", strFilePath))
  Else
    mstrFilePath = strFilePath
  End If
End Property

Public Property Get FileName() As String
  FileName = mstrFileName
End Property

Public Property Let FileName(ByVal strFileName As String)
  mstrFileName = strFileName
End Property

Public Property Get FullPath() As String
  FullPath = PathFix(FilePath, FileName)
End Property

[green]'@-------------------- Public Methods --------------------------@[/green]

Public Function CaptureActiveForm() As Boolean
  CaptureActiveForm = OutputToBitmap(ActiveForm)
End Function

Public Function CaptureFullScreen() As Boolean
  CaptureFullScreen = OutputToBitmap(FullScreen)
End Function

[green]'@------------------- Private Methods --------------------------@[/green]

Private Function OutputToBitmap(ByVal shotType As ScreenShotTypes) As Boolean
On Error GoTo ErrHandler
  Dim frm As Form
  Dim hWndDesktop As Long
  Dim hDC As Long
  Dim hDCMem As Long
  Dim hBitmap As Long
  Dim strFile As String
  Dim RetVal As Long
  Dim lngWide As Long
  Dim lngHigh As Long
  Dim picRect As RECT
  Dim Pic As PicBmp
  Dim IPic As IPicture    [green]'requires reference to "Standard OLE Types"[/green]
  Dim RefIID As GUID
  
  [green]' get the desktop handle and device context[/green]
  hWndDesktop = GetDesktopWindow()
  hDC = GetDC(hWndDesktop)
  
  [green]' get rectangle of requested type[/green]
  Select Case shotType
    Case ScreenShotTypes.ActiveForm
      [green]' reference active form[/green]
      Set frm = Screen.ActiveForm
      [green]' get the form's bounding rectangle[/green]
      Call GetWindowRect(frm.hWnd, picRect)
    Case ScreenShotTypes.FullScreen
      [green]' get the entire desktop's bounding rectangle[/green]
      Call GetWindowRect(hWndDesktop, picRect)
  End Select
  
  [green]' calculate height and width[/green]
  With picRect
    lngWide = .Right - .Left
    lngHigh = .Bottom - .Top
  End With
  
  [green]' create a new device context for painting[/green]
  hDCMem = CreateCompatibleDC(hDC)
  
  [green]' create an empty bitmap the size of the rectangle[/green]
  hBitmap = CreateCompatibleBitmap(hDC, lngWide, lngHigh)
  
  [green]' select the bitmap into the new device context[/green]
  RetVal = SelectObject(hDCMem, hBitmap)
  If RetVal = 0 Then
    RaiseEvent ErrorOccurred(NoSelectObject, _
      Replace(mErrorStrings.NoSelectObject, "{%1}", "hBitmap"))
    Goto CleanUpHere
  End If
  
  [green]' blast the bits from the desktop onto the new device context in memory
  ' starting at the top left corner of the bounding rectangle[/green]
  RetVal = BitBlt(hDCMem, 0, 0, lngWide, lngHigh, hDC, picRect.Left, picRect.Top, SRCCOPY)
  If RetVal = 0 Then
    RaiseEvent ErrorOccurred(NoBitBlt, mErrorStrings.NoBitBlt)
    Goto CleanUpHere
  End If

  [green]' populate structures needed for output to file[/green]
  With RefIID
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With

  With Pic
    .Size = Len(Pic)
    .Type = &H1
    .hBmp = hBitmap   [green]'this is the pointer to the new bitmap[/green]
    .hPal = 0&
  End With

  [green]' create the picture and save to file as bitmap[/green]
  RetVal = OleCreatePictureIndirect(Pic, RefIID, 1, IPic)
  If RetVal <> S_OK Then
    RaiseEvent ErrorOccurred(NoCreatePicture, mErrorStrings.NoCreatePicture)
    GoTo CleanUpHere
  End If
  
  strFile = FullPath
  If Len(strFile) = 0 Then
    RaiseEvent ErrorOccurred(InvalidPath, _
      Replace(mErrorStrings.InvalidPath, "{%1}", mstrFilePath & " + " & mstrFileName))
  Else
    stdole.SavePicture IPic, strFile
    RaiseEvent PictureSaved(strFile, FileLen(strFile), shotType)
    OutputToBitmap = True
  End If
  
CleanUpHere:
  
  [green]' delete the bitmap reference[/green]
  RetVal = DeleteObject(hBitmap)
  If RetVal = 0 Then
    RaiseEvent ErrorOccurred(NoDeleteObject, _
      Replace(mErrorStrings.NoDeleteObject, "{%1}", "hBitmap"))
  End If
  
  [green]' release desktop resources[/green]
  RetVal = ReleaseDC(hWndDesktop, hDC)
  If RetVal = 0 Then
    RaiseEvent ErrorOccurred(NoReleaseDC, _
      Replace(mErrorStrings.NoReleaseDC, "{%1}", "Desktop"))
  End If
  
  [green]' delete memory resources[/green]
  RetVal = DeleteDC(hDCMem)
  If RetVal = 0 Then
    RaiseEvent ErrorOccurred(NoDeleteDC, _
      Replace(mErrorStrings.NoDeleteDC, "{%1}", "Buffer"))
  End If

  OutputToBitmap = True

ExitHere:
  On Error Resume Next
  If Not frm Is Nothing Then Set frm = Nothing
  Exit Function
ErrHandler:
  Dim lngErr As Long, strMsg As String
  lngErr = Err: strMsg = Err.Description
  Err.Clear
  RaiseEvent ErrorOccurred(lngErr, strMsg)
End Function

[green]'@--------------------------------------------------------------@[/green]

Private Function PathFix(ByVal strPath As String, ByVal strFileName As String) As String
On Error GoTo ErrHandler
  
  If Len(strPath) > 0 And Len(strFileName) > 0 Then
    If Dir(strPath) = "" Then
      If Dir(strPath & "\") = "" Then
        Exit Function
      End If
    End If
  
    If Right(strPath, 1) <> "\" Then
      If Left(strFileName, 1) <> "\" Then
        PathFix = strPath & "\" & strFileName
      Else
        PathFix = strPath & strFileName
      End If
    Else
      If Left(strFileName, 1) <> "\" Then
        PathFix = strPath & strFileName
      Else
        PathFix = Mid(strPath, 1, Len(strPath) - 1) & strFileName
      End If
    End If
  End If
  
ExitHere:
  Exit Function
ErrHandler:
  Dim lngErr As Long, strMsg As String
  lngErr = Err: strMsg = Err.Description
  Err.Clear
  RaiseEvent ErrorOccurred(lngErr, strMsg)
End Function

[green]'@---------------------- End of Class --------------------------@[/green]

Here's the sample instantiation using a form with an option group and a command button to snap the pictures:

Option Compare Database
Option Explicit

Private WithEvents mScreenShot As clsScreenShot
Private mlngCounter As Long
Private Const FILE_NAME As String = "MyScreenShot{%1}.bmp"

Private Sub cmdScreenshot_Click()
  mlngCounter = mlngCounter + 1
  
  With mScreenShot
    .FileName = Replace(FILE_NAME, "{%1}", CStr(mlngCounter))
    Select Case Me.fraShotType
      Case 1
        .CaptureActiveForm
      Case 2
        .CaptureFullScreen
    End Select
  End With
End Sub

Private Sub Form_Load()
  Set mScreenShot = New clsScreenShot  
  mScreenShot.FilePath = "C:\"
End Sub

Private Sub mScreenShot_PictureSaved(ByVal strFileName As String, _
                                     ByVal lngSize As Long, _
                                     ByVal shotType As ScreenShotTypes)
                                     
  MsgBox "Saved picture to " & strFileName & vbCrLf & vbCrLf & _
         "File Size: " & Format(lngSize / 1024, "#,### KB") & vbCrLf & _
         "Captured: " & IIf(shotType = ActiveForm, "Active Form", "Full Screen"), _
         vbInformation, "Output Status"
End Sub

Private Sub mScreenShot_ErrorOccurred(ByVal ErrNum As Long, ByVal strMsg As String)
  MsgBox Err & "-" & strMsg, vbExclamation, "Screenshot Class Error"
End Sub

VBSlammer

"You just have to know which screws to turn." - Professor Bob