截图并粘贴新电子邮件 – outlookexcel vba

我正在寻找屏幕截图显示的代码（而不是整个屏幕）。 我已经得到了谷歌的帮助程序，但不幸的是，该程序只是粘贴在Excel中的截图。 我怎样才能将它直接粘贴到Outlook中的新邮件？ 谢谢。 顺便说一句，这是我得到的代码。

Option Explicit Private Const CCHDEVICENAME = 32 Private Const CCHFORMNAME = 32 Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source Private Type DEVMODE dmDeviceName As String * CCHDEVICENAME dmSpecVersion As Integer dmDriverVersion As Integer dmSize As Integer dmDriverExtra As Integer dmFields As Long dmOrientation As Integer dmPaperSize As Integer dmPaperLength As Integer dmPaperWidth As Integer dmScale As Integer dmCopies As Integer dmDefaultSource As Integer dmPrintQuality As Integer dmColor As Integer dmDuplex As Integer dmYResolution As Integer dmTTOption As Integer dmCollate As Integer dmFormName As String * CCHFORMNAME dmUnusedPadding As Integer dmBitsPerPel As Long dmPelsWidth As Long dmPelsHeight As Long dmDisplayFlags As Long dmDisplayFrequency As Long End Type Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Declare Function EmptyClipboard Lib "user32.dll" () As Long Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Declare Function CloseClipboard Lib "user32.dll" () As Long Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Declare Function CountClipboardFormats Lib "user32" () As Long Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Declare Function CreateIC Lib "GDI32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long Sub GetPrintScreen() Call CaptureScreen(35, 200, 975, 445) End Sub 

我认为这是我应该编辑的部分。

 Public Sub ScreenToGIF_NewWorkbook() Dim wbDest As Workbook, wsDest As Worksheet Dim FromType As String, PicHigh As Single Dim PicWide As Single, PicWideInch As Single Dim PicHighInch As Single, DPI As Long Dim PixelsWide As Integer, PixelsHigh As Integer Call TOGGLEEVENTS(False) Call GetPrintScreen If CountClipboardFormats = 0 Then MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste" GoTo EndOfSub End If 'Determine the format of the current clipboard contents. There may be multiple 'formats available but the Paste methods below will always (?) give priority 'to enhanced metafile (picture) if available so look for that first. If IsClipboardFormatAvailable(14) <> 0 Then FromType = "pic" ElseIf IsClipboardFormatAvailable(2) <> 0 Then FromType = "bmp" Else MsgBox "Clipboard does not contain a picture or bitmap to paste.", _ vbExclamation, "No Picture" Exit Sub End If Application.StatusBar = "Pasting from clipboard ..." Set wbDest = Workbooks.Add(xlWBATWorksheet) Set wsDest = wbDest.Sheets(1) wbDest.Activate wsDest.Activate wsDest.Range("B3").Activate 'Paste a picture/bitmap from the clipboard (if possible) and select it. 'The clipboard may contain both text and picture/bitmap format items. If so, 'using just ActiveSheet.Paste will paste the text. Using Pictures.Paste will 'paste a picture if a picture/bitmap format is available, and the Typename 'will return "Picture" (or perhaps "OLEObject"). If *only* text is available, 'Pictures.Paste will create a new TextBox (not a picture) on the sheet and 'the Typename will return "TextBox". (This condition now checked above.) On Error Resume Next 'just in case wsDest.Pictures.Paste.Select On Error GoTo 0 'If the pasted item is an "OLEObject" then must convert to a bitmap 'to get the correct size, including the added border and matting. 'Do this via a CopyPicture-Bitmap and then a second Pictures.Paste. If TypeName(Selection) = "OLEObject" Then With Selection .CopyPicture Appearance:=xlScreen, Format:=xlBitmap .Delete ActiveSheet.Pictures.Paste.Select 'Modify the FromType (used below in the suggested file name) 'to signal that the original clipboard image is not being used. FromType = "ole object" End With End If 'Make sure that what was pasted and selected is as expected. 'Note this is the Excel TypeName, not the clipboard format. If TypeName(Selection) = "Picture" Then With Selection PicWide = .Width PicHigh = .Height .Delete End With Else 'Can get to here if a chart is selected and "Copy"ed instead of "Copy Picture"ed. 'Otherwise, ???. If TypeName(Selection) = "ChartObject" Then MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _ vbExclamation, "Got a Chart Copy, not a Chart Picture" Else MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _ vbExclamation, "Not a Picture" End If 'Clean up and quit. ActiveWorkbook.Close SaveChanges:=False GoTo EndOfSub End If 'Add an empty embedded chart, sized as above, and activate it. 'Positioned at cell B3 just for convenient debugging and final viewing. 'Tip from Jon Peltier: Just add the embedded chart directly, don't use the 'macro recorder method of adding a new separate chart sheet and then relocating 'the chart back to a worksheet. With Sheets(1) .ChartObjects.Add(.Range("B3").Left, .Range("B3").Top, PicWide, PicHigh).Activate End With 'Paste the [resized] bitmap into the ChartArea, which creates ActiveChart.Shapes(1). On Error Resume Next ActiveChart.Pictures.Paste.Select On Error GoTo 0 If TypeName(Selection) = "Picture" Then With ActiveChart 'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1). 'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ??? '''' .Shapes(1).IncrementLeft -1 '''' .Shapes(1).IncrementTop -4 'Remove chart border. This must be done *after* all positioning and sizing. ' .ChartArea.Border.LineStyle = 0 End With 'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG. PicWideInch = PicWide / 72 'points to inches ("logical", not necessarily physical) PicHighInch = PicHigh / 72 DPI = PixelsPerInch() 'typically 96 or 120 dpi for displays PixelsWide = PicWideInch * DPI PixelsHigh = PicHighInch * DPI Else 'Something other than a Picture was pasted into the chart. 'This is very unlikely. MsgBox "Clipboard corrupted, possibly by another task." End If EndOfSub: Call TOGGLEEVENTS(True) End Sub Public Sub TOGGLEEVENTS(blnState As Boolean) 'Originally written by Zack Barresse With Application .DisplayAlerts = blnState .EnableEvents = blnState .ScreenUpdating = blnState If blnState Then .CutCopyMode = False If blnState Then .StatusBar = False End With End Sub Public Function PixelsPerInch() As Long Application.DefaultWebOptions.PixelsPerInch. Dim hdc As Long hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0) PixelsPerInch = GetDeviceCaps(hdc, 88) 'LOGPIXELSX = 88 = Logical pixels/inch in X DeleteDC (hdc) End Function Public Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long) Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE srcDC = CreateDC("DISPLAY", "", "", dm) trgDC = CreateCompatibleDC(srcDC) BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height) SelectObject trgDC, BMPHandle BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY OpenClipboard 0& EmptyClipboard SetClipboardData 2, BMPHandle CloseClipboard DeleteDC trgDC ReleaseDC BMPHandle, srcDC End Sub