Save Userform as BMP
Results 1 to 4 of 4

Thread: Save Userform as BMP
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jul 2008
    Posts
    5
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Save Userform as BMP

    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.

  2. #2
    Board Regular
    Join Date
    Feb 2003
    Location
    Luton, England.
    Posts
    8,127
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Save Userform as BMP

    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 --------------------------------------------------------------
    Regards
    BrianB (using XL2003 & 2010)
    www.cycleofgrowth.com
    Most problems occur from starting at the wrong place.
    Use a cup of coffee to speed up all Windows processes.
    It is easy until you know how.
    **FORMATTED/COMMENTED CODE IS MORE LIKELY TO GET A REPLY

  3. #3
    MrExcel MVP Tom Urtis's Avatar
    Join Date
    Feb 2002
    Location
    San Francisco, California USA
    Posts
    11,190
    Post Thanks / Like
    Mentioned
    2 Post(s)
    Tagged
    2 Thread(s)

    Default Re: Save Userform as BMP

    Quote Originally Posted by CodeScripted View Post
    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

  4. #4
    Board Regular northwolves's Avatar
    Join Date
    Jun 2006
    Location
    Taiyuan,China
    Posts
    1,122
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Save Userform as BMP

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

    http://blog.csdn.net/northwolves/arc...4/1811295.aspx

    Regards
    Northwolves

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •