-
Notifications
You must be signed in to change notification settings - Fork 32
/
Divers.bas
466 lines (387 loc) · 14.3 KB
/
Divers.bas
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
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
Attribute VB_Name = "Divers_Module"
' #VBIDEUtils#************************************************************
' * Author : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 10/21/2002
' * Project Name : VBIDEUtils
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * Screenshot :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
Option Explicit
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 Sub PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd&, ByVal Msg&, ByVal wp&, ByVal lp&)
Private Declare Sub SetFocus Lib "user32" (ByVal hWnd&)
Private Declare Function GetParent Lib "user32" (ByVal hWnd&) As Long
Const WM_SYSKEYDOWN = &H104
Const WM_SYSKEYUP = &H105
Const WM_SYSCHAR = &H106
Const VK_F = 70 ' VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z'
Dim hwndMenu As Long ' needed to pass the menu keystrokes to VB
Declare Function WritePrivateProfileString& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal AppName$, ByVal KeyName$, ByVal keydefault$, ByVal FileName$)
Global gsTemplate As String
Global gsDevelopper As String
Global gsWebSite As String
Global gsEmail As String
Global gsTelephone As String
Global gsInline As String
Global gsComment As String
Global gsUserComment As String
Global gsCommentString As String
Global gsErrorHandler As String
Global Const gsDefaultDevelopper = "removed"
Global Const gsDefaultWebSite = "http://www.ppreview.net"
Global Const gsDefaultEmail = "removed"
Global gcolFind As Collection
Public Function CountLine(sText As String) As Long
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Date : 17/09/1998
' * Time : 22:49
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : CountLine
' * Parameters :
' * sText As String
' **********************************************************************
' * Comments : Count the number of lines
' *
' *
' **********************************************************************
Dim nPos As Long
Dim nI As Long
If Len(sText) = 0 Then
CountLine = 0
Exit Function
End If
nI = 1
nPos = 1
Do While (nPos > 0)
' *** Get the position of the CR
nPos = InStr(nPos, sText, vbCrLf)
If (nPos = 0) Then Exit Do
nPos = nPos + 2
nI = nI + 1
Loop
CountLine = nI
End Function
Public Function GetLine(sText As String, ByVal nLine As Long) As String
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Date : 17/09/1998
' * Time : 22:50
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : GetLine
' * Parameters :
' * sText As String
' * ByVal nLine As Long
' **********************************************************************
' * Comments : Get a specific line a complete set of line
' *
' *
' **********************************************************************
Dim nPos As Long
Dim nStart As String
Dim nI As Long
Dim sTmp As String
nStart = 1
nPos = 1
' *** get the right line
For nI = 1 To nLine
' *** Get the position of the CR
nPos = InStr(nPos, sText, vbCrLf)
' *** Only one line
If nPos = 0 Then
If nI = 1 Then
sTmp = RTrim(sText)
Else
sTmp = RTrim(Mid$(sText, nStart))
End If
GetLine = sTmp
Exit Function
ElseIf nI = nLine Then
sTmp = RTrim(Mid$(sText, nStart, nPos - nStart))
GetLine = sTmp
Exit Function
End If
nPos = nPos + 2
nStart = nPos
Next
End Function
Public Function GetNextLine(sText As String, nPreviousStart As Long) As String
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Date : 17/09/1998
' * Time : 22:50
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : GetNextLine
' * Parameters :
' * sText As String
' * nPreviousStart As Long
' **********************************************************************
' * Comments : Get a specific line a complete set of line
' *
' *
' **********************************************************************
Dim nPos As Long
Dim nStart As String
Dim sTmp As String
nStart = nPreviousStart
nPos = nPreviousStart
' *** get the next line
' *** Get the position of the CR
nPos = InStr(nPos, sText, vbCrLf)
' *** Only one line
If nPos = 0 Then
sTmp = RTrim(Mid$(sText, nStart))
GetNextLine = sTmp
Exit Function
Else
sTmp = RTrim(Mid$(sText, nStart, nPos - nStart))
nPreviousStart = nPos + 2
GetNextLine = sTmp
Exit Function
End If
End Function
Public Sub Add_DefaultTemplate()
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 2/10/98
' * Time : 14:39
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : Add_DefaultTemplate
' * Parameters :
' **********************************************************************
' * Comments : Add a default template
' *
' *
' **********************************************************************
Dim sTemplate As String
sTemplate = "Template_Default"
SaveSetting gsREG_APP, sTemplate, 1, twaCommentProgrammerName
SaveSetting gsREG_APP, sTemplate, 2, twaCommentWebSite
SaveSetting gsREG_APP, sTemplate, 3, twaCommentEMail
SaveSetting gsREG_APP, sTemplate, 4, twaCommentDate
SaveSetting gsREG_APP, sTemplate, 5, twaCommentTime
SaveSetting gsREG_APP, sTemplate, 6, twaCommentModuleName
SaveSetting gsREG_APP, sTemplate, 7, twaCommentModuleFileName
SaveSetting gsREG_APP, sTemplate, 8, twaCommentProcedureName
SaveSetting gsREG_APP, sTemplate, 9, twaCommentPurpose
SaveSetting gsREG_APP, sTemplate, 10, twaCommentProcedureParameters
SaveSetting gsREG_APP, sTemplate, 11, twaCommentPrefered
SaveSetting gsREG_APP, sTemplate, 12, twaCommentPurpose
SaveSetting gsREG_APP, sTemplate, 13, twaCommentSample
SaveSetting gsREG_APP, sTemplate, 14, twaCommentSeeAlso
SaveSetting gsREG_APP, sTemplate, 15, twaCommentHistory
SaveSetting gsREG_APP, "Template", sTemplate, sTemplate
gsTemplate = sTemplate
End Sub
Public Function RemoveAmpersand(sInput As String) As String
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 2/10/98
' * Time : 14:39
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : RemoveAmpersand
' * Parameters :
' * sInput As String
' **********************************************************************
' * Comments : Remove all the & of a string
' *
' *
' **********************************************************************
Dim sTmp As String
Dim nI As Integer
sTmp = ""
For nI = 1 To Len(sInput)
If (Mid$(sInput, nI, 1) <> "&") Then sTmp = sTmp & Mid$(sInput, nI, 1)
Next
RemoveAmpersand = sTmp
End Function
Function InRunMode(VBInst As VBIDE.VBE) As Boolean
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 04/11/1999
' * Time : 16:52
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : InRunMode
' * Parameters :
' * VBInst As VBIDE.VBE
' **********************************************************************
' * Comments :
' *
' *
' **********************************************************************
InRunMode = (VBInst.CommandBars("File").Controls(1).Enabled = False)
End Function
Sub HandleKeyDown(ud As Object, KeyCode As Integer, Shift As Integer)
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 04/11/1999
' * Time : 16:52
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : HandleKeyDown
' * Parameters :
' * ud As Object
' * KeyCode As Integer
' * Shift As Integer
' **********************************************************************
' * Comments :
' *
' *
' **********************************************************************
If Shift <> 4 Then Exit Sub
If KeyCode < 65 Or KeyCode > 90 Then Exit Sub
If VBInstance.DisplayModel = vbext_dm_SDI Then Exit Sub
If hwndMenu = 0 Then hwndMenu = FindHwndMenu(ud.hWnd)
PostMessage hwndMenu, WM_SYSKEYDOWN, KeyCode, &H20000000
KeyCode = 0
SetFocus hwndMenu
End Sub
Function FindHwndMenu(ByVal hWnd As Long) As Long
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 04/11/1999
' * Time : 16:52
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : FindHwndMenu
' * Parameters :
' * ByVal hwnd As Long
' **********************************************************************
' * Comments :
' *
' *
' **********************************************************************
Dim h As Long
Loop2:
h = GetParent(hWnd)
If h = 0 Then FindHwndMenu = hWnd: Exit Function
hWnd = h
GoTo Loop2
End Function
Public Sub CloseUnusedWindows()
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 9/02/99
' * Time : 12:08
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : CloseUnusedWindows
' * Parameters :
' **********************************************************************
' * Comments : Close all unused windows
' *
' *
' **********************************************************************
Dim pWindow As Window
For Each pWindow In VBInstance.Windows
If Not pWindow Is VBInstance.ActiveWindow Then
If pWindow.Type = 0 Or pWindow.Type = 1 Then pWindow.Close
End If
Next
End Sub
Public Function GetALine(sFile As String) As String
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 03/12/1999
' * Time : 12:31
' * Module Name : Divers_Module
' * Module Filename : Divers.bas
' * Procedure Name : GetALine
' * Parameters :
' * sFile As String
' **********************************************************************
' * Comments :
' * Return the next line
' *
' **********************************************************************
Dim sReturn As String
Dim nPos As Integer
sReturn = ""
nPos = InStr(sFile, vbCrLf)
If nPos = 0 Then
' *** Not found
sReturn = ""
sFile = ""
Else
' *** Found
sReturn = left$(sFile, nPos - 1)
sFile = Mid$(sFile, nPos + 2)
End If
GetALine = sReturn
End Function
Public Sub InputNumeric(nKeyAscii As Integer, ctrName As Control, nDecimal As Boolean)
' #VBIDEUtils#************************************************************
' * Programmer Name : removed
' * Web Site : http://www.ppreview.net
' * E-Mail : removed
' * Date : 10/02/2000
' * Time : 09:59
' * Module Name : Lib_Module
' * Module Filename : Lib.bas
' * Procedure Name : InputNumeric
' * Parameters :
' * nKeyAscii As Integer
' * ctrName As Control
' * nDecimal As Boolean
' **********************************************************************
' * Comments :
' *
' *
' **********************************************************************
' *** N'accepte que les chiffres ***
If nDecimal = True Then
' *** Test si point dÚcimal ***
If nKeyAscii = Asc(".") Then
If InStr(Trim$(ctrName.Text), ".") > 0 Then
If InStr(Trim$(ctrName.SelText), ".") < 1 Then
nKeyAscii = 0
Beep
End If
Exit Sub
End If
Exit Sub
End If
End If
If nKeyAscii = vbKeyBack Or (nKeyAscii > 47 And nKeyAscii < 58) Then
' *** Zone numÚrique ***
Else
nKeyAscii = 0
Beep
End If
End Sub