-
Notifications
You must be signed in to change notification settings - Fork 2
/
modMessage.vb
271 lines (171 loc) · 9.04 KB
/
modMessage.vb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
Option Strict Off
Option Explicit On
Module modMessage
' ---------- 標準モジュール ----------
Private Structure COPYDATASTRUCT
Dim dwData As Integer
Dim cbData As Integer
Dim lpData As Integer
End Structure
'サブクラス化関数
Public Delegate Function WindowProcDelegate(ByVal hwnd As IntPtr, ByVal uMsg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As WindowProcDelegate) As Integer
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer
Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrW" (ByVal hwnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As WindowProcDelegate) As IntPtr
Private Declare Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrW" (ByVal hwnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As IntPtr) As IntPtr
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As IntPtr, ByVal hwnd As IntPtr, ByVal MSG As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
Private Declare Function GetActiveWindow Lib "user32" () As IntPtr
Public Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
Private Const GWL_WNDPROC As Integer = (-4) 'ウインドウプロシージャ
Private Const WM_ACTIVATE As Integer = &H6
Private Const WM_ACTIVATEAPP As Integer = &H1C
Private Const WM_SETCURSOR As Integer = &H20
Private Const WM_KEYDOWN As Integer = &H100
Private Const WM_SYSCOMMAND As Integer = &H112
Private Const WM_HSCROLL As Integer = &H114
Private Const WM_VSCROLL As Integer = &H115
Private Const WM_CTLCOLORSCROLLBAR As Integer = &H137
Private Const WM_MOUSEWHEEL As Integer = &H20A
Public Const WM_CUT As Integer = &H300
Public Const WM_COPY As Integer = &H301
Public Const WM_PASTE As Integer = &H302
Public Const WM_CLEAR As Integer = &H303
Public Const WM_UNDO As Integer = &H304
Private Const MM_MCINOTIFY As Integer = &H3B9
Private Const MCI_NOTIFY_SUCCESSFUL As Integer = 1
Private Const MCI_NOTIFY_SUPERSEDED As Integer = 2
Private Const MCI_NOTIFY_ABORTED As Integer = 4
Private Const MCI_NOTIFY_FAILURE As Integer = 8
Private Const WA_ACTIVE As Integer = 1
Private Const WA_CLICKACTIVE As Integer = 2
Private Const WA_INACTIVE As Integer = 0
Private Const SB_LINEUP As Integer = 0
Private Const SB_LINEDOWN As Integer = 1
Private Const SB_PAGEUP As Integer = 2
Private Const SB_PAGEDOWN As Integer = 3
Private Const SB_THUMBPOSITION As Integer = 4
Private Const SB_THUMBTRACK As Integer = 5
Private Const SB_TOP As Integer = 6
Private Const SB_BOTTOM As Integer = 7
Private Const SB_ENDSCROLL As Integer = 8
'デフォルトのウインドウプロシージャ
Public OldWindowhWnd As IntPtr
'---------------------------------------------------------------------------
' 関数名： SubClass
' 機能 ： サブクラス化を開始する
' 引数 ： (in) hWnd … 対象フォームのウインドウハンドル
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub SubClass(ByVal hwnd As IntPtr)
If IntPtr.Size = 4 Then
OldWindowhWnd = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
Else
OldWindowhWnd = SetWindowLongPtr(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End If
End Sub
'---------------------------------------------------------------------------
' 関数名： UnSubClass
' 機能 ： サブクラス化を終了する
' 引数 ： (in) hWnd … 対象フォームのウインドウハンドル
' 返り値 ： なし
'---------------------------------------------------------------------------
Public Sub UnSubClass(ByVal hwnd As IntPtr)
If OldWindowhWnd <> 0 Then
'元のプロシージャアドレスに設定する
If IntPtr.Size = 4 Then
SetWindowLong(hwnd, GWL_WNDPROC, OldWindowhWnd)
Else
SetWindowLongPtr(hwnd, GWL_WNDPROC, OldWindowhWnd)
End If
OldWindowhWnd = 0
End If
End Sub
'---------------------------------------------------------------
' 関数名： strNullCut
' 機能 ： 文字列を vbNullChar までを取得する
' 引数 ： (in) srcStr … 対象文字列
' 返り値 ：編集された文字列
'---------------------------------------------------------------
Public Function strNullCut(ByVal srcStr As String) As String
Dim NullCharPos As Integer
NullCharPos = InStr(srcStr, Chr(0))
If NullCharPos = 0 Then
strNullCut = srcStr
Exit Function
End If
strNullCut = Left(srcStr, NullCharPos - 1)
End Function
'次は、受信する側のコード。文字列取得方法は取得した文字列へのポインタより NULL までの長さを取得し、その長さ分バイト単位でコピーしてやればよい。
'-------------------------------------------------------------------------
' 関数名： WindowProc
' 機能 ： ウインドウメッセージをフックする
' 引数 ： (in) hWnd … 対象フォームのウインドウハンドル
' (in) uMsg … ウインドウメッセージ
' (in) wParam … 追加情報１
' (in) lParam … 追加情報２
' 返り値 ： なし
' 備考 ： 特になし
'---------------------------------------------------------------------------
Public Function WindowProc(ByVal hwnd As IntPtr, ByVal uMsg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As IntPtr
'Dim udtCDP As COPYDATASTRUCT
'Dim SentText As String '送られてきた文字列
'Dim SentTextLen As Long '送られてきた文字列の数
Dim lngTemp As Integer
If frmMain.Handle = GetActiveWindow() Then
Select Case uMsg
Case WM_ACTIVATEAPP
If wParam Then
If frmMain._mnuOptionsItem_0.Checked Then g_blnIgnoreInput = True
End If
Case WM_SETCURSOR
If wParam <> frmMain.picMain.Handle Then
g_Obj(UBound(g_Obj)).intCh = 0
frmMain.staMain.Items.Item("Position").Text = "Position:"
'Call frmMain.picMain.Cls
'Call modEasterEgg.DrawEffect()
Select Case wParam
Case frmMain.lstWAV.Handle
Call frmMain.lstWAV.Focus()
Case frmMain.lstBMP.Handle
Call frmMain.lstBMP.Focus()
Case frmMain.lstBGA.Handle
Call frmMain.lstBGA.Focus()
Case frmMain.lstMeasureLen.Handle
Call frmMain.lstMeasureLen.Focus()
End Select
Else
'Call frmMain.vsbMain.SetFocus
Call frmMain.picMain.Focus()
End If
Case WM_MOUSEWHEEL
If HWORD(wParam) > 0 Then
lngTemp = SB_LINEUP
Else
lngTemp = SB_LINEDOWN
End If
Call WindowProc(frmMain.Handle, WM_VSCROLL, lngTemp, frmMain.vsbMain.Handle)
Call WindowProc(frmMain.Handle, WM_VSCROLL, SB_ENDSCROLL, frmMain.vsbMain.Handle)
Case MM_MCINOTIFY
If wParam = MCI_NOTIFY_SUCCESSFUL Then
Call mciSendString("close PREVIEW", vbNullString, 0, 0)
End If
Case WM_CTLCOLORSCROLLBAR 'スクロールバー変な色対策
Exit Function
End Select
'Debug.Print uMsg, wParam, lParam, frmMain.hsbMain.hwnd
End If
WindowProc = CallWindowProc(OldWindowhWnd, hwnd, uMsg, wParam, lParam)
End Function
Public Function HWORD(ByVal LongValue As Integer) As Short
'長整数値から上位ワードを取得する
HWORD = (LongValue And &HFFFF0000) \ &H10000
End Function
Public Function LWORD(ByVal LongValue As Integer) As Short
'長整数値から下位ワードを取得する
If (LongValue And &HFFFF) > &H7FFF Then
LWORD = CShort(LongValue And &HFFFF) - &H10000
Else
LWORD = LongValue And &HFFFF
End If
End Function
End Module