Save userform as .xlsx on users desktop

[mrwad]

I would like to save userform as an image inside .xlsx file. I have button in userform to save as .xlsx. So my code should take a screenshot, create new Excel file, paste screenshot in there and save newly created Excel file as and .xlsx file on users desktop. For some reason my code does not take a screenshot and not pasting anything to Excel file. What is possibly wrong?

This part comes first:

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1

Code for button on userform:

Private Sub CommandButton5_Click()
    Application.ScreenUpdating = False
On Error Resume Next

    Application.DisplayAlerts = False

    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0

    Application.PrintCommunication = False

    Path = Environ("USERPROFILE") & "\Desktop\"
    Application.SendKeys "(%{1068})"
    DoEvents
    Workbooks.Add
    ActiveSheet.PasteSpecial Format:="Bitmap"
    ActiveSheet.Range("A1").Select
    ActiveSheet.SaveAs FileName:=Path & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".xlsx"
    ActiveWorkbook.Close False

On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Error handler is pointing on ActiveSheet.PasteSpecial Format:="Bitmap" and says that "PasteSpecial method of Worksheet class failed. It seems it actually takes a screenshot but can't paste it for some reason. Maybe it does not understand what is ActiveSheet?

[Zvoni]

is "ActiveSheet" the active Sheet of "ThisWorkbook" or the Workbook you did "Workbooks.Add" on?

[mrwad]

I probably had to mention that I have two buttons: one for saving userform to PDF and another one for saving to XLSX. PDF works fine, I just wanted to add XLSX possibility, but can't get it work. I have slightly modified my code. Now XLSX version works only after saving to PDF. Then if I make some modifications to UserForm (number changes etc.) save to XLSX does not work again and I have to save to PDF first. Otherwise I am getting empty Excel. Why it is so?

Error handler points to newWB.PasteSpecial Format:=0

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1

PrintScreen:

Private Sub AltPrintScreen()
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
End Sub

Save to PDF:

Private Sub btnPrintPDF_Click()
Application.ScreenUpdating = False

    Dim pdfName As String
    Dim newWS As Worksheet
    
    Application.DisplayAlerts = False
    
    Call AltPrintScreen
    DoEvents 
     
    Set newWS = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    Application.PrintCommunication = False
With newWS.PageSetup
    .Orientation = xlLandscape
    .Zoom = False
 .FitToPagesTall = 1
 .FitToPagesWide = 1
End With
Application.PrintCommunication = True
    newWS.PasteSpecial Format:=0, Link:=False, DisplayAsIcon:=False
    pdfName = Environ$("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".pdf"

newWS.ExportAsFixedFormat Type:=xlTypePDF, _
    FileName:=pdfName, Quality:=xlQualityStandard, _
    IncludeDocProperties:=False, IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    newWS.Delete

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set newWS = Nothing
End Sub

Save to XLSX:

Private Sub CommandButton5_Click()
    Application.ScreenUpdating = False

    Dim NewBook As Workbook

    Call AltPrintScreen
    DoEvents
    
    Set NewBook = Workbooks.Add

    With NewBook
       .Range("A1").PasteSpecial
       .SaveAs FileName:=Environ("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".xlsx"
       .Close False
    End With

    Application.ScreenUpdating = True
End Sub

[Zvoni]

Again with this blasted "ActiveSheet".......
Have you tried

Set NewWB=NewBook.Sheet1

or

NewBook.Sheet1.Range("A1").PasteSpecial......

[mrwad]

Just tried:

Private Sub CommandButton5_Click()
    Application.ScreenUpdating = False


    Dim NewBook As Workbook
    Dim newWB As Worksheet
    
    Application.DisplayAlerts = False
    
    Application.PrintCommunication = False
    
    Set NewBook = Workbooks.Add
    Set newWB = NewBook
    Call AltPrintScreen
    DoEvents
    With NewBook
       'newWB.Range("A1").Select
       NewBook.Sheet1.Range("A1").PasteSpecial
       .SaveAs FileName:=Environ("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".xlsx"
       .Close False
    End With


    Application.ScreenUpdating = True
    Set newWB = Nothing
End Sub

[westconn1]

your last code worked for me to save a .xls to the desktop, after fixing a couple of errors and editing a valid filename to save to

Set newWB = NewBook a type mismatch error

change to NewBook.Sheets("sheet1").Range("A1").PasteSpecial

[mrwad]

If I understand correct, I have edited code like this now:

Private Sub CommandButton5_Click()
    Application.ScreenUpdating = False

    Dim NewBook As Workbook
    Set NewBook = Workbooks.Add

    Call AltPrintScreen
    DoEvents
    
       NewBook.Sheets("Sheet1").Range("A1").PasteSpecial
       NewBook.SaveAs Environ("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".xlsx"
       NewBook.Close False

    Application.ScreenUpdating = True
End Sub

In newly saved .xls file I have as a text: NewBook.Sheets("sheet1").Range("A1").PasteSpecial

[westconn1]

that should work as long as the file name is valid (which i can no check)
i only saved as .xls as my old excel does not do .xlsx, but should make no difference

the code i actually used

    Set NewBook = Workbooks.Add

    Call AltPrintScreen
    DoEvents
    With NewBook
        .Sheets("sheet1").Range("A1").PasteSpecial
        .SaveAs FileName:=Environ("USERPROFILE") & "\Desktop\" & "testme.xls"
       .Close False
    End With

[Zvoni]

There is a reason why i dislike all that "ActiveSomething"-Crap like the plague.....

[mrwad]

I don't know whats the problem... I think also it should work but it isn't. We have file system and once I am running Excel on my Desktop it seems to work, but from file system it doesn't. However code is doing all the operations on Users computer, so I don't understand what's the problem...
Anyway I have ended up with calling MS Paint and saving it as a picture (bmp) by modifying this 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 --------------------------------------------------------------

[westconn1]

i liked the original code a lot better

We have file system and once I am running Excel on my Desktop it seems to work, but from file system it doesn't.

i have no idea what this means

in your previous code what was the actual file name you were saving to? as i could not test that

debug.print Environ("USERPROFILE") & "\Desktop\" & ThisWorkbook.Sheets("Other Data").Range("P14").Value & "," & " " & "Summary" & "_" & Format(Now, "dd.mm.yyyy") & ".xlsx"

does that match what is expected?
is a , valid in a filename?

[mrwad]

We have file system (M - F i l e s) and files are stored actually in there. However once you open some file Word, Excel etc. it opens on your computer as usual and the code is running on your computer, not in some other system or somewhere else. I don't understand what might be the problem as everything else (other codes) are working fine.

Name should be correct as it does not give any error while saving. I have Worksheet called "Other Data" and part of the name comes from cell located in Other Data sheet:

ThisWorkbook.Sheets("Other Data").Range("P14").Value = project number.

Maybe I will test it a little bit later again and come back to this thread with some results.

[jdc2000]

M-Files info:

https://www.m-files.com/en

That could well be the issue.