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?

Same question asked here: https://stackoverflow.com/questions/55574557

 

[Logit]

.
Here is a macro to print the UserForm to the sheet. You can add your save macro after that.

Option Explicit


'Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
'   bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Private Declare PtrSafe Sub keybd_event Lib "User32" _
'    (ByVal bVk As Byte, ByVal bScan As Byte, _
'     ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
     
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" _
        (ByVal bVk As Byte, ByVal bScan As Byte, _
         ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
       bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
     
    
    
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12 '''


Private Sub AltPrintScreen()
        keybd_event VK_MENU, 0, 0, 0
        keybd_event VK_SNAPSHOT, 0, 0, 0
        keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
        keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End Sub
Private Sub CommandButton1_Click()
Call AltPrintScreen
    DoEvents
    Application.Wait Now + TimeSerial(0, 0, 1)
    Worksheets("Sheet1").Range("B3").PasteSpecial
    Unload Me
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/ibcVPb3dGlFeRuabGElhs4Bxi5EXl1D7A4SrdqsIGMz

 

[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?

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
On Error Resume Next


    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
    
On Error GoTo 0


    ThisWorkbook.Worksheets("MAIN").Activate


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

Save to XLSX:

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


    Dim newWB As Worksheet
    
    Application.DisplayAlerts = False
    
    Application.PrintCommunication = False


    Call AltPrintScreen


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


On Error GoTo 0
    Application.ScreenUpdating = True
    Set newWB = Nothing
End Sub