VBA to capture an image of an excel userform with option of saving or attaching to an email

Question

I have been attempting to undertake what I hope has been made clear by the title of this question.

I have attempted what is show here in a previous question but I was stumped by the fact that I am running a 64bit machine which i then tried to remedy using another previous question.

Any thoughts would be greatly appreciated.

Answer 1

I just wanted to post how I eventually solved the userform screenshot component of the above question. I wrote this over a year ago so I apologise if it is hard to follow. I have cleaned it up. Any questions holler at me.

'Declares variables for userform screen shot
Option Explicit
Public Const VK_SNAPSHOT = 44
Public Const VK_LMENU = 164
Public Const KEYEVENTF_KEYUP = 2
Public Const KEYEVENTF_EXTENDEDKEY = 1

Private Sub CommandButton10_Click()
'Check File
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim cnf
Dim cnf2
Dim dir1 As String
Dim dir12 As String
Set cnf = CreateObject("Scripting.FileSystemObject")
Set cnf2 = CreateObject("Scripting.FileSystemObject")
dir1 = RELEVANT DIRECTORY & Me.parcelBox.Value 'user defined field
dir12 = RELEVANT DIRECTORY & Me.parcelBox.Value & "\" & Me.ComboBox1.Value & "\" 'user defined fields

If Not cnf.FolderExists(dir1) Then
    cnf.CreateFolder (dir1)
If Not cnf2.FolderExists(dir12) Then
    cnf2.CreateFolder (dir12)

End If
End If
myPath = dir12


'Screenshot Userform2
''''''''''''''''

'checks if excel version as this will not work for <=2003
If Application.Version < 12 Then
    MsgBox ("Your Are Using Excel 2003. Unfortunately You Are Unable To Save A Form. Email A Section Lead A Brief Description Of The Complaint")
    GoTo outdated
End If

'prompts whether user wants a pdf the userform or not
intMessage1 = MsgBox("Create PDF of Form", _
    vbYesNo, "Closing")
If intMessage1 = vbYes Then
    GoTo saveform
    End
Else
    GoTo donotsaveform
End If

saveform:
Application.Wait Now + TimeValue("00:00:02")

'directory path to save screenshot
myPath = dir12

DoEvents
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
DoEvents
Workbooks.Add
Application.Wait Now + TimeValue("00:00:01")
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False

ActiveSheet.Range("A1").Select    

ActiveSheet.PageSetup.Orientation = xlLandscape

'Full path with pdf file name based on userinput in combobox
newpath1 = myPath & "\" & Me.ComboBox3.Value & ".pdf" 'user defined field


  'checks if file already exists
If dir(newpath1) = "" Then
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            myPath & Me.ComboBox3.Value & ".pdf", Quality _
            :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False

    ActiveWorkbook.Close False

Else
    Dim mypath4 As String
    Dim mypath5 As String
    mypath4 = Application.GetSaveAsFilename(InitialFileName:=myPath,    FileFilter:="PDF Files (*.pdf), *.pdf")

    If mypath4 = "False" Then
        ActiveWorkbook.Close False
        GoTo cancel1
    Else

        mypath5 = mypath4

        'overwrites if it does exist
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
            mypath5, Quality _
            :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
            ActiveWorkbook.Close False
    End If
End If
donotsaveform:
cancel1:

outdated:

Me.Hide
UserForm3.Show

End Sub

Answer 2

This is a slightly updated answer which addresses the Filepath to look for your applications filepath and also formats the image to fully fit onto 1 pdf page if needed in portrait.

Private Sub cmdPDF_Click()
    
'Save as a PDF file
'Check File
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim cnf
Dim cnf2
Dim dir1 As String
Dim dir12 As String
Dim mypath As String, mypath2 As String, mypath3 As String, mypath4 As String, mypath5 As String, newpath1 As String
Dim intMessage1

Set cnf = CreateObject("Scripting.FileSystemObject")
Set cnf2 = CreateObject("Scripting.FileSystemObject")
dir1 = Application.ActiveWorkbook.Path & "\" 'user defined field
dir12 = Application.ActiveWorkbook.Path & "\" 'user defined fields

If Not cnf.FolderExists(dir1) Then
    cnf.CreateFolder (dir1)
If Not cnf2.FolderExists(dir12) Then
    cnf2.CreateFolder (dir12)

End If
End If
mypath = dir12


'Screenshot Userform2
''''''''''''''''

'checks if excel version as this will not work for <=2003
If Application.Version < 12 Then
    MsgBox ("Your Are Using Excel 2003. Unfortunately You Are Unable To Save A Form. Email A Section Lead A Brief Description Of The Complaint")
    GoTo outdated
End If

'prompts whether user wants a pdf the userform or not
intMessage1 = MsgBox("Create PDF of Form", _
    vbYesNo, "Closing")
If intMessage1 = vbYes Then
    GoTo saveform
    End
Else
    GoTo donotsaveform
End If

saveform:
Application.Wait Now + TimeValue("00:00:02")

'directory path to save screenshot
mypath = dir12

DoEvents
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
DoEvents
Workbooks.Add
Application.Wait Now + TimeValue("00:00:01")
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
With ActiveSheet.Pictures
    .ShapeRange.LockAspectRatio = msoTrue
    .Width = 475
End With
ActiveSheet.Range("A1").Select

ActiveSheet.PageSetup.Orientation = xlPortrait
With ActiveSheet.PageSetup
.PrintArea = ActiveSheet.Range("A1:L50")
.FitToPagesTall = 1
.FitToPagesWide = 1
.LeftMargin = Application.InchesToPoints(0.4)
.RightMargin = Application.InchesToPoints(0.4)
.BottomMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(0.75)


End With
'Full path with pdf file name based on userinput in combobox
newpath1 = mypath & "Userform " & ARefFromYourUserForm.Text & " " & AnotherRefFromYourUserFormIfWanted.Text & " " & FreeFile & ".pdf" 'user defined fields plus Freefile to avoid overwriting by accident


  'checks if file already exists
If Dir(newpath1) = "" Then
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            mypath & "Userform " & ARefFromYourUserForm.Text & " " & AnotherRefFromYourUserFormIfWanted.Text & " " & FreeFile & ".pdf", Quality _
            :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, _
            OpenAfterPublish:=True

    ActiveWorkbook.Close False

Else
    mypath4 = Application.GetSaveAsFilename(InitialFileName:=mypath, FileFilter:="PDF Files (*.pdf), *.pdf")

    If mypath4 = "False" Then
        ActiveWorkbook.Close False
        GoTo cancel1
    Else

        mypath5 = mypath4

        'overwrites if it does exist
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            mypath5, Quality _
            :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, _
            OpenAfterPublish:=True
            ActiveWorkbook.Close False
    End If
End If
donotsaveform:
cancel1:

outdated:

End Sub

The Public Constants below need to be put in a new or existing module, they cannot go in the userform script.

Option Explicit
Public Const VK_SNAPSHOT = 44
Public Const VK_LMENU = 164
Public Const KEYEVENTF_KEYUP = 2
Public Const KEYEVENTF_EXTENDEDKEY = 1