史萊姆論壇

返回   史萊姆論壇 > 專業主討論區 > 程式語言討論區
忘記密碼?
論壇說明 標記討論區已讀

歡迎您來到『史萊姆論壇』 ^___^

您目前正以訪客的身份瀏覽本論壇,訪客所擁有的權限將受到限制,您可以瀏覽本論壇大部份的版區與文章,但您將無法參與任何討論或是使用私人訊息與其他會員交流。若您希望擁有完整的使用權限,請註冊成為我們的一份子,註冊的程序十分簡單、快速,而且最重要的是--註冊是完全免費的!

請點擊這裡:『註冊成為我們的一份子!』

Google 提供的廣告


發文 回覆
 
主題工具 顯示模式
舊 2005-06-24, 07:54 AM   #1
魔術王子
版區管理員
 
魔術王子 的頭像
榮譽勳章
UID - 115097
在線等級: 級別:42 | 在線時長:1993小時 | 升級還需:28小時級別:42 | 在線時長:1993小時 | 升級還需:28小時
註冊日期: 2004-01-13
住址: 魔術學園
文章: 2985
精華: 0
現金: 14947 金幣
資產: 2678577 金幣
預設 篡改[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
魔術王子 目前離線  
送花文章: 1530, 收花文章: 1555 篇, 收花: 3894 次
回覆時引用此帖
向 魔術王子 送花的會員:
tmail1987 (2007-10-05)
感謝您發表一篇好文章
舊 2005-06-24, 07:55 AM   #2 (permalink)
版區管理員
 
魔術王子 的頭像
榮譽勳章
UID - 115097
在線等級: 級別:42 | 在線時長:1993小時 | 升級還需:28小時級別:42 | 在線時長:1993小時 | 升級還需:28小時
註冊日期: 2004-01-13
住址: 魔術學園
文章: 2985
精華: 0
現金: 14947 金幣
資產: 2678577 金幣
預設

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
魔術王子 目前離線  
送花文章: 1530, 收花文章: 1555 篇, 收花: 3894 次
回覆時引用此帖
舊 2005-06-24, 09:01 AM   #3 (permalink)
管理版主
 
mini 的頭像
榮譽勳章
UID - 4144
在線等級: 級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時級別:97 | 在線時長:9834小時 | 升級還需:162小時
註冊日期: 2002-12-07
文章: 13335
精華: 0
現金: 26432 金幣
資產: 3024292 金幣
預設

只有一點疑問

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

Thx share ^^
mini 目前離線  
送花文章: 2011, 收花文章: 7996 篇, 收花: 26798 次
回覆時引用此帖
舊 2005-06-24, 12:19 PM   #4 (permalink)
長老會員
 
劍痞憶秋年 的頭像
榮譽勳章
UID - 15
在線等級: 級別:31 | 在線時長:1096小時 | 升級還需:56小時級別:31 | 在線時長:1096小時 | 升級還需:56小時級別:31 | 在線時長:1096小時 | 升級還需:56小時級別:31 | 在線時長:1096小時 | 升級還需:56小時級別:31 | 在線時長:1096小時 | 升級還需:56小時級別:31 | 在線時長:1096小時 | 升級還需:56小時
註冊日期: 2002-12-06
住址: 步雲崖
文章: 280
精華: 0
現金: 15847 金幣
資產: 20867 金幣
預設

<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, 收花文章: 33 篇, 收花: 130 次
回覆時引用此帖
舊 2005-06-24, 12:26 PM   #5 (permalink)
版區管理員
 
魔術王子 的頭像
榮譽勳章
UID - 115097
在線等級: 級別:42 | 在線時長:1993小時 | 升級還需:28小時級別:42 | 在線時長:1993小時 | 升級還需:28小時
註冊日期: 2004-01-13
住址: 魔術學園
文章: 2985
精華: 0
現金: 14947 金幣
資產: 2678577 金幣
預設

引用:
作者: mini
只有一點疑問

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

Thx share ^^
小王子不是很了解,不過應該是離開這個事件吧
語法:
    Me.WindowState = vbMinimized
    
    Exit Sub
ErrMsg:
    MsgBox "欲執行本程式,請先將 KeybHook.dll 複製到 Windows 所在目錄!"
    End
上面是他原程式,若不執行Exit Sub,則程式會繼續執行MsgBox "欲執行本程式,請先將 KeybHook.dll 複製到 Windows 所在目錄!"
說實話,小王子沒注意到這部份
魔術王子 目前離線  
送花文章: 1530, 收花文章: 1555 篇, 收花: 3894 次
回覆時引用此帖
發文 回覆


主題工具
顯示模式

發表規則
不可以發文
不可以回覆主題
不可以上傳附加檔案
不可以編輯您的文章

論壇啟用 BB 語法
論壇啟用 表情符號
論壇啟用 [IMG] 語法
論壇禁用 HTML 語法
Trackbacks are 禁用
Pingbacks are 禁用
Refbacks are 禁用


所有時間均為台北時間。現在的時間是 10:58 PM


Powered by vBulletin® 版本 3.6.8
版權所有 ©2000 - 2024, Jelsoft Enterprises Ltd.


SEO by vBSEO 3.6.1