excelVBA截屏代码（适用于XP系统）

' 本代码为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