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.

Show the current approach you're trying to use, and explain exactly what problems you're having. There's a bunch of suggestions in those previous two questions, so it's unclear exactly what you're doing currently. — Tim Williams, Feb 28 '14 at 19:45
Did you read all the comments on the second answer? Change all Long type to LongPtr ?? along with adding the extra PtrSafe? — user2140261, Feb 28 '14 at 20:04
My approach is the same as the first link I referenced with the added extras of what was discussed in the second. I got a run time error regarding "olepro32.dll" not being found. — Lew, Feb 28 '14 at 20:42
It's not so difficult to *include your actual code in the question*. If you want help, it's not a good approach to ask folk to go digging through previous posts trying to figure out what you're doing. — Tim Williams, Mar 01 '14 at 01:41
Apologies if you feel that way, it was not out of laziness that I did not add my code. It was a copy of @mehow answer in the first link with the only difference being the UserForm and CommandButton names. Therefore I thought it would be repetitive to repeat it. I was looking for anybody who had run into this before. — Lew, Mar 01 '14 at 15:53

Lew · Accepted Answer · 2015-07-31T18:28:05.870

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

To get the above to work you need to put the Public Const's in a module and then the balance of the script needs to go in the Button Sub command. For those using option explicit you also need to add these at the top: Dim mypath As String, mypath2 As String, mypath3 As String, mypath4 As String, mypath5 As String, newpath1 As String Dim intMessage1 The Dim path4 and Dim path5 can be deleted further down. Edit the rest to fit your directories and userform names. Thanks for the answer helped me solve my query. — TobyPython, Feb 12 '21 at 16:09

score 0 · Answer 2 · answered Feb 12 '21 at 17:42

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

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

2 Answers2