篡改[Visual Basic 6.0設計"螢幕抓取程式"配合"TrayIcon"]

[魔術王子]

本程式是修改 王國榮先生 所著的Visual Basic 6.0 Windows API講座
(由於原程式有設計熱鍵功能,但須另寫一個按鍵偵測程式,所以這部份小王子取消<無法傳檔案給大家>)
ScrCap3.bas內容

Attribute VB_Name = "Module1"

Option Explicit


Public Const GWL_WNDPROC = (-4)
Public Const WM_USER = &H400
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205

Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2

Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4

Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Type NOTIFYICONDATA
       cbSize As Long
       hWnd As Long
       uID As Long
       uFlags As Long
       uCallbackMessage As Long
       hIcon As Long
       szTip As String * 64
End Type

Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

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 GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Declare Function BringWindowToTop Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetForegroundWindow Lib "user32" () As Long

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public prevWndProc As Long

Function WndProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_USER + 100 Then
        If lParam = WM_LBUTTONUP Then
            Form1.Capture
            Form1.picCopy.Refresh
            Form1.WindowState = vbNormal
            Form1.Show
        ElseIf lParam = WM_RBUTTONUP Then
            Form1.PopupMenu Form1.mTarget
        End If
    End If
    WndProc = CallWindowProc(prevWndProc, hWnd, Msg, wParam, lParam)
End Function

PS:粗體部分需自行KeyIn

[魔術王子]

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

[mini]

只有一點疑問

有兩個地方使用 Exit Sub
不知為何 ?

Thx share ^^

[劍痞憶秋年]

＜１＞第一個 exit sub
小弟知道原因 (剛好手上有這本書)
也就是 魔術王子 忘了去除 (含有 按鍵偵測程式 的) 刪了這句了

因為原程式的 Form_Load (含有 按鍵偵測程式 的)

前面有
On Error GoTo ErrMsg

SetKeyboardHook Me.hWnd, WM_USER

後面還有下列的部份

ErrMsg:
MsgBox "欲執行本程式，請先將 KeybHook.dll 複製到 Windows 所在目錄！"
End

<２>第二個 exit sub
小弟看了一下，是原 source 就有的！！
偶有兩種想法
(1)原來就沒必要加的
or 原本程式還有其它的考慮，但是後來去除之後忘了刪這個 exit sub 了
(2)可能 vb 有小 bug，不加會有問題

劣者初步的看法是 (1) 的機會比較大(不過目前只是光看程式碼，還沒有實際 Run 過)

以上只是劣者的淺見，說的不對請大家不吝批評指教！！！

說真的，這上面大部份程式碼都看不懂就是了
(因為 API 偶還真是不太了解，通常只是抄範例，實際運作(=程式碼原理)倒是很少企研究)

[魔術王子]

作者: mini

只有一點疑問

有兩個地方使用 Exit Sub
不知為何 ?

Thx share ^^

小王子不是很了解,不過應該是離開這個事件吧

    Me.WindowState = vbMinimized
    
    Exit Sub
ErrMsg:
    MsgBox "欲執行本程式，請先將 KeybHook.dll 複製到 Windows 所在目錄！"
    End

上面是他原程式,若不執行Exit Sub,則程式會繼續執行MsgBox "欲執行本程式，請先將 KeybHook.dll 複製到 Windows 所在目錄！"
說實話,小王子沒注意到這部份