-
Notifications
You must be signed in to change notification settings - Fork 1
/
Module1.bas
2783 lines (2189 loc) · 95.3 KB
/
Module1.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
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Attribute VB_Name = "Module1"
'@IgnoreModule IntegerDataType, ModuleWithoutFolder
' gaugeForm_BubblingEvent ' leaving that here so I can copy/paste to find it
'---------------------------------------------------------------------------------------
' Module : Module1
' Author : beededea
' Date : 27/04/2023
' Purpose : Module for declaring any public and private constants, APIs and types used by the functions therein.
'---------------------------------------------------------------------------------------
Option Explicit
'------------------------------------------------------ STARTS
'constants used to choose a font via the system dialog window
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND As Long = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const LF_FACESIZE As Integer = 32
Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40&
Private Const CF_SCREENFONTS As Long = &H1
'type declaration used to choose a font via the system dialog window
Private Type FormFontInfo
Name As String
Weight As Integer
Height As Integer
UnderLine As Boolean
Italic As Boolean
Color As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type FONTSTRUC
lStructSize As Long
hwnd As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
Flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Type ChooseColorStruct
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
'APIs used to choose a font via the system dialog window
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' API and enums for acquiring the special folder paths
Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long
Public Enum FolderEnum ' has to be public
feCDBurnArea = 59 ' \Docs & Settings\User\Local Settings\Application Data\Microsoft\CD Burning
feCommonAppData = 35 ' \Docs & Settings\All Users\Application Data
feCommonAdminTools = 47 ' \Docs & Settings\All Users\Start Menu\Programs\Administrative Tools
feCommonDesktop = 25 ' \Docs & Settings\All Users\Desktop
feCommonDocs = 46 ' \Docs & Settings\All Users\Documents
feCommonPics = 54 ' \Docs & Settings\All Users\Documents\Pictures
feCommonMusic = 53 ' \Docs & Settings\All Users\Documents\Music
feCommonStartMenu = 22 ' \Docs & Settings\All Users\Start Menu
feCommonStartMenuPrograms = 23 ' \Docs & Settings\All Users\Start Menu\Programs
feCommonTemplates = 45 ' \Docs & Settings\All Users\Templates
feCommonVideos = 55 ' \Docs & Settings\All Users\Documents\My Videos
feLocalAppData = 28 ' \Docs & Settings\User\Local Settings\Application Data
feLocalCDBurning = 59 ' \Docs & Settings\User\Local Settings\Application Data\Microsoft\CD Burning
feLocalHistory = 34 ' \Docs & Settings\User\Local Settings\History
feLocalTempInternetFiles = 32 ' \Docs & Settings\User\Local Settings\Temporary Internet Files
feProgramFiles = 38 ' \Program Files
feProgramFilesCommon = 43 ' \Program Files\Common Files
'feRecycleBin = 10 ' ???
feUser = 40 ' \Docs & Settings\User
feUserAdminTools = 48 ' \Docs & Settings\User\Start Menu\Programs\Administrative Tools
feUserAppData = 26 ' \Docs & Settings\User\Application Data
feUserCache = 32 ' \Docs & Settings\User\Local Settings\Temporary Internet Files
feUserCookies = 33 ' \Docs & Settings\User\Cookies
feUserDesktop = 16 ' \Docs & Settings\User\Desktop
feUserDocs = 5 ' \Docs & Settings\User\My Documents
feUserFavorites = 6 ' \Docs & Settings\User\Favorites
feUserMusic = 13 ' \Docs & Settings\User\My Documents\My Music
feUserNetHood = 19 ' \Docs & Settings\User\NetHood
feUserPics = 39 ' \Docs & Settings\User\My Documents\My Pictures
feUserPrintHood = 27 ' \Docs & Settings\User\PrintHood
feUserRecent = 8 ' \Docs & Settings\User\Recent
feUserSendTo = 9 ' \Docs & Settings\User\SendTo
feUserStartMenu = 11 ' \Docs & Settings\User\Start Menu
feUserStartMenuPrograms = 2 ' \Docs & Settings\User\Start Menu\Programs
feUserStartup = 7 ' \Docs & Settings\User\Start Menu\Programs\Startup
feUserTemplates = 21 ' \Docs & Settings\User\Templates
feUserVideos = 14 ' \Docs & Settings\User\My Documents\My Videos
feWindows = 36 ' \Windows
feWindowFonts = 20 ' \Windows\Fonts
feWindowsResources = 56 ' \Windows\Resources
feWindowsSystem = 37 ' \Windows\System32
End Enum
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' APIs for useful functions START
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
' APIs for useful functions END
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' Constants and APIs for playing sounds
Public Const SND_ASYNC As Long = &H1 ' play asynchronously
Public Const SND_FILENAME As Long = &H20000 ' name is a file name
Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
'API Functions to read/write information from INI File
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any _
, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long _
, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any _
, ByVal lpString As Any, ByVal lpFileName As String) As Long
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
'constants and APIs defined for querying the registry
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_CURRENT_USER As Long = &H80000001
Private Const REG_SZ As Long = 1 ' Unicode nul terminated string
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByRef lpData As Any, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, ByRef phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Any, ByVal cbData As Long) As Long
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' Enums defined for opening a common dialog box to select files without OCX dependencies
Private Enum FileOpenConstants
'ShowOpen, ShowSave constants.
cdlOFNAllowMultiselect = &H200&
cdlOFNCreatePrompt = &H2000&
cdlOFNExplorer = &H80000
cdlOFNExtensionDifferent = &H400&
cdlOFNFileMustExist = &H1000&
cdlOFNHideReadOnly = &H4&
cdlOFNLongNames = &H200000
cdlOFNNoChangeDir = &H8&
cdlOFNNoDereferenceLinks = &H100000
cdlOFNNoLongNames = &H40000
cdlOFNNoReadOnlyReturn = &H8000&
cdlOFNNoValidate = &H100&
cdlOFNOverwritePrompt = &H2&
cdlOFNPathMustExist = &H800&
cdlOFNReadOnly = &H1&
cdlOFNShareAware = &H4000&
End Enum
' Types defined for opening a common dialog box to select files without OCX dependencies
Private Type OPENFILENAME
lStructSize As Long 'The size of this struct (Use the Len function)
hwndOwner As Long 'The hWnd of the owner window. The dialog will be modal to this window
hInstance As Long 'The instance of the calling thread. You can use the App.hInstance here.
lpstrFilter As String 'Use this to filter what files are showen in the dialog. Separate each filter with Chr$(0). The string also has to end with a Chr(0).
lpstrCustomFilter As String 'The pattern the user has choosed is saved here if you pass a non empty string. I never use this one
nMaxCustFilter As Long 'The maximum saved custom filters. Since I never use the lpstrCustomFilter I always pass 0 to this.
nFilterIndex As Long 'What filter (of lpstrFilter) is showed when the user opens the dialog.
lpstrFile As String 'The path and name of the file the user has chosed. This must be at least MAX_PATH (260) character long.
nMaxFile As Long 'The length of lpstrFile + 1
lpstrFileTitle As String 'The name of the file. Should be MAX_PATH character long
nMaxFileTitle As Long 'The length of lpstrFileTitle + 1
lpstrInitialDir As String 'The path to the initial path :) If you pass an empty string the initial path is the current path.
lpstrTitle As String 'The caption of the dialog.
Flags As FileOpenConstants 'Flags. See the values in MSDN Library (you can look at the flags property of the common dialog control)
nFileOffset As Integer 'Points to the what character in lpstrFile where the actual filename begins (zero based)
nFileExtension As Integer 'Same as nFileOffset except that it points to the file extention.
lpstrDefExt As String 'Can contain the extention Windows should add to a file if the user doesn't provide one (used with the GetSaveFileName API function)
lCustData As Long 'Only used if you provide a Hook procedure (Making a Hook procedure is pretty messy in VB.
lpfnHook As Long 'Pointer to the hook procedure.
lpTemplateName As String 'A string that contains a dialog template resource name. Only used with the hook procedure.
End Type
Private Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long 'LPCITEMIDLIST
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long 'BFFCALLBACK
lParam As Long
iImage As Long
End Type
' vars defined for opening a common dialog box to select files without OCX dependencies
Private x_OpenFilename As OPENFILENAME
' APIs declared for opening a common dialog box to select files without OCX dependencies
Private Declare Function GetOpenFileName Lib "comdlg32" Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long
'Private Declare Function SHBrowseForFolderA Lib "Shell32.dll" (bInfo As BROWSEINFO) As Long
'Private Declare Function SHGetPathFromIDListA Lib "Shell32.dll" (ByVal pidl As Long, ByVal szPath As String) As Long
'Private Declare Function CoTaskMemFree Lib "ole32.dll" (lp As Any) As Long
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'------------------------------------------------------ ENDS
'Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As RECT) As Long
'Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByVal lpRect As RECT) As Long
'
'Public Type RECT
' Left As Long
' Top As Long
' Right As Long ' This is +1 (right - left = width)
' Bottom As Long ' This is +1 (bottom - top = height)
'End Type
'------------------------------------------------------ STARTS
' APIs, constants and types defined for determining the OS version
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Private Const VER_PLATFORM_WIN32s As Long = 0
Private Const VER_PLATFORM_WIN32_WINDOWS As Long = 1
Private Const VER_PLATFORM_WIN32_NT As Long = 2
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' stored vars read from settings.ini
'
' general
Public PzGStartup As String
Public PzGGaugeFunctions As String
'Public PzGAnimationInterval As String
Public PzGSmoothSecondHand As String
'Public PzGClockFaceSwitchPref As String
Public PzGMainGaugeTimeZone As String
Public PzGMainDaylightSaving As String
'Public PzGSecondaryGaugeTimeZone As String
'Public PzGSecondaryDaylightSaving As String
' config
Public PzGEnableTooltips As String
Public PzGEnablePrefsTooltips As String
Public PzGEnableBalloonTooltips As String
Public PzGShowTaskbar As String
Public PzGDpiAwareness As String
Public PzGGaugeSize As String
Public PzGScrollWheelDirection As String
' position
Public PzGAspectHidden As String
Public PzGWidgetPosition As String
Public PzGWidgetLandscape As String
Public PzGWidgetPortrait As String
Public PzGLandscapeFormHoffset As String
Public PzGLandscapeFormVoffset As String
Public PzGPortraitHoffset As String
Public PzGPortraitYoffset As String
Public PzGvLocationPercPrefValue As String
Public PzGhLocationPercPrefValue As String
' sounds
Public PzGEnableSounds As String
' development
Public PzGDebug As String
Public PzGDblClickCommand As String
Public PzGOpenFile As String
Public PzGDefaultEditor As String
' font
Public PzGClockFont As String
Public PzGPrefsFont As String
Public PzGPrefsFontSizeHighDPI As String
Public PzGPrefsFontSizeLowDPI As String
Public PzGPrefsFontItalics As String
Public PzGPrefsFontColour As String
' window
Public PzGWindowLevel As String
Public PzGPreventDragging As String
Public PzGOpacity As String
Public PzGWidgetHidden As String
Public PzGHidingTime As String
Public PzGIgnoreMouse As String
Public PzGFirstTimeRun As String
' General storage variables declared
Public PzGSettingsDir As String
Public PzGSettingsFile As String
Public PzGTrinketsDir As String
Public PzGTrinketsFile As String
Public PzGClockHighDpiXPos As String
Public PzGClockHighDpiYPos As String
Public PzGClockLowDpiXPos As String
Public PzGClockLowDpiYPos As String
Public PzGLastSelectedTab As String
Public PzGSkinTheme As String
Public PzGUnhide As String
' vars stored for positioning the prefs form
Public PzGFormHighDpiXPosTwips As String
Public PzGFormHighDpiYPosTwips As String
Public PzGFormLowDpiXPosTwips As String
Public PzGFormLowDpiYPosTwips As String
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
' General variables declared
'Public toolSettingsFile As String
Public classicThemeCapable As Boolean
Public storeThemeColour As Long
Public windowsVer As String
' vars to obtain correct screen width (to correct VB6 bug)
Public screenWidthTwips As Long
Public screenHeightTwips As Long
Public screenHeightPixels As Long
Public screenWidthPixels As Long
Public oldScreenHeightPixels As Long
Public oldScreenWidthPixels As Long
' key presses
Public CTRL_1 As Boolean
Public SHIFT_1 As Boolean
' other globals
Public debugFlg As Integer
Public minutesToHide As Integer
Public aspectRatio As String
Public oldPzGSettingsModificationTime As Date
Public Const visibleAreaWidth As Long = 648 ' this is the width of the rightmost visible point of the widget - ie. the surround
'------------------------------------------------------ ENDS
'------------------------------------------------------ STARTS
Private Const OF_EXIST As Long = &H4000
Private Const OFS_MAXPATHNAME As Long = 128
Private Const HFILE_ERROR As Long = -1
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, _
lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function PathIsDirectory Lib "shlwapi" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long
Public PzGWindowLevelWasChanged As Boolean
'------------------------------------------------------ ENDS
' Flag for debug mode '.06 DAEB 19/04/2021 common.bas moved to the common area so that it can be used by each of the utilities
Private mbDebugMode As Boolean ' .30 DAEB 03/03/2021 frmMain.frm replaced the inIDE function that used a variant to one without
Public tzDelta As Long
Public tzDelta1 As Long
Public msgBoxADynamicSizingFlg As Boolean
'---------------------------------------------------------------------------------------
' Procedure : fFExists
' Author : RobDog888 https://www.vbforums.com/member.php?17511-RobDog888
' Date : 19/07/2023
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Function fFExists(ByVal Fname As String) As Boolean
Dim lRetVal As Long
Dim OfSt As OFSTRUCT
On Error GoTo fFExists_Error
lRetVal = OpenFile(Fname, OfSt, OF_EXIST)
If lRetVal <> HFILE_ERROR Then
fFExists = True
Else
fFExists = False
End If
On Error GoTo 0
Exit Function
fFExists_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fFExists of Module Module1"
End Function
'---------------------------------------------------------------------------------------
' Procedure : fDirExists
' Author : zeezee https://www.vbforums.com/member.php?90054-zeezee
' Date : 19/07/2023
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Function fDirExists(ByVal pstrFolder As String) As Boolean
On Error GoTo fDirExists_Error
fDirExists = (PathFileExists(pstrFolder) = 1)
If fDirExists Then fDirExists = (PathIsDirectory(pstrFolder) <> 0)
On Error GoTo 0
Exit Function
fDirExists_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fDirExists of Module Module1"
End Function
''---------------------------------------------------------------------------------------
'' Procedure : fFExists
'' Author : beededea
'' Date : 17/10/2019
'' Purpose :
''---------------------------------------------------------------------------------------
''
'Public Function fFExists(ByRef OrigFile As String) As Boolean
' Dim FS As Object
' On Error GoTo fFExists_Error
' 'If debugflg = 1 Then Debug.Print "%fFExists"
'
' Set FS = CreateObject("Scripting.FileSystemObject")
' fFExists = FS.FileExists(OrigFile)
'
' On Error GoTo 0
' Exit Function
'
'fFExists_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fFExists of module module1"
'End Function
'---------------------------------------------------------------------------------------
' Procedure : fDirExists
' Author : beededea
' Date : 17/10/2019
' Purpose :
'---------------------------------------------------------------------------------------
'
'Public Function fDirExists(ByRef OrigFile As String) As Boolean
' Dim FS As Object
' On Error GoTo fDirExists_Error
' '''If debugflg = 1 Then msgBox "%fDirExists"
'
' Set FS = CreateObject("Scripting.FileSystemObject")
' fDirExists = FS.FolderExists(OrigFile)
'
' On Error GoTo 0
' Exit Function
'
'fDirExists_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fDirExists of module module1"
'End Function
'---------------------------------------------------------------------------------------
' Procedure : fExtractSuffix
' Author : beededea
' Date : 20/06/2019
' Purpose : extract the suffix from a filename
'---------------------------------------------------------------------------------------
'
'Public Function fExtractSuffix(ByVal strPath As String) As String
'
'
' Dim stringBits() As String ' string array
' Dim upperBit As Integer: upperBit = 0
'
' On Error GoTo fExtractSuffix_Error
' '''If debugflg = 1 Then DebugPrint "%" & "fnExtractSuffix"
'
' If strPath = vbNullString Then
' fExtractSuffix = vbNullString
' Exit Function
' End If
'
' If InStr(strPath, ".") <> 0 Then
' stringBits = Split(strPath, ".")
' upperBit = UBound(stringBits)
' fExtractSuffix = stringBits(upperBit)
' Else
' fExtractSuffix = strPath
' End If
'
' On Error GoTo 0
' Exit Function
'
'fExtractSuffix_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fExtractSuffix of module module1"
'End Function
'---------------------------------------------------------------------------------------
' Procedure : fExtractSuffixWithDot
' Author : beededea
' Date : 20/06/2019
' Purpose : extract the suffix from a filename
'---------------------------------------------------------------------------------------
'
'Public Function fExtractSuffixWithDot(ByVal strPath As String) As String
'
' Dim stringBits() As String ' string array
' Dim upperBit As Integer: upperBit = 0
'
' On Error GoTo fExtractSuffixWithDot_Error
' '''If debugflg = 1 Then DebugPrint "%" & "fExtractSuffixWithDot"
'
' If strPath = vbNullString Then
' fExtractSuffixWithDot = vbNullString
' Exit Function
' End If
'
' If InStr(strPath, ".") <> 0 Then
' stringBits = Split(strPath, ".")
' upperBit = UBound(stringBits)
' fExtractSuffixWithDot = "." & stringBits(upperBit)
' Else
' fExtractSuffixWithDot = vbNullString
' End If
'
' On Error GoTo 0
' Exit Function
'
'fExtractSuffixWithDot_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fExtractSuffixWithDot of module module1"
'End Function
'---------------------------------------------------------------------------------------
' Procedure : fExtractFileNameNoSuffix
' Author : beededea
' Date : 20/06/2019
' Purpose : extract the filename without a suffix
'---------------------------------------------------------------------------------------
'
'Public Function fExtractFileNameNoSuffix(ByVal strPath As String) As String
'
' Dim stringBits() As String ' string array
' Dim lowerBit As Integer: lowerBit = 0
'
' On Error GoTo fExtractFileNameNoSuffix_Error
' '''If debugflg = 1 Then DebugPrint "%" & "fnExtractFileNameNoSuffix"
'
' If strPath = vbNullString Then
' fExtractFileNameNoSuffix = vbNullString
' Exit Function
' End If
'
' If InStr(strPath, ".") <> 0 Then
' stringBits = Split(strPath, ".")
' lowerBit = LBound(stringBits)
' fExtractFileNameNoSuffix = stringBits(lowerBit)
' Else
' fExtractFileNameNoSuffix = strPath
' End If
'
' On Error GoTo 0
' Exit Function
'
'fExtractFileNameNoSuffix_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fExtractFileNameNoSuffix of module module1"
'End Function
'
'---------------------------------------------------------------------------------------
' Procedure : fLicenceState
' Author : beededea
' Date : 20/06/2019
' Purpose : check the state of the licence
'---------------------------------------------------------------------------------------
'
Public Function fLicenceState() As Integer
Dim slicence As String: slicence = "0"
On Error GoTo fLicenceState_Error
''If debugflg = 1 Then DebugPrint "%" & "fLicenceState"
fLicenceState = 0
' read the tool's own settings file
If fFExists(PzGSettingsFile) Then ' does the tool's own settings.ini exist?
slicence = fGetINISetting("Software\PzJustClock", "licence", PzGSettingsFile)
' if the licence state is not already accepted then display the licence form
If slicence = "1" Then fLicenceState = 1
End If
On Error GoTo 0
Exit Function
fLicenceState_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fLicenceState of Form common"
End Function
'---------------------------------------------------------------------------------------
' Procedure : showLicence
' Author : beededea
' Date : 20/06/2019
' Purpose : check the state of the licence
'---------------------------------------------------------------------------------------
'
Public Sub showLicence(ByVal licenceState As Integer)
Dim slicence As String: slicence = "0"
On Error GoTo showLicence_Error
''If debugflg = 1 Then DebugPrint "%" & "showLicence"
' if the licence state is not already accepted then display the licence form
If licenceState = 0 Then
'Call LoadFileToTB(frmLicence.txtLicenceTextBox, App.Path & "\Resources\txt\licence.txt", False)
Call licenceSplash
End If
On Error GoTo 0
Exit Sub
showLicence_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure showLicence of Form common"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : setDPIaware
' Author : beededea
' Date : 29/10/2023
' Purpose : This sets DPI awareness for the whole program incl. native VB6 forms, requires a program hard restart.
'---------------------------------------------------------------------------------------
'
Public Sub setDPIaware()
On Error GoTo setDPIaware_Error
' Cairo.SetDPIAwareness ' for debugging
' msgBoxADynamicSizingFlg = True
If PzGDpiAwareness = "1" Then
If Not InIDE Then
Cairo.SetDPIAwareness ' this way avoids the VB6 IDE shrinking (sadly, VB6 has a high DPI unaware IDE)
msgBoxADynamicSizingFlg = True
End If
End If
On Error GoTo 0
Exit Sub
setDPIaware_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure setDPIaware of Module modMain"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : testDPIAndSetInitialAwareness
' Author : beededea
' Date : 29/10/2023
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Sub testDPIAndSetInitialAwareness()
On Error GoTo testDPIAndSetInitialAwareness_Error
If fPixelsPerInchX() > 96 Then ' only DPI aware by default when greater than 'standard'
PzGDpiAwareness = "1"
Call setDPIaware
End If
On Error GoTo 0
Exit Sub
testDPIAndSetInitialAwareness_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure testDPIAndSetInitialAwareness of Module Module1"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : LoadFileToTB
' Author : beededea
' Date : 26/08/2019
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Sub LoadFileToTB(ByVal TxtBox As Object, ByVal FilePath As String, Optional ByVal Append As Boolean = False)
'PURPOSE: Loads file specified by FilePath into textcontrol
'(e.g., Text Box, Rich Text Box) specified by TxtBox
'If Append = true, then loaded text is appended to existing
' contents else existing contents are overwritten
'Returns: True if Successful, false otherwise
Dim iFile As Integer: iFile = 0
Dim s As String: s = vbNullString
On Error GoTo LoadFileToTB_Error
''If debugflg = 1 Then msgbox "%" & LoadFileToTB
If Dir$(FilePath) = vbNullString Then Exit Sub
On Error GoTo ErrorHandler:
s = TxtBox.Text
iFile = FreeFile
Open FilePath For Input As #iFile
s = Input(LOF(iFile), #iFile)
If Append Then
TxtBox.Text = TxtBox.Text & s
Else
TxtBox.Text = s
End If
'LoadFileToTB = True
ErrorHandler:
If iFile > 0 Then Close #iFile
On Error GoTo 0
Exit Sub
LoadFileToTB_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure LoadFileToTB of Form common"
End Sub
'
'---------------------------------------------------------------------------------------
' Procedure : fGetINISetting
' Author : beededea
' Date : 05/07/2019
' Purpose : Get the INI Setting from the File
'---------------------------------------------------------------------------------------
'
Public Function fGetINISetting(ByVal sHeading As String, ByVal sKey As String, ByRef sINIFileName As String) As String
On Error GoTo fGetINISetting_Error
Const cparmLen As Integer = 500 ' maximum no of characters allowed in the returned string
Dim sReturn As String * cparmLen ' not going to initialise this with a 500 char string
Dim sDefault As String * cparmLen
Dim lLength As Long: lLength = 0
lLength = GetPrivateProfileString(sHeading, sKey, sDefault, sReturn, cparmLen, sINIFileName)
fGetINISetting = Mid$(sReturn, 1, lLength)
On Error GoTo 0
Exit Function
fGetINISetting_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fGetINISetting of module module1"
End Function
'
'---------------------------------------------------------------------------------------
' Procedure : sPutINISetting
' Author : beededea
' Date : 05/07/2019
' Purpose : Save INI Setting in the File
'---------------------------------------------------------------------------------------
'
Public Sub sPutINISetting(ByVal sHeading As String, ByVal sKey As String, ByVal sSetting As String, ByRef sINIFileName As String)
On Error GoTo sPutINISetting_Error
Dim unusedReturnValue As Long: unusedReturnValue = 0
unusedReturnValue = WritePrivateProfileString(sHeading, sKey, sSetting, sINIFileName)
On Error GoTo 0
Exit Sub
sPutINISetting_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure sPutINISetting of module module1"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : savestring
' Author : beededea
' Date : 05/07/2019
' Purpose :
'---------------------------------------------------------------------------------------
'
Public Sub savestring(ByRef hKey As Long, ByRef strPath As String, ByRef strvalue As String, ByRef strData As String)
Dim keyhand As Long: keyhand = 0
Dim unusedReturnValue As Long: unusedReturnValue = 0
On Error GoTo savestring_Error
unusedReturnValue = RegCreateKey(hKey, strPath, keyhand)
unusedReturnValue = RegSetValueEx(keyhand, strvalue, 0, REG_SZ, ByVal strData, Len(strData))
unusedReturnValue = RegCloseKey(keyhand)
On Error GoTo 0
Exit Sub
savestring_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure savestring of module module1"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : fSpecialFolder
' Author : si_the_geek vbforums
' Date : 17/10/2019
' Purpose : Returns the path to the specified special folder (AppData etc)
'---------------------------------------------------------------------------------------
'
Public Function fSpecialFolder(ByVal pfe As FolderEnum) As String
Const MAX_PATH As Integer = 260
Dim strPath As String: strPath = vbNullString
Dim strBuffer As String: strBuffer = vbNullString
On Error GoTo fSpecialFolder_Error
strBuffer = Space$(MAX_PATH)
If SHGetFolderPath(0, pfe, 0, 0, strBuffer) = 0 Then strPath = Left$(strBuffer, InStr(strBuffer, vbNullChar) - 1)
If Right$(strPath, 1) = "\" Then strPath = Left$(strPath, Len(strPath) - 1)
fSpecialFolder = strPath
On Error GoTo 0
Exit Function
fSpecialFolder_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure fSpecialFolder of Module Module1"
End Function
'---------------------------------------------------------------------------------------
' Procedure : addTargetfile
' Author : beededea
' Date : 30/05/2019
' Purpose : open a dialogbox to select a file as the target, normally a binary
'---------------------------------------------------------------------------------------
'
Public Sub addTargetFile(ByVal fieldValue As String, ByRef retFileName As String)
Dim FilePath As String: FilePath = vbNullString
Dim dialogInitDir As String: dialogInitDir = vbNullString
Dim retfileTitle As String: retfileTitle = vbNullString
Const x_MaxBuffer As Integer = 256
''If debugflg = 1 Then Debug.Print "%" & "addTargetfile"
On Error Resume Next
' set the default folder to the existing reference
If Not fieldValue = vbNullString Then
If fFExists(fieldValue) Then
' extract the folder name from the string
FilePath = fGetDirectory(fieldValue)
' set the default folder to the existing reference
dialogInitDir = FilePath 'start dir, might be "C:\" or so also
ElseIf fDirExists(fieldValue) Then ' this caters for the entry being just a folder name
' set the default folder to the existing reference
dialogInitDir = fieldValue 'start dir, might be "C:\" or so also
Else
dialogInitDir = App.path 'start dir, might be "C:\" or so also
End If
End If
With x_OpenFilename
' .hwndOwner = Me.hWnd
.hInstance = App.hInstance
.lpstrTitle = "Select a File Target"
.lpstrInitialDir = dialogInitDir
.lpstrFilter = "Text Files" & vbNullChar & "*.txt" & vbNullChar & "All Files" & vbNullChar & "*.*" & vbNullChar & vbNullChar
.nFilterIndex = 2
.lpstrFile = String(x_MaxBuffer, 0)
.nMaxFile = x_MaxBuffer - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = x_MaxBuffer - 1
.lStructSize = Len(x_OpenFilename)
End With
Call obtainOpenFileName(retFileName, retfileTitle) ' retfile will be buffered to 256 bytes
On Error GoTo 0
Exit Sub
'addTargetfile_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure addTargetfile of module module1.bas"
End Sub
'---------------------------------------------------------------------------------------
' Procedure : fGetDirectory
' Author : beededea
' Date : 11/07/2019
' Purpose : get the folder or directory path as a string not including the last backslash
'---------------------------------------------------------------------------------------
'
Public Function fGetDirectory(ByRef path As String) As String
On Error GoTo fGetDirectory_Error
''If debugflg = 1 Then DebugPrint "%" & "fnGetDirectory"
If InStrRev(path, "\") = 0 Then
fGetDirectory = vbNullString
Exit Function
End If
fGetDirectory = Left$(path, InStrRev(path, "\") - 1)
On Error GoTo 0
Exit Function
fGetDirectory_Error: