轉貼[用Visual Basic 6.0設計"螢幕抓取程式"]

[魔術王子]

本程式是轉貼 王國榮先生 所著的Visual Basic 6.0 Windows API講座
ScrCap.bas內容

Option Explicit

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
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

ScrCap.frm內容

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmCopyScreen 
   Caption         =   "螢幕抓取程式"
   ClientHeight    =   2910
   ClientLeft      =   2055
   ClientTop       =   2970
   ClientWidth     =   4425
   LinkTopic       =   "Form1"
   PaletteMode     =   1  '最上層控制項的調色盤
   ScaleHeight     =   2910
   ScaleWidth      =   4425
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   3600
      Top             =   960
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
   End
   Begin VB.PictureBox Picture1 
      AutoRedraw      =   -1  'True
      FillStyle       =   4  '左上到右下的斜線
      Height          =   2535
      Left            =   0
      ScaleHeight     =   2475
      ScaleWidth      =   2835
      TabIndex        =   2
      Top             =   0
      Width           =   2895
      Begin VB.PictureBox picCopy 
         BorderStyle     =   0  '沒有框線
         Height          =   855
         Left            =   0
         ScaleHeight     =   855
         ScaleWidth      =   1335
         TabIndex        =   3
         Top             =   0
         Width           =   1335
      End
   End
   Begin VB.HScrollBar HScroll1 
      Height          =   255
      Left            =   0
      TabIndex        =   1
      Top             =   2520
      Width           =   2895
   End
   Begin VB.VScrollBar VScroll1 
      Height          =   2535
      Left            =   2880
      TabIndex        =   0
      Top             =   0
      Width           =   255
   End
   Begin VB.Menu mCopyScreen 
      Caption         =   "我抓我抓我抓抓"
   End
   Begin VB.Menu mSaveFile 
      Caption         =   "儲存檔案"
   End
End
Attribute VB_Name = "frmCopyScreen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Sub SetPicture()
   picCopy.Visible = True
   ' 判別 Image 的寬度是否小於 PictureBox 的寬度
   If picCopy.Width <= Picture1.ScaleWidth Then
       picCopy.Left = (Picture1.ScaleWidth - picCopy.Width) / 2
   Else ' Image 的寬度大於 PictureBox 的寬度
       picCopy.Left = 0
       HScroll1.Min = 0
       HScroll1.Value = 0
       HScroll1.Max = picCopy.Width - Picture1.ScaleWidth
       HScroll1.SmallChange = HScroll1.Max / 100
       HScroll1.LargeChange = HScroll1.Max / 10
   End If

   ' 判別 Image 的高度是否小於 PictureBox 的高度
   If picCopy.Height <= Picture1.ScaleHeight Then
       picCopy.Top = (Picture1.ScaleHeight - picCopy.Height) / 2
   Else ' Image 的高度大於 PictureBox 的高度
       picCopy.Top = 0
       VScroll1.Min = 0
       VScroll1.Value = 0
       VScroll1.Max = picCopy.Height - Picture1.ScaleHeight
       VScroll1.SmallChange = VScroll1.Max / 100
       VScroll1.LargeChange = VScroll1.Max / 10
   End If
End Sub

Private Sub Form_Resize()

    On Error Resume Next
    Picture1.Width = Me.ScaleWidth - VScroll1.Width
    Picture1.Height = Me.ScaleHeight - HScroll1.Height
    VScroll1.Left = Picture1.Width
    HScroll1.Top = Picture1.Height
    VScroll1.Height = Picture1.Height
    HScroll1.Width = Picture1.Width
    
    SetPicture

End Sub

Private Sub HScroll1_Change()

    picCopy.Left = -HScroll1.Value

End Sub
Private Sub mCopyScreen_Click()

    Dim hDC As Long, sx As Integer, sy As Integer
    
    Me.Hide
    DoEvents    ' 若不執行此一敘述，可讓 Me.Hide 不會即時被執行
    
    picCopy.Width = Screen.Width
    picCopy.Height = Screen.Height
    
    picCopy.AutoRedraw = True
    
    ' 圖像的轉移
    hDC = GetDC(0)                              ' 取得螢幕DC
    sx = Screen.Width \ Screen.TwipsPerPixelX   ' 螢幕寬度(以Pixel為單位)
    sy = Screen.Height \ Screen.TwipsPerPixelY  ' 螢幕高度(以Pixel為單位)
    ' 將螢幕DC的圖像轉移到名稱為picCopy的PictureBox中
    BitBlt picCopy.hDC, 0, 0, sx, sy, hDC, 0, 0, vbSrcCopy
    ReleaseDC 0, hDC                            ' 釋放螢幕DC
    
    picCopy.AutoRedraw = False
    
    SetPicture      ' 設定 PictureBox 與捲動軸之間的關係
    Me.Show

End Sub

Private Sub mSaveFile_Click()

   On Error Resume Next
   With CommonDialog1
      .DialogTitle = "儲存檔案"
      .Filter = "點陣檔(*.bmp)|*.bmp"
      .CancelError = True
      .ShowOpen
      If Err.Number <> cdlCancel Then
         SavePicture picCopy.Picture, .filename
      End If
   End With

End Sub

Private Sub VScroll1_Change()

    picCopy.Top = -VScroll1.Value

End Sub

PS:粗體部分需自行KeyIn
這些全都利用API設計的,大家可以順便學學API

[mini]

如能擷取 播放器影像 會更好 ^^
通常下 播放器 是直接使用 DirectShow (設計起來簡單又快)
所以 影像是處於 Active Window 空間裡
(當然並非所有播放器都這麼設計，其實您只要快速移動 播放器)
(可以發現 影像並不是這麼緊貼 播放器 窗體，會看到後方黑畫面，這大多是 DirectShow 設計的)
所以抓出來才一片黑
(網路上有人發現 兩個播放器疊在一起 播放同一視訊，就可以抓到圖，要說為何 ??)

總之要連同 Active Window 內容與 桌面一同抓取，難度比較高
如只針對 Active Window 則只要抓到 Active Window 的 hWnd 就好辦了

至於實作
留給有興趣的網友吧 ^^

Thx share ^^

[魔術王子]

作者: mini

如能擷取 播放器影像 會更好 ^^
通常下 播放器 是直接使用 DirectShow (設計起來簡單又快)
所以 影像是處於 Active Window 空間裡
(當然並非所有播放器都這麼設計，其實您只要快速移動 播放器)
(可以發現 影像並不是這麼緊貼 播放器 窗體，會看到後方黑畫面，這大多是 DirectShow 設計的)
所以抓出來才一片黑
(網路上有人發現 兩個播放器疊在一起 播放同一視訊，就可以抓到圖，要說為何 ??)

總之要連同 Active Window 內容與 桌面一同抓取，難度比較高
如只針對 Active Window 則只要抓到 Active Window 的 hWnd 就好辦了

至於實作
留給有興趣的網友吧 ^^

Thx share ^^

看看有沒有網友願意分享啦
再來小王子會先將這程式和TrayIcon結合
若可以的話再試幾秒抓一次螢幕