CoderHelper怎样实现代码窗口的中键支持?
新建一外接程序.修改设计器Connect的代码
'版权信息
'隶属工程: MidButSupport4CodePane
'模块名称: Connect
'模块描述:
'成员个数: 2
'代码行数: 50
'声明行数: 20
'创建时间: 2005-8-12 21:02:09(创建人:MysticBoy)
'修改时间: 2005-8-12 21:02:09(修改人:MysticBoy)
'代码说明:
'版权说明: 版权所有(c) ?-2005 Mysticsoft.
' 保留所有权
'**************************************
Option Explicit
Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
On Error GoTo error_handler
Set VBI = Application
Load frmAddIn'装载窗体.
error_handler:
End Sub
'------------------------------------------------------
'这个方法从 VB 中删除外接程序
'------------------------------------------------------
Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
On Error Resume Next
Unload frmAddIn
End Sub
在 frmAddIn中添加一Timer控件. Interval设置为 200(建议值).然后打开其代码窗口.添加以下代码:
'版权信息
'隶属工程: MidButSupport4CodePane
'模块名称: frmAddIn
'模块描述:
'成员个数: 7
'代码行数: 60
'声明行数: 15
'创建时间: 2005-8-12 21:00:43(创建人:MysticBoy)
'修改时间: 2005-8-13 8:41:11(修改人:MysticBoy)
'代码说明:
'版权说明: 版权所有(c) ?-2005 Mysticsoft.
' 保留所有权
'**************************************
Public hwx As Long
Private Sub Form_Load()
'Hook App.hInstance
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
UnHook hwx
End Sub
Private Sub Form_Terminate()
UnHook hwx
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnHook hwx
End Sub
Public Sub UH()
UnHook hwx
End Sub
Private Sub Timer1_Timer()
Dim pt As POINTAPI
Dim hw As Long
Dim cl As String * 255, tx As String * 255
Static ohw As Long
On Error Resume Next
GetCursorPos pt
hw = WindowFromPoint(pt.x, pt.y)
GetClassName hw, cl, 255
GetWindowText hw, tx, 255
'获取当前鼠标下的窗体句柄和类名称.以及其文本.
If InStr(cl, "VbaWindow") > 0 And InStr(tx, VBI.ActiveCodePane.Window.Caption) Then
'如果包含类名称VbaWindow,同时在获取到的文本中包含了当前活动代码才华窗口中的文本.说明当前鼠标在当前活动的代码窗口中.此时可进行消息拦截.因为本程序是VB6IDE的插件.是DLL插件.与IDE是一个 进程.因此可以拦截到其事件.
'Debug.Print tx
If InStr(tx, "(Code)") > 0 Then
'如果是vbaWindow 而且标题和当前活动标题一样,并且,包含Code字样!代码窗口中包含Code字样.
If ohw <> hw Then'假如当前拦截的对象不和当前鼠标下的一样就执行以下操作
UnHook ohw '解除对以前的对象的拦截.
Hook hw '为当前鼠标下对象设钩.
ohw = hw '
hwx = hw
End If
Else
End If '
End If
End Sub
你需要新添加一模块.添加以下代码
'版权信息
'隶属工程: MidButSupport4CodePane
'模块名称: Module1
'模块描述:
'成员个数: 21
'代码行数: 163
'声明行数: 64
'创建时间: 2005-8-12 21:01:12(创建人:MysticBoy)
'修改时间: 2005-8-12 21:03:00(修改人:MysticBoy)
'代码说明:
'版权说明: 版权所有(c) ?-2005 Mysticsoft.
' 保留所有权
'**************************************
Option Explicit
Public Type POINTL
x As Long
y As Long
End Type
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 SetWindowLong _
Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Declare Function SystemParametersInfo _
Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, _
ByVal uParam As Long, _
lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Declare Function ScreenToClient Lib "user32" _
(ByVal hwnd As Long, xyPoint As POINTL) As Long
Public Const GWL_WNDPROC = -4
Public Const SPI_GETWHEELSCROLLLINES = 104
Public Const WM_MOUSEWHEEL = &H20A
Public WHEEL_SCROLL_LINES As Long
Global lpPrevWndProc As Long
Public Type POINTAPI
x As Long
y As Long
End Type
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GVInf Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public VBI As VBIDE.VBE
Public AutoKnowSL As Boolean
Public SL As Long
Public Sub Hook(ByVal hwnd As Long)
On Error GoTo errH
lpPrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
AutoKnowSL = GetSetting("CoderHelper", "MBS4CP", "UseSysParam", "0") = 1
SL = GetSetting("CoderHelper", "MBS4CP", "WHEEL_SCROLL_LINES", "1")
'获取"控制面板"中的滚动行数值
Call SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, WHEEL_SCROLL_LINES, 0)
If AutoKnowSL = True Then
SL = WHEEL_SCROLL_LINES
Else
If SL = 0 Then
SL = 1
End If
End If
errH:
End Sub
Public Sub UnHook(ByVal hwnd As Long)
On Error GoTo errH
Dim lngReturnValue As Long
lngReturnValue = SetWindowLong(hwnd, GWL_WNDPROC, lpPrevWndProc)
errH:
End Sub
'成员[WindowProc]说明信息
'代码编辑: 2005-9-4 15:37:21(MysticBoy)
'成员类型: 公有方法
'HelpCtID: 0
'成员描述:
'输入参数: 参数名称 说明
' hw
' uMsg
' wParam
' lParam
'功能说明: <在此键入说明>
'**************************************************************
Function WindowProc(ByVal hw As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
On Error Resume Next
Dim pt As POINTAPI
Dim hwxc As Long
GetCursorPos pt
hwxc = WindowFromPoint(pt.x, pt.y)
If hw <> hwxc Then
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)
Exit Function
End If
Select Case uMsg
Case WM_MOUSEWHEEL'如果鼠标消息来自中键.
Dim wzDelta, wKeys As Integer
wzDelta = HIWORD(wParam)
wKeys = LOWORD(wParam)
pt.x = LOWORD(lParam)
pt.y = HIWORD(lParam)
'滚动明细数据库
'Debug.Print wzDelta, wKeys, pt.x, pt.y
If wKeys = 16 Then
'滚动键按下，水平滚动,本程序是移动当前光标位置.而不是使得代码窗口的滚动条滚动.
Dim nx As String, sc As Long, el As Long, ec As Long, nl As Long
VBI.ActiveCodePane.GetSelection nl, sc, el, ec
nx = VBI.ActiveCodePane.CodeModule.Lines(nl, 1)
If Sgn(wzDelta) = 1 Then'左右滚动.
VBI.ActiveCodePane.SetSelection nl, sc - SL, el, ec - SL'向左
Else
VBI.ActiveCodePane.SetSelection nl, sc + SL, el, ec + SL'向右
End If
Else
Dim nc As Long
If Sgn(wzDelta) = 1 Then
For nc = VBI.ActiveCodePane.TopLine To VBI.ActiveCodePane.TopLine - SL Step -1
VBI.ActiveCodePane.TopLine = nc'为防止卡行.采用逐行上下滚动.
Next
Else
For nc = VBI.ActiveCodePane.TopLine To VBI.ActiveCodePane.TopLine + SL Step 1
VBI.ActiveCodePane.TopLine = nc
Next
End If
End If
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)'执行默认操作.释放控制
Case Else
WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam)'执行默认操作.释放控制
End Select
End Function
Public Function HIWORD(LongIn As Long) As Integer
' 取出32位值的高16位
On Error Resume Next
HIWORD = (LongIn And &HFFFF0000) \ &H10000
End Function
Public Function LOWORD(LongIn As Long) As Integer
On Error Resume Next
' 取出32位值的低16位
LOWORD = LongIn And &HFFFF&
End Function