PDA

View Full Version : Userform to Image



IRish3538
11-17-2016, 01:34 PM
Wondering if there's a way to "ctrl+alt+print screen" thru vba? I have a userform that displays a bunch of info and i want to email the image of the userform. no clue how to do it. i know how to auto-generate an email with an image, and i can print screen the userform manually, but not sure how to automate this.

Kenneth Hobs
11-17-2016, 05:03 PM
Button1 method is a bit better but any SendKeys() sort of method, even API like this one, is not foolproof. If I get time, I could show you how to modify this to be more foolproof, and faster though it would still use API methods.

For now, you can play with this old code:

'http://www.ozgrid.com/forum/showthread.php?t=149777&page=1Option Explicit


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


Private Sub CommandButton1_Click()

DoEvents

Application.ScreenUpdating = 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

DoEvents

Workbooks.Add

Application.Wait Now + TimeValue("00:00:01")
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, _
DisplayAsIcon:=False
ActiveSheet.Range("A1").Select
'added to force landscape
ActiveSheet.PageSetup.Orientation = xlLandscape

With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With

ActiveSheet.PageSetup.PrintArea = ""

With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments

'// One or more properties may not be available
' .PrintQuality = 300

.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

'ActiveWindow.SelectedSheets.PrintOut Copies:=1
'ActiveWorkbook.Close False

Application.ScreenUpdating = True
Unload Me
End Sub




Private Sub CommandButton2_Click()
Dim pdfName As String

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 'Otherwise, all of screen would be pasted.

ThisWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False

pdfName = ActiveWorkbook.Path & "\" & Me.Name & " " & Format(Now, "yyyy-mmm-dd") & ".pdf"
'Debug.Print pdfName
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=pdfName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Worksheets(Worksheets.Count).Delete

Unload Me
End Sub

Kenneth Hobs
11-17-2016, 07:47 PM
Here is the copy window, in this case userform, to bmp file method.

In Userform1 with CommandButton1 control:

Private Sub CommandButton1_Click()
CopyWindowToBMP "c:\temp\bill.bmp"
End Sub

In a Module:

'Similar to, http://blog.csdn.net/northwolves/article/details/1811295
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 Function MapVirtualKey Lib "user32" Alias _
"MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib _
"olepro32.dll" (PicDesc As PicBmp, RefIID As Guid, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long


Private Const VK_MENU = &H12
Private Const VK_LMENU = 164
Private Const VK_SNAPSHOT = &H2C
Private Const KEYEVENTF_KEYUP = &H2
Private Const CF_BITMAP = 2
'Const VK_SNAPSHOT = 44
'Const VK_LMENU = 164
'Const KEYEVENTF_KEYUP = 2
Private Const KEYEVENTF_EXTENDEDKEY = 1


Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type


Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type


Sub CopyWindowToBMP(bmpFile As String)
Dim Altscan As Double, hwnd As Long, Pic As PicBmp, _
IPic As IPicture, IID_IDispatch As Guid

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 'Otherwise, all of screen would be pasted.


OpenClipboard 0 'OpenClipboard

With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With


With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = GetClipboardData(CF_BITMAP)
End With

OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
stdole.SavePicture IPic, bmpFile
CloseClipboard
End Sub