Userform to Image

[IRish3538]

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]

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]

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