Save Userform as BMP

[CodeScripted]

I want to take a Screenshot of UserForm and save it as BitMap Image

Following code allows me to take a screenshot of whatever is in MS Excel Sheet1 From Column A1 to F20.


Sub ExportScreenShot()
Const FName As String = "C:\My Documents\My Screenshots\Screenshot.bmp"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application. ScreenUpdating = False
Set pic_rng = Worksheets("Sheet1").Range("A1:F20")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export Filename:="C:\My Documents\My Screenshots\Screenshot.bmp", FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
'Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I am trying to manipulate this code so that it takes a screenshot of the userform. Is it possible to manipulate this code to take a screenshot of the UserForm and save it?

*Note I got this code on Internet by googling it, and I am trying to manipulate it to help me. I am not using the exact code, for any marketing purpose.

 

[BrianB]

It does not seem possible to do the job directly. In fact I see it is possible to purchase commercial applications. Here is some code which copies to MS Paint and saves from there.

'=====================================================================
'- VBA CODE TO SCREEN COPY A USERFORM AND SAVE AS A BITMAP FILE
'- 1. API Mimics 'Alt + PrintScreen' (Sendkeys method not work from a form.)
'- 2. Get next file name from folder eg.ScreenShot_001.bmp,ScreenShot_002.bmp
'- 3. Copy to MS Paint and save as bitmap - using SendKeys
'=====================================================================
'- Cannot declare API functions in a Userform ........
'- ..... so might as well put all code in a normal module
'- Brian Baulsom July 2008
'=====================================================================
'- API FOR KEY PRESSES
Public Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal _
    bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const VK_KEYUP = &H2
Public Const VK_SNAPSHOT = &H2C
Public Const VK_MENU = &H12
'---------------------------------------------------------------------
'- FOLDER FOR SAVED PICTURES
Const MyScreenShotFolder As String = "F:\TEMP\"
'---------------------------------------------------------------------
'- MS PAINT
Const MSPaint As String = "C:\WINDOWS\system32\mspaint.exe"
Const Alt As String = "%"   ' for SendKeys Alt key
'---------------------------------------------------------------------
'- BITMAP FILE
Dim BitmapFileName As String    ' file name without "_00x.bmp" ending
Dim FullFileName As String      ' full path
Dim RetVal      ' Shell error return. Not used here.
'---------------------------------------------------------------------
'- GET NEXT FILE NAME (Uses FileSystemObject)
Dim FSO As Object
Dim FileNumber As Integer
Dim LastFileNumber As Integer
'-- end of declarations ----------------------------------------------
'=====================================================================
'- CODE TO OPEN USERFORM - Button in a worksheet
'=====================================================================
Sub Button1_Click()
    UserForm1.Show
    Unload UserForm1
End Sub
'---------------------------------------------------------------------
 
'=====================================================================
'- API PRINT SCREEN (COPY TO CLIPBOARD)
'- ** This code is called from the userform eg. button ***
'- Requires Key Up and Key Down code to mimic key presses
'=====================================================================
Sub PRINT_SCREEN()
    '- API print screen
    keybd_event VK_MENU, 0, 0, 0            ' Alt key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, 0, 0        ' PrintScreen key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0 'Alt key up
    DoEvents
    keybd_event VK_MENU, 0, VK_KEYUP, 0     'PrintScreen key up
    DoEvents
    '------------------------------------------------------------------
    SAVE_PICTURE    ' subroutine
End Sub
'------------ eop -----------------------------------------------------
 
'=====================================================================
'- MSPAINT : PASTE PICTURE - SAVE AS BITMAP FILE
'=====================================================================
'- NB. Sendkeys requires 'Wait' statements to delay code while things
'- happen on screen.
'- These can be changed as required depending on computer speed
'- This routine can be used alone if there is something in the Clipboard
'- Not been able to get this to work with Paint Hidden or Minimised
'=====================================================================
Private Sub SAVE_PICTURE()
    '-----------------------------------------------------------------
    '- file name
    BitmapFileName = "ScreenShot"  ' completed by subroutine
    '-----------------------------------------------------------------
    GET_NEXT_FILENAME  ' SUBROUTINE (can be omitted)
    '-----------------------------------------------------------------
    FullFileName = MyScreenShotFolder & BitmapFileName & ".bmp"
    '-----------------------------------------------------------------
    '- open Paint
    RetVal = Shell(MSPaint, vbNormalFocus)  ' normal screen
    Application.StatusBar = " Open MS Paint"
    Application.Wait Now + TimeValue("00:00:02")    ' 2 seconds to open
    '- paste ----------------------------------------------------------
    Application.StatusBar = " Paste picture"
    SendKeys Alt & "E", True    ' edit
    SendKeys "P", True          'paste
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' wait 1 second
    '- save file ------------------------------------------------------
    Application.StatusBar = " Saving " & FullFileName
    SendKeys Alt & "F"              ' File menu
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' wait 1 second
    SendKeys "A", True              ' Save As dialog
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")
    SendKeys FullFileName, True     ' type file name
    DoEvents
    Application.Wait Now + TimeValue("00:00:02")    ' wait 2 seconds
    SendKeys Alt & "S", True        ' Save
    DoEvents
    Application.Wait Now + TimeValue("00:00:03") ' 3 seconds to save
    '- close ----------------------------------------------------------
    Application.StatusBar = " Closing Paint"
    SendKeys Alt & "{F4}", True
    DoEvents
    Application.StatusBar = False
    MsgBox ("File Saved.")
End Sub
'-- eop ----------------------------------------------------------------
'=====================================================================
'- SUBROUTINE : GET NEXT FILE NAME -> BitMapFileName + "_xxx"
'- Called from Sub SAVE_PICTURE()
'=====================================================================
Private Sub GET_NEXT_FILENAME()
    Dim f, f1, fc
    Dim Fname As String
    Dim F3 As String    ' number
    Dim Flen As Integer ' length
    '-----------------------------------------------------------------
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set f = FSO.GetFolder(MyScreenShotFolder)
    Set fc = f.Files
    LastFileNumber = 0
    '- length of file name = name + number + suffix
    Flen = Len(BitmapFileName) + 4 + 4
    '-----------------------------------------------------------------
    '- LOOP FILES IN FOLDER
    For Each f1 In fc
        Fname = f1.Name
        '---------------------------------------------------------
        '- check valid file and number
        F3 = Mid(Fname, Len(Fname) - 6, 3) ' number string
        If InStr(1, Fname, BitmapFileName, vbTextCompare) <> 0 _
            And IsNumeric(F3) And Len(Fname) = Flen Then
            FileNumber = CInt(F3)
            If FileNumber > LastFileNumber Then
                LastFileNumber = FileNumber
            End If
        End If
        '---------------------------------------------------------
    Next
    LastFileNumber = LastFileNumber + 1
    '-----------------------------------------------------------------
    '- Next file name
    BitmapFileName = BitmapFileName & "_" & Format(LastFileNumber, "000")
End Sub
'-- eop --------------------------------------------------------------

 

[Tom Urtis]

I want to take a Screenshot of UserForm and save it as BitMap Image

If it helps, this link shows how to print a bmp userform image.
http://www.mrexcel.com/forum/showthread.php?t=283776

 

[northwolves]

You may use clipboard and stdole to get it,see my blog:

http://blog.csdn.net/northwolves/archive/2007/10/04/1811295.aspx

Regards
Northwolves