[文件操作] [已解决]批处理有没有方法或工具根据提供的屏幕坐标截图？

zhanglei1371

网上搜了好长时间，发现截图都是截全屏的，我想用变量计算出需要截屏的矩形区域，提供出屏幕上四个角的坐标，或者左上角的坐标，区域的宽度和高度，这四个值，能否实现截图呢？

网上搜到个类似的解决方案：但是不知怎么用：

Private Declare Function icePub_saveScreen Lib "icePubDll.dll" (ByVal bmpFile As String) As Integer

Dim str1 As String
Dim a2 As Integer

str1 = App.Path + "\1.bmp"
a2 = icePub_saveScreen(str1)

Private Declare Function icePub_saveScreenJpg Lib "icePubDll.dll" (ByVal jpgFile As String) As Integer

Dim str1 As String
Dim a2 As Integer

str1 = App.Path + "\1.jpg"
a2 = icePub_saveScreenJpg(str1)

Private Declare Function icePub_saveSubScreen Lib "icePubDll.dll" (ByVal bmpFile As String, ByVal startX As Integer,ByVal startY As Integer,ByVal endX As Integer,ByVal endY As Integer) As Integer

Dim str1 As String
Dim a2 As Integer

str1 = App.Path + "\1.bmp"
a2 = icePub_saveSubScreen(str1,0,0,100,60)

Private Declare Function icePub_saveSubScreenJpg Lib "icePubDll.dll" (ByVal jpgFile As String, ByVal startX As Integer,ByVal startY As Integer,ByVal endX As Integer,ByVal endY As Integer) As Integer

Dim str1 As String
Dim a2 As Integer

str1 = App.Path + "\1.jpg"
a2 = icePub_saveScreenJpg(str1,0,0,100,60)

download:
http://dl.icese.net/dev.php?f=icePubDll.rar
复制代码

我也下载了这个ｄｌｌ，想放在ｖｂａ中使用，发现不知怎么用。有高手知道的话，或者有更好的方法，万望告之，非常感谢。

yu2n

你需要注册这个DLL文件
──────────────────────────────────────────────────
如何注册dll文件：http://jingyan.baidu.com/article/08b6a591f472f814a80922fd.html
64位系统下注册32位dll文件：http://succu.blog.163.com/blog/static/193917174201210625642312/

bailong360

第三方PrtScr

Usage:PrtScr x y width height [drive:][path]filename
例:PrtScr 0 0 200 200 save.bmp (截取左上角200*200的区域保存为save.bmp)
x y从屏幕左上角算起
复制代码

用了一些比较极端的编译参数来压缩体积,如果有bug请报告

yu2n

截屏保存到 c:\1.bmp ，可指定区域，vb6 / vba 通用

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ##
Private Type PointAPI
  X As Long
  Y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitmapInfo, ByVal wUsage As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As PointAPI) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
Private Type BitmapInfoHeader '40 bytes
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
Private Type BitmapInfo
  bmiHeader As BitmapInfoHeader
  bmiColors As RGBQUAD
End Type
Private Type BitmapFileHeader
  bfType As Integer
  bfSize As Long
  bfReserved1 As Integer
  bfReserved2 As Integer
  bfOffBits As Long
End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ##
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal l As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_FLAG_SEQUENTIAL_SCAN = &H8000000
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_ALWAYS = 2
Private Const GENERIC_WRITE = &H40000000
'Download by http://www.codefans.net
Private Type SECURITY_ATTRIBUTES
  nLength As Long
  lpSecurityDescriptor As Long
  bInheritHandle As Long
End Type
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ##
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_SHOWWINDOW = &H40
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As PointAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lpPoint As PointAPI, ByVal nCount As Long) As Long
Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
Private Const PS_DOT = 2                     '  .......
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' ########### ########### ########### ########### ########### ########### ########### ###########
' ########### ########### ########### ########### ########### ########### ########### ###########
' ########### ########### ########### ########### ########### ########### ########### ###########

Private Sub GetScreenResolution(ByRef nWidth As Integer, ByRef nHeight As Integer)
  Dim a(1 To 61) As Integer
  EnumDisplaySettings 0, -1, a(1)
  'a(53) Deep / a(55) Width / a(57) Height / a(61) Refresh frequency
  nWidth = a(55)
  nHeight = a(57)
End Sub

Sub Main()
  TestSaveScreen
  MsgBox "Done"
  End
End Sub

Sub TestSaveScreen()
  Dim beginPoint As PointAPI
  Dim endPoint As PointAPI
  Dim X As Long, Y As Long
  Y = GetSystemMetrics(SM_CYSCREEN)
  X = GetSystemMetrics(SM_CXSCREEN)
  beginPoint.X = 0
  beginPoint.Y = 0
  endPoint.X = X
  endPoint.Y = Y
  Screen2Bmp "c:\1.bmp", beginPoint, endPoint
End Sub

Function Screen2Bmp(ByVal bmpFile As String, ByRef beginPoint As PointAPI, ByRef endPoint As PointAPI)

  Dim X&, Y&, nSrcDC&, nSrcBmp&, nMemDC&
  'Init Screen DC
  nSrcDC = GetDC(0)
  
  'Create a bitmap object on the screen
  X = GetSystemMetrics(SM_CXSCREEN)
  Y = GetSystemMetrics(SM_CYSCREEN)
  nSrcBmp = CreateCompatibleBitmap(nSrcDC, X, Y)
  nMemDC = CreateCompatibleDC(nSrcDC)    'Create a memory DC on the screen
  
  'Move the screen content to the memory DC
  SelectObject nMemDC, nSrcBmp
  BitBlt nMemDC, 0, 0, X, Y, nSrcDC, 0, 0, SRCCOPY
  DeleteObject nSrcBmp
  
  'Correct starting coordinates
  Dim nTmpDC&, nTmpBmp&, k&, g&, tmpInt%
  If endPoint.X < beginPoint.X Then
    tmpInt = endPoint.X
    endPoint.X = beginPoint.X
    beginPoint.X = tmpInt
  End If
  If endPoint.Y < beginPoint.Y Then
    tmpInt = endPoint.Y
    endPoint.Y = beginPoint.Y
    beginPoint.Y = tmpInt
  End If
  
  k = endPoint.X - beginPoint.X
  g = endPoint.Y - beginPoint.Y
  
  nTmpDC = CreateCompatibleDC(nSrcDC)
  nTmpBmp = CreateCompatibleBitmap(nSrcDC, k, g)
  SelectObject nTmpDC, nTmpBmp
  
  BitBlt nTmpDC, 0, 0, k, g, nMemDC, beginPoint.X, beginPoint.Y, SRCCOPY
  DeleteDC nMemDC
  
  Dim bih As BitmapInfoHeader
  With bih
    .biBitCount = 32
    .biClrImportant = 0
    .biClrUsed = 0
    .biCompression = 0
    .biHeight = g
    .biPlanes = 1
    .biSize = 40
    .biSizeImage = k * g * 4
    .biWidth = k
    .biXPelsPerMeter = 0
    .biYPelsPerMeter = 0
  End With
  
  Dim bfh As BitmapFileHeader
  With bfh
    .bfOffBits = 14 + bih.biSize
    .bfReserved1 = 0
    .bfReserved2 = 0
    .bfSize = .bfOffBits + bih.biSizeImage
    .bfType = 19778 'BM
  End With
  
  Dim sa As SECURITY_ATTRIBUTES
  With sa
    .bInheritHandle = 0
    .lpSecurityDescriptor = 0
    .nLength = 0
  End With
  
  If k > 0 And g > 0 Then
    ReDim bits(4, 0 To k - 1, 0 To g - 1)
  Else
    ReDim bits(4, 0, 0)
  End If
  
  Dim bitinfo As BitmapInfo
  With bitinfo.bmiHeader
    .biBitCount = 32
    .biCompression = 0
    .biHeight = g
    .biPlanes = 1
    .biSize = Len(bitinfo.bmiHeader)
    .biWidth = k
  End With
  
  GetDIBits nTmpDC, nTmpBmp, 0&, g, bits(0, 0, 0), bitinfo, DIB_RGB_COLORS
  DeleteObject nTmpBmp
  DeleteDC nTmpDC
  
  Dim fh As Long
  Dim Writtennum As Long
  fh = CreateFile(bmpFile, GENERIC_WRITE, 0, sa, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL + FILE_FLAG_SEQUENTIAL_SCAN, 0)
  Writtennum = 0
  WriteFile fh, bfh.bfType, 2, Writtennum, 0
  WriteFile fh, bfh.bfSize, 12, Writtennum, 0
  WriteFile fh, bih, bih.biSize, Writtennum, 0
  WriteFile fh, bits(0, 0, 0), bih.biSizeImage, Writtennum, 0
  
  'Debug.Print WriteFile(fh, bfh, Len(BITMAPFILEHEADER), 0, 0)
  'Debug.Print WriteFile(fh, bih, Len(BITMAPINFOHEADER), Len(BITMAPFILEHEADER), 0)
  'Debug.Print WriteFile(fh, nTmpBmp, k * g * 3, Len(BITMAPFILEHEADER) + Len(BITMAPINFOHEADER), 0)
  
  CloseHandle fh

End Function
复制代码

zhanglei1371

回复 3# bailong360


    我下载prtsc。exe测试下，prtsc 0 0 500 800 c:\123546.bmp
结果发现C盘下什么也没。只是剪贴板内多个全屏的截图。难道是我哪里操作有误？

zhanglei1371

回复 4# yu2n


    测试了下，word直接崩溃了
C盘根目录倒是生成了 一个7.91M的bmp，不知怎么回事。此外，我按照二楼的方法，发现还是无法注册dll，不知那个dll您用过没？
附件：http://pan.baidu.com/s/1mglA42G

bailong360

回复 5# zhanglei1371
是PrtScr而不是PrtSc哦
看了一下,忘记更新列表了,现在应该可以搜索到PrtScr了

zhanglei1371

回复 7# bailong360


是不是64位无法使用？我下载了，结果运行错误，弹出对话框：应用程序无法正常启动0xc00000018

zhanglei1371

回复 9# bailong360


    我用的win7 64，提示应用程序无法正常启动....

bailong360

回复 9# zhanglei1371
LZ用32位的cmd启动试一下,我去试试重新编译

zhanglei1371

回复 10# bailong360


    发现32位的可以用，64位的提示错误。若是64位能用，将是非常优秀和完美的一个软件。
此外，我上面上传了个icePubDll.dll的下载地址，似乎有C语言源码，但是我发现一旦横向宽度坐标超过1080，就会截一直到屏幕右下角而成自己指定的右下角的区域。您若能修改下这个bug，能否顺便也修复下这个dll，编译下？这个32.64皆可用，谢谢了

bailong360

回复 11# zhanglei1371
已重新编译;;dll下载不了,无法访问

zhanglei1371

回复 12# bailong360


  多谢，64位已经可以完美使用！
icepubdll：
http://download.csdn.net/download/xiaomer/3733352

yu2n

回复 6# zhanglei1371

VB简单截图工具（源码）
http://www.softhy.net/soft/32142.htm

请自行修改。

zhanglei1371

回复 13# zhanglei1371


    提点建议：
工具64位下可行。但是存在些不完美的地方：
我最终是想通过vba代码： Selection.InlineShapes.AddPicture "C:\mc.jpg"将生成的图片插入到word文档，但是发现这样生成的图片无法插入到word文档。而且体积奇大无比
两个同样大小的截图，一个是90.3k，一个是1.5M（本工具生成），能改善下，能插入到word文档就是最好了。体积大小无所谓