[魔術王子]

ScrCap3.frm內容

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "螢幕抓取程式"
   ClientHeight    =   5310
   ClientLeft      =   2055
   ClientTop       =   2970
   ClientWidth     =   7245
   Icon            =   "ScrCap3.frx":0000
   LinkTopic       =   "Form1"
   PaletteMode     =   1  '最上層控制項的調色盤
   ScaleHeight     =   5310
   ScaleWidth      =   7245
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   3600
      Top             =   960
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   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 mTarget 
      Caption         =   "抓取對象"
      Visible         =   0   'False
      Begin VB.Menu mScreen 
         Caption         =   "螢幕"
         Checked         =   -1  'True
      End
      Begin VB.Menu mActiveWindow 
         Caption         =   "使用中的視窗"
      End
   End
   Begin VB.Menu mSaveFile 
      Caption         =   "儲存檔案"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Const uID = 9998
Const uMessage = WM_USER + 100



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 = IIf(HScroll1.Max \ 100 > 0, HScroll1.Max \ 100, 1)
       HScroll1.LargeChange = IIf(HScroll1.Max \ 10 > 0, HScroll1.Max \ 10, 1)
   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 = IIf(VScroll1.Max \ 100 > 0, VScroll1.Max \ 100, 1)
       VScroll1.LargeChange = IIf(VScroll1.Max \ 10 > 0, VScroll1.Max \ 10, 1)
   End If
End Sub


Private Sub Form_Load()

    prevWndProc = GetWindowLong(Me.hWnd, GWL_WNDPROC)
    SetWindowLong Me.hWnd, GWL_WNDPROC, AddressOf WndProc
    
    ' 加入圖示
    Dim nid As NOTIFYICONDATA
    
    nid.cbSize = Len(nid)
    nid.hWnd = Me.hWnd
    nid.uID = uID
    nid.uFlags = NIF_ICON + NIF_TIP + NIF_MESSAGE
    nid.hIcon = Me.Icon
    nid.szTip = "螢幕抓取程式" + Chr(0)
    nid.uCallbackMessage = uMessage
    Shell_NotifyIcon NIM_ADD, nid
    
    ' 將自己縮到最小
    Me.WindowState = vbMinimized
    
    Exit Sub

End Sub

Private Sub Form_Resize()

    On Error Resume Next
    
    If Me.WindowState = vbMinimized Then
        Me.Hide
        Exit Sub
    Else
        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 If

End Sub

Private Sub Form_Unload(Cancel As Integer)

    SetWindowLong Me.hWnd, GWL_WNDPROC, prevWndProc
    
    ' 刪除圖示
    Dim nid As NOTIFYICONDATA
    
    nid.cbSize = Len(nid)
    nid.hWnd = Me.hWnd
    nid.uID = uID
    Shell_NotifyIcon NIM_DELETE, nid
    

End Sub

Private Sub HScroll1_Change()

    picCopy.Left = -HScroll1.Value

End Sub

Private Sub mActiveWindow_Click()

    mScreen.Checked = False
    mActiveWindow.Checked = True

End Sub


Public Sub Capture()
    Dim hDC As Long, hWnd As Long
    Dim Width As Single, Height As Single
    Dim sx As Integer, sy As Integer
    
    hWnd = GetForegroundWindow()
    If mScreen.Checked Or hWnd = 0 Then ' 抓取螢幕
        hDC = GetDC(0)
        Width = Screen.Width
        Height = Screen.Height
    
    Else ' 抓取使用中的視窗
        Dim r As RECT
        hDC = GetWindowDC(hWnd)
        GetWindowRect hWnd, r
        Width = (r.Right - r.Left) * Screen.TwipsPerPixelX
        Height = (r.Bottom - r.Top) * Screen.TwipsPerPixelY
    End If
    
    picCopy.Width = Width
    picCopy.Height = Height
    
    picCopy.AutoRedraw = True
    
    sx = Width \ Screen.TwipsPerPixelX
    sy = Height \ Screen.TwipsPerPixelY
    BitBlt picCopy.hDC, 0, 0, sx, sy, hDC, 0, 0, vbSrcCopy
    
    picCopy.AutoRedraw = False

    If mScreen.Checked Then
        ReleaseDC 0, hDC
    Else
        ReleaseDC hWnd, hDC
    End If
    
    SetPicture      ' 設定 PictureBox 與捲動軸之間的關係
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 mScreen_Click()

    mScreen.Checked = True
    mActiveWindow.Checked = False

End Sub

Private Sub VScroll1_Change()

    picCopy.Top = -VScroll1.Value

End Sub

PS:粗體部分需自行KeyIn