|
論壇說明 | 標記討論區已讀 |
歡迎您來到『史萊姆論壇』 ^___^ 您目前正以訪客的身份瀏覽本論壇,訪客所擁有的權限將受到限制,您可以瀏覽本論壇大部份的版區與文章,但您將無法參與任何討論或是使用私人訊息與其他會員交流。若您希望擁有完整的使用權限,請註冊成為我們的一份子,註冊的程序十分簡單、快速,而且最重要的是--註冊是完全免費的! 請點擊這裡:『註冊成為我們的一份子!』 |
|
主題工具 | 顯示模式 |
2005-06-24, 07:54 AM | #1 |
版區管理員
|
篡改[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 |
送花文章: 1530,
|
向 魔術王子 送花的會員:
|
tmail1987 (2007-10-05)
感謝您發表一篇好文章 |
2005-06-24, 07:55 AM | #2 (permalink) |
版區管理員
|
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 |
送花文章: 1530,
|
2005-06-24, 12:19 PM | #4 (permalink) |
長老會員
|
<1>第一個 exit sub
小弟知道原因 (剛好手上有這本書) 也就是 魔術王子 忘了去除 (含有 按鍵偵測程式 的) 刪了這句了 因為原程式的 Form_Load (含有 按鍵偵測程式 的) 前面有 On Error GoTo ErrMsg SetKeyboardHook Me.hWnd, WM_USER 後面還有下列的部份 ErrMsg: MsgBox "欲執行本程式,請先將 KeybHook.dll 複製到 Windows 所在目錄!" End <2>第二個 exit sub 小弟看了一下,是原 source 就有的!! 偶有兩種想法 (1)原來就沒必要加的 or 原本程式還有其它的考慮,但是後來去除之後忘了刪這個 exit sub 了 (2)可能 vb 有小 bug,不加會有問題 劣者初步的看法是 (1) 的機會比較大(不過目前只是光看程式碼,還沒有實際 Run 過) 以上只是劣者的淺見,說的不對請大家不吝批評指教!!! 說真的,這上面大部份程式碼都看不懂就是了 (因為 API 偶還真是不太了解,通常只是抄範例,實際運作(=程式碼原理)倒是很少企研究) |
__________________ 一切有為法 如夢幻泡影 如露亦如電 應作如是觀 |
|
送花文章: 150,
|
2005-06-24, 12:26 PM | #5 (permalink) | |
版區管理員
|
引用:
語法:
Me.WindowState = vbMinimized Exit Sub ErrMsg: MsgBox "欲執行本程式,請先將 KeybHook.dll 複製到 Windows 所在目錄!" End 說實話,小王子沒注意到這部份 |
|
送花文章: 1530,
|