' 本代码为WINDOWS XP版截取全屏幕,生成图片为jpg格式,存于桌面 ' 用法:将下面代码粘入EXCELVBA编辑器中,确保EXCEL中有表名sheet1、sheet2、sheet3、然后建一个按钮关联“截取全屏”程序,点按钮会自动在桌面生成“截屏图片”多次截取时应先对“截屏图片”重命名,否则会自动替换前期截取的图片
Private Declare Sub keybd_event Lib "user32" _ (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Sub 截取全屏() Application.WindowState = xlMinimized ' 最小化窗口 Application.Run "延时" '如果电脑显卡配置高可不运行此延时程序,子程序在下面 ' Application.WindowState = xlNormal ' 最大化窗口 Dim myPic As Shape, pic As Shape Dim rng As Range, n% n = ActiveSheet.Shapes.Count ' Call keybd_event(vbKeySnapshot, 0, 0, 0) '全屏窗口 ' Call keybd_event(vbKeySnapshot, 1, 1, 1)'活动窗口 DoEvents Range("A6:Z50").Select ActiveSheet.Paste Set rng = Worksheets("Sheet1").Range("A6:Z50") rng.CopyPicture xlScreen, xlBitmap ActiveSheet.Paste Destination:=ActiveSheet.Range("A6:Z50") Set myPic = ActiveSheet.Shapes(n + 1) myPic.Copy With ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height).Chart .Parent.Select .Paste .Export "C:\Documents and Settings\Administrator\桌面\截屏图片.jpg"'另存的地址及文件名称 .Parent.Delete End With myPic.Delete '删除 myPic Set myPic = Nothing '设定rng=空值 Set rng = Nothing Application.Run "删图片过程" '删除EXCEL中插入的原图片,子程序在下面, Range("A6").Select End Sub Sub 删图片过程() On Error Resume Next Dim shp As Shape, rng2 As Range, theCell As Range Set rng2 = Range("A6:Z50") '指定要删除图片的单元格 ' rng.Clear For Each shp In ActiveSheet.Shapes Set theCell = shp.TopLeftCell If Not Intersect(rng2, theCell) Is Nothing Then shp.Delete Next shp 'Set theCell = Nothing '删除区域文字内容 'Set rng = Nothing '删除区域文字内容 End Sub Sub 延时() ' 如果电脑显卡配置高可不运行此延时程序 Sheets("Sheet3").Select Range("C1:D6640").Select Range("D1").Activate Selection.FormulaR1C1 = "1" ActiveWindow.SmallScroll Down:=48 Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With ActiveWindow.SmallScroll Down:=57 ActiveWindow.ScrollRow = 1450 ActiveWindow.ScrollRow = 6589 ActiveWindow.ScrollRow = 6581 ActiveWindow.SmallScroll Down:=18 Range("C1:D6640").Select Range("D6640").Activate Selection.ClearContents Sheets("Sheet1").Select End Sub |
|