dcsimg
Results 1 to 13 of 13

Thread: Save userform as .xlsx on users desktop

  1. #1

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Save userform as .xlsx on users desktop

    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:

    Code:
    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:

    Code:
    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?

  2. #2
    PowerPoster Zvoni's Avatar
    Join Date
    Sep 2012
    Location
    To the moon and then left
    Posts
    1,819

    Re: Save userform as .xlsx on users desktop

    is "ActiveSheet" the active Sheet of "ThisWorkbook" or the Workbook you did "Workbooks.Add" on?
    One System to rule them all, One IDE to find them,
    One Code to bring them all, and to the Framework bind them,
    in the Land of Redmond, where the Windows lie
    ---------------------------------------------------------------------------------
    People call me crazy because i'm jumping out of perfectly fine airplanes.
    ---------------------------------------------------------------------------------
    For health reasons i try to avoid reading unformatted Code

  3. #3

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Re: Save userform as .xlsx on users desktop

    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

    Name:  Captur1e.JPG
Views: 34
Size:  15.5 KB

    Code:
    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:

    Code:
    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:

    Code:
    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:

    Code:
    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
    Last edited by mrwad; Apr 10th, 2019 at 08:50 AM.

  4. #4
    PowerPoster Zvoni's Avatar
    Join Date
    Sep 2012
    Location
    To the moon and then left
    Posts
    1,819

    Re: Save userform as .xlsx on users desktop

    Again with this blasted "ActiveSheet".......
    Have you tried
    Code:
    Set NewWB=NewBook.Sheet1
    or
    Code:
    NewBook.Sheet1.Range("A1").PasteSpecial......
    One System to rule them all, One IDE to find them,
    One Code to bring them all, and to the Framework bind them,
    in the Land of Redmond, where the Windows lie
    ---------------------------------------------------------------------------------
    People call me crazy because i'm jumping out of perfectly fine airplanes.
    ---------------------------------------------------------------------------------
    For health reasons i try to avoid reading unformatted Code

  5. #5

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Re: Save userform as .xlsx on users desktop

    Just tried:

    Code:
    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

  6. #6
    PowerPoster
    Join Date
    Dec 2004
    Posts
    24,247

    Re: Save userform as .xlsx on users desktop

    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
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  7. #7

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Re: Save userform as .xlsx on users desktop

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


    Code:
    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

  8. #8
    PowerPoster
    Join Date
    Dec 2004
    Posts
    24,247

    Re: Save userform as .xlsx on users desktop

    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
    Code:
        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
    Last edited by westconn1; Apr 9th, 2019 at 05:16 AM.
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  9. #9
    PowerPoster Zvoni's Avatar
    Join Date
    Sep 2012
    Location
    To the moon and then left
    Posts
    1,819

    Re: Save userform as .xlsx on users desktop

    There is a reason why i dislike all that "ActiveSomething"-Crap like the plague.....
    One System to rule them all, One IDE to find them,
    One Code to bring them all, and to the Framework bind them,
    in the Land of Redmond, where the Windows lie
    ---------------------------------------------------------------------------------
    People call me crazy because i'm jumping out of perfectly fine airplanes.
    ---------------------------------------------------------------------------------
    For health reasons i try to avoid reading unformatted Code

  10. #10

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Re: Save userform as .xlsx on users desktop

    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:

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

  11. #11
    PowerPoster
    Join Date
    Dec 2004
    Posts
    24,247

    Re: Save userform as .xlsx on users desktop

    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
    Code:
    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?
    i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
    Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next

    dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part

    come back and mark your original post as resolved if your problem is fixed
    pete

  12. #12

    Thread Starter
    Member
    Join Date
    Oct 2018
    Posts
    38

    Re: Save userform as .xlsx on users desktop

    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.

  13. #13
    Frenzied Member jdc2000's Avatar
    Join Date
    Oct 2001
    Location
    Idaho Falls, Idaho USA
    Posts
    1,362

    Re: Save userform as .xlsx on users desktop

    M-Files info:

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

    That could well be the issue.

Posting Permissions

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



Featured


Click Here to Expand Forum to Full Width