Windows自带了snipping tool。但是在某些情况下用起来非常卡。
所以那时只好用了这个工具,用来截测试结果图。
环境:VB6
两个窗体,一个模块
第一个窗体,要设置的很小,不要影响到正常操作。
第二个窗体,设为无边框,上面放一个shape,最好设为虚线。
第一个窗体:
Private Declare Function GetKeyState Lib "User32" (ByVal nVirtKey As Long) As Integer
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Const HWND_TOPMOST = -1
Private starttime As String
Public Sub Command1_Click()
Form1.Hide
Sleep (500)
Form2.Show
End Sub
Private Sub Form_Load()
SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX _
, Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
Me.Height \ Screen.TwipsPerPixelY, 0
regHotKey
starttime = Now
Me.Top = Screen.Height - (Me.Height + 600)
Me.Left = 0
Timer1.Interval = 60000
End Sub
Private Sub Form_Unload(Cancel As Integer)
unregHotKey
Unload Form2
Unload Form1
End Sub
Private Sub Timer1_Timer()
If DateDiff("n", starttime, Now) > 60 Then
Unload Me
End If
End Sub
Private Sub regHotKey()
Dim ret As Long
preWinProc = GetWindowLong(Me.hwnd, GWL_WNDPROC)
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf Wndproc)
idHotKey = 1
Modifiers = MOD_ALT + MOD_CONTROL
uVirtKey = vbKeyA
ret = RegisterHotKey(Me.hwnd, idHotKey, Modifiers, uVirtKey)
End Sub
Private Sub unregHotKey()
Dim ret As Long
ret = SetWindowLong(Me.hwnd, GWL_WNDPROC, preWinProc)
Call UnregisterHotKey(Me.hwnd, uVirtKey)
End Sub
第二个窗体:
Private Type PointAPI
x As Long
y As Long
End Type
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetCursorPos Lib "User32" (lpPoint As PointAPI) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private 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
Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Sub ScreenShot(Lt, Top, Rt, Bot)
SourceDC = CreateDC("DISPLAY", 0, 0, 0)
DestDC = CreateCompatibleDC(SourceDC)
BHandle = CreateCompatibleBitmap(SourceDC, Rt - 2, Bot - 2)
SelectObject DestDC, BHandle
BitBlt DestDC, 0, 0, Rt, Bot, SourceDC, Lt + 1, Top + 1, &HCC0020
Wnd = Screen.ActiveForm.hwnd
OpenClipboard Wnd
EmptyClipboard
SetClipboardData 2, BHandle
CloseClipboard
DeleteDC DestDC
ReleaseDC DHandle, SourceDC
End Sub
Private Sub Form_Load()
With Form2
.Caption = ""
.AutoRedraw = True
.MousePointer = 2
.ScaleMode = 3
End With
With Form2.Shape1
.Visible = False
.Left = 0
.Top = 0
.Width = 0
.Height = 0
End With
SetWindowPos Form2.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE And SWP_SHOWWINDOW
BitBlt Form2.hdc, 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY, GetDC(0), 0, 0, vbSrcCopy
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Dim Point As PointAPI
GetCursorPos Point
With Form2.Shape1
.Left = Point.x
.Top = Point.y
.Visible = True
End With
End If
If Button = 2 Then
Unload Form2
Form1.Show
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Dim Point As PointAPI
GetCursorPos Point
With Form2.Shape1
If Point.x >= .Left And Point.y >= .Top Then
.Width = Point.x - .Left
.Height = Point.y - .Top
.Visible = True
End If
End With
End If
End Sub
Public Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next
ScreenShot Shape1.Left, Shape1.Top, Shape1.Width, Shape1.Height
Form1.Show
Unload Form2
End Sub
模块:
Option Explicit
Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 RegisterHotKey Lib "User32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Declare Function UnregisterHotKey Lib "User32" (ByVal hwnd As Long, ByVal id As Long) As Long
Public Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = (-4)
Public preWinProc As Long
Public Modifiers As Long, uVirtKey As Long, idHotKey As Long
Private Type taLong
ll As Long
End Type
Private Type t2Int
lWord As Integer
hWord As Integer
End Type
Private i As Integer
Public Function Wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
i = i + 1
If Msg = WM_HOTKEY Then
If wParam = idHotKey Then
Dim lp As taLong, i2 As t2Int
lp.ll = lParam
LSet i2 = lp
If (i2.lWord = Modifiers) And i2.hWord = uVirtKey Then
Form1.Command1_Click
End If
End If
End If
Wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function
快捷键在第一个窗体中设置。
初始位置放在了左下方,可以自行设置。
想要托盘化,自行设置。
没有图片编辑功能,那时我也不需要。