Save Userform as BMP

CodeScripted

New Member
Joined
Jul 18, 2008
Messages
5
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.
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
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.
Code:
'=====================================================================
'- 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 --------------------------------------------------------------
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,251
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top