-
Notifications
You must be signed in to change notification settings - Fork 2
/
clsOSInfo.cls
2090 lines (1818 loc) · 85.5 KB
/
clsOSInfo.cls
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
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsOSInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6", "Yes"
Attribute VB_Ext_KEY = "Top_Level", "Yes"
Option Explicit
' OSInfo class by Alex Dragokas
' ver 1.18
'
' Updated to support x64 by Jon Johnson (fafalone)
'
'Tips:
' Versions:
' 10.0* | Windows Server 2022 (ReleaseId 2009+)
' 10.0* | Windows 11 (builds 22000+)
' 10.0* | Windows Server 2016
' 10.0* | Windows 10 (builds 9885+, Insider Preview)
' 6.4* | Windows 10 Technical Preview (builds 9879-)
' 6.3* | Windows Server 2012 R2
' 6.3* | Windows 8.1
' 6.2 | Windows Server 2012
' 6.2 | Windows 8
' 6.1 | Windows Server 2008 R2
' 6.1 | Windows 7
' 6.0 | Windows Server 2008
' 6.0 | Windows Vista
' 5.2 | Windows Server 2003 R2
' 5.2 | Windows Server 2003
' 5.2 | Windows XP 64-Bit Edition
' 5.1 | Windows XP
' 5.0 | Windows 2000
' 4.90 | Windows Me
' 4.10 | Windows 98
' 4.0 | Windows NT Workstation 4.0
' 4.0/4.03 | Windows 95
' Last Service Packs:
' 11 | SP0, ReleaseId=2009+, Build=22000+ (Sun Valley)
' 10 | SP0, ReleaseId=2009+, Build=19043+ (Vibranium)
' 8.1 | SP0, Update 1+, Build=9600
' 8 | SP0, Build=9200
' 7 | SP1, Build=7601
' Vista | SP2, Build=6002
' XP x64 | SP2, Build=3790
' XP x32 | SP3, Build=2600
' 2000 | SP4, Build=2195
' ME | Build=3000
' NT 4.0 | SP6a, Build=1381
' 98 | Build=2222 A
' 95 | Build=950
' Build versions:
' https://en.wikipedia.org/wiki/List_of_Microsoft_Windows_versions
' https://www.techpowerup.com/forums/threads/windows-os-builds-list.167382/
' https://docs.microsoft.com/en-Us/windows-server/get-started/windows-server-release-info
#If VBA7 = 0 Then
Private Enum LongPtr
[_]
End Enum
#End If
Private Enum ePlatformID
Win32S = 0
Win32Windows = 1
Win32NT = 2
WinCE = 3
UNIX = 4
Xbox = 5
MacOSX = 6
End Enum
Private Type RTL_OSVERSIONINFOEXW
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion(127) As Integer
wServicePackMajor As Integer
wServicePackMinor As Integer
wSuiteMask As Integer
wProductType As Byte
wReserved As Byte
End Type
'Private Type OSVERSIONINFOEXW
' dwOSVersionInfoSize As Long
' dwMajorVersion As Long
' dwMinorVersion As Long
' dwBuildNumber As Long
' dwPlatformId As Long
' szCSDVersion(127) As Integer
' wServicePackMajor As Integer
' wServicePackMinor As Integer
' wSuiteMask As Integer
' wProductType As Byte
' wReserved As Byte
'End Type
Private Type SID_IDENTIFIER_AUTHORITY
Value(0 To 5) As Byte
End Type
Private Type SID_AND_ATTRIBUTES
SID As LongPtr
Attributes As Long
End Type
Private Type TOKEN_GROUPS
GroupCount As Long
Groups(0) As SID_AND_ATTRIBUTES
End Type
'Private Type TOKEN_PRIVILEGES
' PrivilegeCount As Long
' LuidLowPart As Long
' LuidHighPart As Long
' Attributes As Long
'End Type
Private Type OBJECT_ATTRIBUTES
Length As Long
RootDirectory As LongPtr
ObjectName As LongPtr
Attributes As Long
SecurityDescriptor As LongPtr
SecurityQualityOfService As LongPtr
End Type
Private Type UNICODE_STRING
Length As Integer
MaximumLength As Integer
Buffer As LongPtr
End Type
Private Type MEMORYSTATUSEX
dwLength As Long
dwMemoryLoad As Long
ullTotalPhys As Currency
ullAvailPhys As Currency
ullTotalPageFile As Currency
ullAvailPageFile As Currency
ullTotalVirtual As Currency
ullAvailVirtual As Currency
ullAvailExtendedVirtual As Currency
End Type
Private Type PDH_FMT_COUNTERVALUE
CStatus As Long
Align(3) As Byte
Data(7) As Byte
End Type
Private Type SECURE_BOOT_STATUS
fEnabled As Byte
fCapable As Byte
End Type
Private Type SYSTEM_CODEINTEGRITY_INFORMATION
Length As Long
CodeIntegrityOptions As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoW" (ByVal LCID As Long, ByVal LCType As Long, ByVal lpLCData As LongPtr, ByVal cchData As Long) As Long
Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function GetSystemDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function GetSystemDefaultLCID Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32.dll" () As Long
Private Declare PtrSafe Function IsWow64Process Lib "kernel32" (ByVal hProcess As LongPtr, Wow64Process As Long) As Long
Private Declare PtrSafe Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As RTL_OSVERSIONINFOEXW) As Long 'OSVERSIONINFOEXW
Private Declare PtrSafe Function RtlGetVersion Lib "ntdll.dll" (lpVersionInformation As RTL_OSVERSIONINFOEXW) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetProductInfo Lib "kernel32" (ByVal dwOSMajorVersion As Long, ByVal dwOSMinorVersion As Long, ByVal dwSpMajorVersion As Long, ByVal dwSpMinorVersion As Long, pdwReturnedProductInfo As Long) As Long
'Private Declare PtrSafe Function CheckTokenMembership Lib "advapi32" (ByVal TokenHandle As LongPtr, ByVal SidToCheck As LongPtr, IsMember As Long) As Long
Private Declare PtrSafe Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As LongPtr, ByVal DesiredAccess As Long, TokenHandle As LongPtr) As Long
Private Declare PtrSafe Function GetTokenInformation Lib "advapi32" (ByVal TokenHandle As LongPtr, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
' Private Declare PtrSafe Function OpenThreadToken Lib "advapi32" (ByVal hThread As LongPtr, ByVal dwDesiredAccess As Long, ByVal bOpenAsSelf As Long, phToken As LongPtr) As Long
' Private Declare PtrSafe Function GetCurrentThread Lib "kernel32" () As LongPtr
Private Declare PtrSafe Function GetCurrentProcess Lib "kernel32" () As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function LocalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function FreeSid Lib "advapi32" (ByVal psid As LongPtr) As LongPtr
Private Declare PtrSafe Function AllocateAndInitializeSid Lib "advapi32" (pIdentifierAuthority As SID_IDENTIFIER_AUTHORITY, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, psid As LongPtr) As Long
Private Declare PtrSafe Function IsValidSid Lib "advapi32" (ByVal psid As LongPtr) As Long
Private Declare PtrSafe Function GetSidSubAuthority Lib "advapi32" (ByVal psid As LongPtr, ByVal nSubAuthority As Long) As LongPtr
Private Declare PtrSafe Function GetSidSubAuthorityCount Lib "advapi32" (ByVal psid As LongPtr) As LongPtr
Private Declare PtrSafe Function EqualSid Lib "advapi32" (ByVal pSid1 As LongPtr, ByVal pSid2 As LongPtr) As Long
Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExW" (ByVal hKey As LongPtr, ByVal lpSubKey As LongPtr, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As LongPtr) As Long
Private Declare PtrSafe Function RegCloseKey Lib "advapi32" (ByVal hKey As LongPtr) As Long
Private Declare PtrSafe Function RegQueryValueExStr Lib "advapi32" Alias "RegQueryValueExW" (ByVal hKey As LongPtr, ByVal lpValueName As LongPtr, ByVal lpReserved As LongPtr, lpType As Long, ByVal szData As LongPtr, lpcbData As Long) As Long
Private Declare PtrSafe Function RegQueryValueExLong Lib "advapi32" Alias "RegQueryValueExW" (ByVal hKey As LongPtr, ByVal lpValueName As LongPtr, ByVal lpReserved As LongPtr, lpType As Long, szData As Long, lpcbData As Long) As Long
Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExW" (ByVal hKey As LongPtr, ByVal lpValueName As LongPtr, ByVal lpReserved As LongPtr, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As LongPtr) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function lstrlenW Lib "kernel32" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
Private Declare PtrSafe Function ConvertSidToStringSid Lib "advapi32" Alias "ConvertSidToStringSidW" (ByVal psid As LongPtr, StringSid As LongPtr) As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As LongPtr) As LongPtr
Private Declare PtrSafe Sub RtlGetNtVersionNumbers Lib "ntdll" (Major As Long, Minor As Long, Build As Long)
'Private Declare PtrSafe Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueW" (ByVal lpSystemName As LongPtr, ByVal lpName As LongPtr, lpLuid As LUID) As Long
'Private Declare PtrSafe Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As LongPtr, ByVal DisableAllPrivileges As Long, ByRef NewState As Any, ByVal BufferLength As Long, ByRef PreviousState As Any, ByRef ReturnLength As Long) As Long
Private Declare PtrSafe Function OpenThreadToken Lib "advapi32" (ByVal hThread As LongPtr, ByVal dwDesiredAccess As Long, ByVal bOpenAsSelf As Long, phToken As LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThread Lib "kernel32" () As LongPtr
Private Declare PtrSafe Function NtOpenSymbolicLinkObject Lib "ntdll" (LinkHandle As LongPtr, ByVal DesiredAccess As Long, ObjectAttributes As OBJECT_ATTRIBUTES) As Long
Private Declare PtrSafe Function NtOpenDirectoryObject Lib "ntdll" (DirectoryHandle As LongPtr, ByVal DesiredAccess As Long, ObjectAttributes As OBJECT_ATTRIBUTES) As Long
Private Declare PtrSafe Function NtClose Lib "ntdll" (ByVal ObjectHandle As LongPtr) As Long
'Private Declare PtrSafe Function IsOS Lib "Shlwapi.dll" Alias "#437" (ByVal dwOS As Long) As Long
Private Declare PtrSafe Function GetUserName Lib "advapi32" Alias "GetUserNameW" (ByVal lpBuffer As LongPtr, nSize As Long) As Long
Private Declare PtrSafe Function GetComputerName Lib "kernel32" Alias "GetComputerNameW" (ByVal lpBuffer As LongPtr, nSize As Long) As Long
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function GlobalMemoryStatusEx Lib "kernel32" (ByRef lpBuffer As MEMORYSTATUSEX) As Long
Private Declare PtrSafe Function PdhOpenQuery Lib "Pdh.dll" Alias "PdhOpenQueryW" (ByVal szDataSource As LongPtr, ByVal dwUserData As LongPtr, phQuery As LongPtr) As Long
Private Declare PtrSafe Function PdhCloseQuery Lib "Pdh.dll" (ByVal QueryHandle As LongPtr) As Long
Private Declare PtrSafe Function PdhAddEnglishCounter Lib "Pdh.dll" Alias "PdhAddEnglishCounterW" (ByVal hQuery As LongPtr, ByVal szFullCounterPath As String, ByVal dwUserData As LongPtr, phCounter As LongPtr) As Long
Private Declare PtrSafe Function PdhCollectQueryData Lib "Pdh.dll" (ByVal hQuery As LongPtr) As Long
Private Declare PtrSafe Function PdhGetFormattedCounterValue Lib "Pdh.dll" (ByVal hCounter As LongPtr, ByVal dwFormat As Long, lpdwType As Long, pValue As PDH_FMT_COUNTERVALUE) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare PtrSafe Function NtQuerySystemInformation Lib "ntdll" (ByVal SystemInformationClass As Long, SystemInformation As Any, ByVal SystemInformationLength As Long, ReturnLength As Long) As Long
#Else
Private Declare Function GetLocaleInfo Lib "kernel32.dll" Alias "GetLocaleInfoW" (ByVal lcid As Long, ByVal LCTYPE As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long
Private Declare Function GetUserDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare Function GetSystemDefaultUILanguage Lib "kernel32.dll" () As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32.dll" () As Long
Private Declare Function GetUserDefaultLCID Lib "kernel32.dll" () As Long
Private Declare Function IsWow64Process Lib "kernel32.dll" (ByVal hProc As Long, bWow64Process As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExW" (lpVersionInformation As RTL_OSVERSIONINFOEXW) As Long 'OSVERSIONINFOEXW
Private Declare Function RtlGetVersion Lib "ntdll.dll" (lpVersionInformation As RTL_OSVERSIONINFOEXW) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetProductInfo Lib "kernel32.dll" (ByVal dwOSMajorVersion As Long, ByVal dwOSMinorVersion As Long, ByVal dwSpMajorVersion As Long, ByVal dwSpMinorVersion As Long, pdwReturnedProductType As Long) As Long
'Private Declare Function CheckTokenMembership Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal SidToCheck As Long, IsMember As Long) As Long
Private Declare Function OpenProcessToken Lib "Advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "Advapi32.dll" (ByVal TokenHandle As Long, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ReturnLength As Long) As Long
'Private Declare Function OpenThreadToken Lib "advapi32.dll" (ByVal ThreadHandle As Long, ByVal DesiredAccess As Long, ByVal OpenAsSelf As Long, TokenHandle As Long) As Long
'Private Declare Function GetCurrentThread Lib "kernel32.dll" () As Long
Private Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (dest As Any, Source As Any, ByVal lSize As Long)
'Private Declare Function GetMem4 Lib "msvbvm60.dll" (Src As Any, Dst As Any) As Long - Incompat. VBA
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function LocalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Sub FreeSid Lib "Advapi32.dll" (ByVal pSid As Long)
Private Declare Function AllocateAndInitializeSid Lib "Advapi32.dll" (pIdentifierAuthority As Any, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Function IsValidSid Lib "Advapi32.dll" (ByVal pSid As Long) As Long
Private Declare Function GetSidSubAuthority Lib "Advapi32.dll" (ByVal pSid As Long, ByVal nSubAuthority As Long) As Long
Private Declare Function GetSidSubAuthorityCount Lib "Advapi32.dll" (ByVal pSid As Long) As Long
Private Declare Function EqualSid Lib "Advapi32.dll" (pSid1 As Any, pSid2 As Any) As Long
Private Declare Function RegOpenKeyEx Lib "Advapi32.dll" Alias "RegOpenKeyExW" (ByVal hKey As Long, ByVal lpSubKey As Long, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "Advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExStr Lib "Advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal szData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "Advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, szData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueEx Lib "Advapi32.dll" Alias "RegQueryValueExW" (ByVal hKey As Long, ByVal lpValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Any, lpcbData As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryW" (ByVal lpFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32.dll" (ByVal lpStrDest As Long, ByVal lpStrSrc As Long) As Long
Private Declare Function ConvertSidToStringSid Lib "Advapi32.dll" Alias "ConvertSidToStringSidW" (ByVal pSid As Long, StringSid As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Declare Sub RtlGetNtVersionNumbers Lib "ntdll.dll" (Major As Long, Minor As Long, Build As Long)
'Private Declare Function LookupPrivilegeValue Lib "Advapi32.dll" Alias "LookupPrivilegeValueW" (ByVal lpSystemName As Long, ByVal lpName As Long, lpLuid As Long) As Long
'Private Declare Function AdjustTokenPrivileges Lib "Advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, ByVal PreviousState As Long, ByVal ReturnLength As Long) As Long
Private Declare Function OpenThreadToken Lib "Advapi32.dll" (ByVal ThreadHandle As Long, ByVal DesiredAccess As Long, ByVal OpenAsSelf As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentThread Lib "kernel32.dll" () As Long
Private Declare Function NtOpenSymbolicLinkObject Lib "ntdll.dll" (LinkHandle As Long, ByVal DesiredAccess As Long, ObjectAttributes As OBJECT_ATTRIBUTES) As Long
'Private Declare Function NtOpenDirectoryObject Lib "ntdll.dll" (DirectoryHandle As Long, ByVal DesiredAccess As Long, ObjectAttributes As OBJECT_ATTRIBUTES) As Long
Private Declare Function NtClose Lib "ntdll.dll" (ByVal Handle As Long) As Long
'Private Declare Function IsOS Lib "Shlwapi.dll" Alias "#437" (ByVal dwOS As Long) As Long
Private Declare Function GetUserName Lib "Advapi32.dll" Alias "GetUserNameW" (ByVal lpBuffer As Long, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameW" (ByVal lpBuffer As Long, nSize As Long) As Long
Private Declare Function lstrlen Lib "kernel32.dll" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function GlobalMemoryStatusEx Lib "kernel32.dll" (lpBuffer As MEMORYSTATUSEX) As Long
Private Declare Function PdhOpenQuery Lib "Pdh.dll" Alias "PdhOpenQueryW" (ByVal szDataSource As Long, ByVal dwUserData As Long, phQuery As Long) As Long
Private Declare Function PdhCloseQuery Lib "Pdh.dll" (ByVal QueryHandle As Long) As Long
Private Declare Function PdhAddEnglishCounter Lib "Pdh.dll" Alias "PdhAddEnglishCounterW" (ByVal hQuery As Long, ByVal szFullCounterPath As Long, ByVal dwUserData As Long, phCounter As Long) As Long
Private Declare Function PdhCollectQueryData Lib "Pdh.dll" (ByVal hQuery As Long) As Long
Private Declare Function PdhGetFormattedCounterValue Lib "Pdh.dll" (ByVal hCounter As Long, ByVal dwFormat As Long, lpdwType As Long, pValue As PDH_FMT_COUNTERVALUE) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long
' Private Declare Function GetMem8 Lib "msvbvm60.dll" (Src As Any, Dst As Any) As Long 'VBA unsupported
Private Declare Function NtQuerySystemInformation Lib "ntdll.dll" (ByVal infoClass As Long, Buffer As Any, ByVal BufferSize As Long, ret As Long) As Long
#End If
Private Const MAX_PATH As Long = 260&
Private Const SM_SERVERR2 As Long = 89&
Private Const SM_MEDIACENTER As Long = 87&
Private Const SM_STARTER As Long = 88&
Private Const SM_TABLETPC As Long = 86&
Private Const SM_CLEANBOOT As Long = 67&
Private Const VER_SUITE_STORAGE_SERVER As Long = &H2000&
Private Const VER_SUITE_DATACENTER As Long = &H80&
Private Const VER_SUITE_PERSONAL As Long = &H200&
Private Const VER_SUITE_ENTERPRISE As Long = 2&
Private Const VER_SUITE_BACKOFFICE As Long = 4
Private Const VER_SUITE_BLADE As Long = &H400&
Private Const VER_SUITE_COMPUTE_SERVER As Long = &H4000&
Private Const VER_SUITE_EMBEDDEDNT As Long = &H40&
Private Const VER_SUITE_SINGLEUSERTS As Long = &H100&
Private Const VER_SUITE_SMALLBUSINESS As Long = 1
Private Const VER_SUITE_SMALLBUSINESS_RESTRICTED As Long = &H20&
Private Const VER_SUITE_TERMINAL As Long = &H10&
Private Const VER_SUITE_WH_SERVER As Long = &H8000&
Private Const VER_NT_WORKSTATION As Long = 1&
Private Const VER_NT_DOMAIN_CONTROLLER As Long = 2&
Private Const VER_NT_SERVER As Long = 3&
'Private Const LOCALE_SYSTEM_DEFAULT As Long = &H800&
'Private Const LOCALE_USER_DEFAULT As Long = &H400&
Private Const LOCALE_SENGLANGUAGE As Long = &H1001&
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const KEY_WOW64_64KEY As Long = &H100&
Private Const DIRECTORY_QUERY As Long = 1&
Private Const CODEINTEGRITY_OPTION_TESTSIGN As Long = 2&
Private Const CODEINTEGRITY_OPTION_DEBUGMODE_ENABLED As Long = &H80&
Private Const CODEINTEGRITY_OPTION_HVCI_KMCI_ENABLED As Long = &H400&
Private Const CODEINTEGRITY_OPTION_HVCI_KMCI_AUDITMODE_ENABLED As Long = &H800&
Private Const CODEINTEGRITY_OPTION_HVCI_KMCI_STRICTMODE_ENABLED As Long = &H1000&
Private Const CODEINTEGRITY_OPTION_HVCI_IUM_ENABLED As Long = &H2000&
Private Const SystemSecureBootInformation As Long = &H91&
Private Const SystemCodeIntegrityInformation As Long = &H67&
Private Const STATUS_SUCCESS As Long = 0&
Private Const ERROR_SUCCESS As Long = 0&
Private Const TOKEN_QUERY As Long = &H8&
'Private Const ERROR_NO_TOKEN As Long = 1008&
Private Const TokenElevation As Long = 20&
'Private Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
'Private Const SE_PRIVILEGE_ENABLED As Long = 2&
'Private Const STATUS_ACCESS_DENIED As Long = &HC0000022
Private Const STATUS_OBJECT_NAME_NOT_FOUND As Long = &HC0000034
Private Const STATUS_INVALID_INFO_CLASS As Long = &HC0000003
Private Const PDH_FMT_LONG As Long = &H100&
Private Const PDH_FMT_DOUBLE As Long = &H200&
Dim osi As RTL_OSVERSIONINFOEXW
Dim OSName_ As String
Dim Bitness_ As String
Dim Edition_ As String
Dim MajorMinor_ As Single
Dim MajorMinorNTDLL_ As Single
Dim NtDllVersion_ As String
Dim Revision_ As Long
Dim SPver_ As Single
Dim IsSafeBoot_ As Boolean
Dim IsElevated_ As Boolean
Dim IntegrityLevel_ As String
Dim UserType_ As String
Dim UserName_ As String
Dim ComputerName_ As String
Dim IsWindowsXPOrGreater_ As Boolean
Dim IsWindowsVistaOrGreater_ As Boolean
Dim IsWindows7OrGreater_ As Boolean
Dim IsWindows8OrGreater_ As Boolean
Dim IsWindows8Point1OrGreater_ As Boolean
Dim IsWindows10OrGreater_ As Boolean
Dim IsWindows11OrGreater_ As Boolean
Dim IsWindows2000_ As Boolean
Dim IsWindowsXP_ As Boolean
Dim IsWindowsVista_ As Boolean
Dim IsWindows7_ As Boolean
Dim IsWindows8_ As Boolean
Dim IsWindows8Point1_ As Boolean
Dim IsWindows10_ As Boolean
Dim LangSystemName_ As String
Dim LangSystemNameFull_ As String
Dim LangSystemCode_ As Long
Dim LangDisplayName_ As String
Dim LangDisplayNameFull_ As String
Dim LangDisplayCode_ As Long
Dim LangNonUnicodeName_ As String
Dim LangNonUnicodeNameFull_ As String
Dim LangNonUnicodeCode_ As Long
Dim CodepageOEM_ As String
Dim CodepageANSI_ As String
Dim CodepageOEM_File_ As String
Dim CodepageANSI_File_ As String
Dim SuiteMask_ As String 'As Integer
Dim ProductType_ As String 'As Byte
Dim SID_CurrentProcess_ As String
Dim SafeBootMode_ As String
Dim Platform_ As String 'Win9x / WinNT
Dim ReleaseId_ As Long
Dim DisplayVersion_ As String
Dim IsServer_ As Boolean
Dim IsDomainController_ As Boolean
Dim inIDE As Boolean
Dim IsWin64_ As Boolean
Dim IsWin32_ As Boolean
Dim SecureBoot_ As Boolean
Dim SecureBootSupported_ As Boolean
Dim TestSigning_ As Boolean
Dim DebugMode_ As Boolean
Dim CodeIntegrity_ As Boolean
Dim PlatformID_ As Long
Dim IsLocalSystemContext_ As Boolean
Dim IsAdminGroup_ As Boolean
Dim IsSystemCaseSensitive_ As Boolean
Dim IsEmbedded_ As Boolean
Dim LCID_UserDefault_ As Long
Dim m_hCpuQuery As LongPtr
Dim m_hCpuCounter As LongPtr
Dim m_Pid As Long
Private Sub Class_Initialize()
On Error GoTo ErrorHandler
Dim dec As Single
Dim ProductType As Long
Dim lret As Long
Dim pos As Long
Dim tmp As String
Dim hLib As LongPtr
Dim dwMajor As Long
Dim dwMinor As Long
Dim dwBuild As Long
Debug.Assert MakeTrue(inIDE)
m_Pid = GetCurrentProcessId()
LangDisplayCode_ = GetUserDefaultUILanguage Mod &H10000
LangDisplayName_ = GetLangNameByCultureCode(LangDisplayCode_)
LangDisplayNameFull_ = GetLangNameFullByCultureCode(LangDisplayCode_)
LangSystemCode_ = GetSystemDefaultUILanguage Mod &H10000
LangSystemName_ = GetLangNameByCultureCode(LangSystemCode_)
LangSystemNameFull_ = GetLangNameFullByCultureCode(LangSystemCode_)
LangNonUnicodeCode_ = GetSystemDefaultLCID Mod &H10000
LangNonUnicodeName_ = GetLangNameByCultureCode(LangNonUnicodeCode_)
LangNonUnicodeNameFull_ = GetLangNameFullByCultureCode(LangNonUnicodeCode_)
LCID_UserDefault_ = GetUserDefaultLCID()
osi.dwOSVersionInfoSize = Len(osi)
If (STATUS_SUCCESS <> RtlGetVersion(osi)) Then
GetVersionEx osi
End If
If inIDE Then
'query correct OS version without manifest
Dim oWMI As Object
Dim colOS As Object
Dim oOS As Object
Dim Ver() As String
Set oWMI = CreateObject("winmgmts:{impersonationLevel=Impersonate}!\\.\root\cimv2")
Set colOS = oWMI.ExecQuery("Select * from Win32_OperatingSystem")
For Each oOS In colOS
pos = InStr(oOS.Version, ".")
If pos = 0 Then
osi.dwMajorVersion = CLng(oOS.Version)
osi.dwMinorVersion = 0
osi.dwBuildNumber = 0
Else
Ver = Split(oOS.Version, ".")
If UBound(Ver) = 1 Then
osi.dwMajorVersion = CLng(Ver(0))
osi.dwMinorVersion = CLng(Ver(1))
osi.dwBuildNumber = 0
Else
osi.dwMajorVersion = CLng(Ver(0))
osi.dwMinorVersion = CLng(Ver(1))
osi.dwBuildNumber = CLng(Ver(2))
End If
End If
Next
Set oOS = Nothing
Set colOS = Nothing
Set oWMI = Nothing
End If
If osi.dwMajorVersion >= 6 Then
If PdhOpenQuery(0, 0, m_hCpuQuery) = ERROR_SUCCESS Then ' https://stackoverflow.com/a/64166/10205274
'not supported in XP
If PdhAddEnglishCounter(m_hCpuQuery, StrPtr("\Processor(_Total)\% Processor Time"), 0, m_hCpuCounter) = ERROR_SUCCESS Then
PdhCollectQueryData m_hCpuQuery
End If
End If
End If
' If IsWow64() Then IsWin64_ = True 'VB6 is always x86
#If Win64 Then
IsWin64_ = True
#Else
IsWin64_ = IsWow64()
#End If
IsWin32_ = Not IsWin64_
Bitness_ = IIf(IsWin64_, "x64", "x32")
lret = GetSystemMetrics(SM_CLEANBOOT)
IsSafeBoot_ = (lret > 0)
Select Case lret
Case 1
SafeBootMode_ = "Safe mode (no Networking)"
Case 2
SafeBootMode_ = "Safe mode with Networking"
Case Else
SafeBootMode_ = "Normal"
End Select
' OS Major + Minor
dec = osi.dwMinorVersion
If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
MajorMinor_ = osi.dwMajorVersion + dec
' Service Pack Major + Minor
dec = osi.wServicePackMinor
If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
SPver_ = osi.wServicePackMajor + dec
'getting ntdll.dll version
hLib = GetProcAddress(GetModuleHandle(StrPtr("ntdll.dll")), "RtlGetNtVersionNumbers")
If hLib <> 0 Then
RtlGetNtVersionNumbers dwMajor, dwMinor, dwBuild
dwBuild = dwBuild And &H3FFF&
NtDllVersion_ = dwMajor & "." & dwMinor & "." & dwBuild
dec = dwMinor
If dec <> 0 Then Do: dec = dec / 10: Loop Until dec < 1
MajorMinorNTDLL_ = dwMajor + dec
End If
If MajorMinor_ >= 10 Then
'Get ReleaseId for Windows 10
tmp = RegRead_REG_SZ("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "ReleaseId")
If IsNumeric(tmp) Then ReleaseId_ = CLng(tmp)
End If
DisplayVersion_ = RegRead_REG_SZ("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "DisplayVersion")
'OS Version List:
'https://msdn.microsoft.com/en-us/library/windows/desktop/ms724833(v=vs.85).aspx
'https://docs.microsoft.com/en-Us/windows-server/get-started/windows-server-release-info
PlatformID_ = osi.dwPlatformId
If osi.dwPlatformId = Win32S Then
OSName_ = "Windows 3.1"
Platform_ = "Win3x"
ElseIf osi.dwPlatformId = Win32Windows Then
'Win 9x
Platform_ = "Win9x"
If osi.dwMajorVersion = 4 Then
Select Case osi.dwMinorVersion
'4.0
Case 0 'Windows 95 [A/B/C]
OSName_ = "Windows 95"
If ChrW$(osi.szCSDVersion(0)) = "B" Or ChrW$(osi.szCSDVersion(0)) = "C" Then
Edition_ = "OSR2"
End If
'4.10
Case 10 'Windows 98 [Gold/SE]
OSName_ = "Windows 98"
If ChrW$(osi.szCSDVersion(0)) = "B" Or ChrW$(osi.szCSDVersion(0)) = "C" Then
Edition_ = "Second Edition"
Else
Edition_ = "Gold"
End If
'4.90
Case 90 'Windows Millennium Edition
OSName_ = "Windows ME"
End Select
End If
ElseIf osi.dwPlatformId = Win32NT Then
Platform_ = "WinNT"
Select Case MajorMinor_
Case 10
Dim bIsWin11Core As Boolean
bIsWin11Core = (0 <> GetProcAddress(GetModuleHandle(StrPtr("kernel32.dll")), "GetTempPath2W"))
If osi.wProductType = VER_NT_WORKSTATION Then
If osi.dwBuildNumber >= 22000 And bIsWin11Core Then
OSName_ = "Windows 11"
IsWindows11OrGreater_ = True
Else
OSName_ = "Windows 10"
End If
Else
If ReleaseId_ >= 2009 Then
If bIsWin11Core Then
OSName_ = "Windows Server 2022"
IsWindows11OrGreater_ = True
Else
OSName_ = "Windows Unknown"
End If
ElseIf ReleaseId_ >= 1803 Then
OSName_ = "Windows Server 2019"
Else
OSName_ = "Windows Server 2016"
End If
End If
Case 6.4
OSName_ = "Windows 10"
Edition_ = "Technical Preview"
Case 6.3
If osi.wProductType = VER_NT_WORKSTATION Then
OSName_ = "Windows 8.1"
Else
OSName_ = "Windows Server 2012 R2"
End If
Case 6.2
If osi.wProductType = VER_NT_WORKSTATION Then
OSName_ = "Windows 8"
Else
OSName_ = "Windows Server 2012"
End If
Case 6.1
If osi.wProductType = VER_NT_WORKSTATION Then
OSName_ = "Windows 7"
Else
OSName_ = "Windows Server 2008 R2"
End If
Case 6
If osi.wProductType = VER_NT_WORKSTATION Then
OSName_ = "Windows Vista"
Else
OSName_ = "Windows Server 2008"
End If
Case 5.2
If osi.wProductType = VER_NT_SERVER Or osi.wProductType = VER_NT_DOMAIN_CONTROLLER Then
OSName_ = "Windows Server 2003"
If GetSystemMetrics(SM_SERVERR2) Then
Edition_ = "R2"
ElseIf osi.wSuiteMask And VER_SUITE_DATACENTER Then
Edition_ = "Datacenter"
ElseIf osi.wSuiteMask And VER_SUITE_ENTERPRISE Then
Edition_ = "Enterprise"
ElseIf osi.wSuiteMask And VER_SUITE_BLADE Then
Edition_ = "Web Edition"
ElseIf osi.wSuiteMask And VER_SUITE_STORAGE_SERVER Then
Edition_ = "Storage"
ElseIf osi.wSuiteMask And VER_SUITE_WH_SERVER Then
Edition_ = "Home"
Else
Edition_ = "Standard"
End If
ElseIf osi.wProductType = VER_NT_WORKSTATION And IsWin64_ Then
OSName_ = "Windows XP"
Edition_ = "Professional"
End If
Case 5.1
OSName_ = "Windows XP"
If GetSystemMetrics(SM_MEDIACENTER) Then
Edition_ = "Media Center Edition"
ElseIf GetSystemMetrics(SM_STARTER) Then
Edition_ = "Starter Edition"
ElseIf GetSystemMetrics(SM_TABLETPC) Then
Edition_ = "Tablet PC Edition"
ElseIf osi.wSuiteMask = VER_SUITE_PERSONAL Then
Edition_ = "Home Edition"
Else
Edition_ = "Professional"
End If
Case 5
OSName_ = "Windows 2000"
If osi.wProductType = VER_NT_WORKSTATION Then
If osi.wSuiteMask And VER_SUITE_PERSONAL Then
Edition_ = "Home"
ElseIf GetSystemMetrics(SM_TABLETPC) = 0 Then
Edition_ = "Professional"
Else
Edition_ = "Tablet Edition"
End If
Else
If osi.wSuiteMask And VER_SUITE_DATACENTER Then
Edition_ = "Datacenter Server"
ElseIf osi.wSuiteMask And VER_SUITE_ENTERPRISE Then
Edition_ = "Advanced Server"
Else
Edition_ = "Server"
End If
End If
Case 4
OSName_ = "Windows NT 4.0"
If osi.wProductType = VER_NT_WORKSTATION Then
Edition_ = "Workstation"
Else
If osi.wSuiteMask And VER_SUITE_ENTERPRISE Then
Edition_ = "Enterprise Server"
Else
Edition_ = "Standard Server"
End If
End If
Case 3
OSName_ = "Windows NT 3.51"
End Select
ElseIf osi.dwPlatformId = WinCE Then
OSName_ = "Windows CE"
Platform_ = "WinCE"
ElseIf osi.dwPlatformId = UNIX Then
OSName_ = "Unix"
Platform_ = "Unix"
End If
IsWindows2000_ = (MajorMinor_ = 5)
IsWindowsXPOrGreater_ = (MajorMinor_ >= 5.1)
IsWindowsXP_ = (MajorMinor_ >= 5.1 And MajorMinor_ < 6)
IsWindowsVistaOrGreater_ = (MajorMinor_ >= 6)
IsWindowsVista_ = (MajorMinor_ = 6)
IsWindows7OrGreater_ = (MajorMinor_ >= 6.1)
IsWindows7_ = (MajorMinor_ = 6.1)
IsWindows8OrGreater_ = (MajorMinor_ >= 6.2)
IsWindows8_ = (MajorMinor_ = 6.2)
IsWindows8Point1OrGreater_ = (MajorMinor_ >= 6.3)
IsWindows8Point1_ = (MajorMinor_ = 6.3)
IsWindows10OrGreater_ = (MajorMinor_ >= 6.4)
IsWindows10_ = IsWindows10OrGreater_ And Not IsWindows11OrGreater_
If Len(OSName_) = 0 Then
OSName_ = "Windows Unknown" & "(ver: " & MajorMinor_ & ". PT: " & osi.wProductType & ". Build: " & osi.dwBuildNumber & ")" & " Registry's data: " & _
RegRead_REG_SZ("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "ProductName")
End If
'Ðåäàêöèÿ
If Len(Edition_) = 0 Then
If MajorMinor_ >= 6 Then
If GetProductInfo(osi.dwMajorVersion, osi.dwMinorVersion, osi.wServicePackMajor, osi.wServicePackMinor, ProductType) Then
Edition_ = GetProductName(ProductType)
End If
End If
End If
Revision_ = RegRead_REG_DWORD("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "UBR")
IsServer_ = (osi.wProductType <> VER_NT_WORKSTATION)
If osi.wProductType = VER_NT_DOMAIN_CONTROLLER Then
IsDomainController_ = True
Edition_ = LTrim$(Edition_ & " (Domain Controller)")
End If
IsElevated_ = IsProcessElevated()
IntegrityLevel_ = GetIntegrityLevel()
UserType_ = GetUserType()
UserName_ = GetUserName_()
ComputerName_ = GetComputerName_()
IsAdminGroup_ = (UserType_ = "Administrators")
GetCodePageInfo
' wSuiteMask
If osi.wSuiteMask And VER_SUITE_BACKOFFICE Then SuiteMask_ = SuiteMask_ & " + " & "BackOffice"
If osi.wSuiteMask And VER_SUITE_BLADE Then SuiteMask_ = SuiteMask_ & " + " & "Blade"
If osi.wSuiteMask And VER_SUITE_COMPUTE_SERVER Then SuiteMask_ = SuiteMask_ & " + " & "Compute Server"
If osi.wSuiteMask And VER_SUITE_DATACENTER Then SuiteMask_ = SuiteMask_ & " + " & "DataCenter"
If osi.wSuiteMask And VER_SUITE_ENTERPRISE Then SuiteMask_ = SuiteMask_ & " + " & "Enterprise"
If osi.wSuiteMask And VER_SUITE_EMBEDDEDNT Then SuiteMask_ = SuiteMask_ & " + " & "EmbeddedNT"
If osi.wSuiteMask And VER_SUITE_PERSONAL Then SuiteMask_ = SuiteMask_ & " + " & "Personal"
If osi.wSuiteMask And VER_SUITE_SINGLEUSERTS Then SuiteMask_ = SuiteMask_ & " + " & "SingleUserTS"
If osi.wSuiteMask And VER_SUITE_SMALLBUSINESS Then SuiteMask_ = SuiteMask_ & " + " & "SmallBusiness"
If osi.wSuiteMask And VER_SUITE_SMALLBUSINESS_RESTRICTED Then SuiteMask_ = SuiteMask_ & " + " & "SmallBusiness Restricted"
If osi.wSuiteMask And VER_SUITE_STORAGE_SERVER Then SuiteMask_ = SuiteMask_ & " + " & "Storage Server"
If osi.wSuiteMask And VER_SUITE_TERMINAL Then SuiteMask_ = SuiteMask_ & " + " & "Terminal"
If osi.wSuiteMask And VER_SUITE_WH_SERVER Then SuiteMask_ = SuiteMask_ & " + " & "WH Server"
If 0 <> Len(SuiteMask_) Then SuiteMask_ = Mid$(SuiteMask_, 4)
' wProductType
Select Case osi.wProductType
Case VER_NT_DOMAIN_CONTROLLER
ProductType_ = "Domain Controller"
Case VER_NT_SERVER
ProductType_ = "Server"
Case VER_NT_WORKSTATION
ProductType_ = "Workstation"
End Select
SID_CurrentProcess_ = GetCurrentProcessSID()
IsLocalSystemContext_ = (SID_CurrentProcess_ = "S-1-5-18")
Call GetSecureBootState(SecureBootSupported_, SecureBoot_)
Dim codeIntegrityFlags As Long
codeIntegrityFlags = GetCodeIntegrityFlags()
TestSigning_ = codeIntegrityFlags And CODEINTEGRITY_OPTION_TESTSIGN
DebugMode_ = codeIntegrityFlags And CODEINTEGRITY_OPTION_DEBUGMODE_ENABLED
CodeIntegrity_ = codeIntegrityFlags And _
(CODEINTEGRITY_OPTION_HVCI_KMCI_ENABLED Or CODEINTEGRITY_OPTION_HVCI_KMCI_AUDITMODE_ENABLED Or _
CODEINTEGRITY_OPTION_HVCI_KMCI_STRICTMODE_ENABLED Or CODEINTEGRITY_OPTION_HVCI_IUM_ENABLED)
'http://www.nicklowe.org/2012/02/understanding-case-sensitivity-in-windows-obcaseinsensitive-file_case_sensitive_search/
Dim hDir As LongPtr
Dim OA As OBJECT_ATTRIBUTES
Dim UniStr As UNICODE_STRING
If Me.MajorMinor <= 5 Then 'Win2000-
IsSystemCaseSensitive_ = True
Else
With UniStr
.Length = LenB("\SYSTEMROOT")
.MaximumLength = .Length
.Buffer = StrPtr("\SYSTEMROOT")
End With
With OA
.Length = LenB(OA)
.ObjectName = VarPtr(UniStr)
.Attributes = 0
End With
lret = NtOpenSymbolicLinkObject(hDir, DIRECTORY_QUERY, OA)
If hDir <> 0 Then NtClose hDir
If lret = STATUS_OBJECT_NAME_NOT_FOUND Then
IsSystemCaseSensitive_ = True
End If
End If
'For some reason, doesn't return correct result (at least, for Windows 8.1 Embedded Industry Pro)
'
'Const OS_EMBEDDED As Long = 13&
'Dim iHasFeature As Long
'iHasFeature = IsOS(OS_EMBEDDED)
Dim sEditionID$, sProductName$
sEditionID = RegRead_REG_SZ("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "EditionID")
sProductName = RegRead_REG_SZ("SOFTWARE\Microsoft\Windows NT\CurrentVersion", "ProductName")
IsEmbedded_ = (osi.wSuiteMask And VER_SUITE_EMBEDDEDNT) Or _
(InStr(1, sEditionID, "Embedded", 1) <> 0) Or _
(InStr(1, sProductName, "Embedded", 1) <> 0)
If InStr(1, Edition_, "Unknown", 1) <> 0 Then Edition_ = Edition_ & " (" & sEditionID & ")"
If IsEmbedded_ Then Edition_ = Edition_ & " (Embedded)"
Exit Sub
ErrorHandler:
ErrorMsg Err, "clsOSver.Class_Initialize"
Resume Next
End Sub
Private Sub GetCodePageInfo()
On Error GoTo ErrorHandler
CodepageOEM_ = RegRead_REG_SZ("SYSTEM\CurrentControlSet\Control\Nls\CodePage", "OEMCP")
If 0 <> Len(CodepageOEM_) Then
CodepageOEM_File_ = RegRead_REG_SZ("SYSTEM\CurrentControlSet\Control\Nls\CodePage", CodepageOEM_)
End If
CodepageANSI_ = RegRead_REG_SZ("SYSTEM\CurrentControlSet\Control\Nls\CodePage", "ACP")
If 0 <> Len(CodepageANSI_) Then
CodepageANSI_File_ = RegRead_REG_SZ("SYSTEM\CurrentControlSet\Control\Nls\CodePage", CodepageANSI_)
End If
Exit Sub
ErrorHandler:
ErrorMsg Err, "clsOSver.GetCodePageInfo"
End Sub
Private Function GetLangNameFullByCultureCode(lcid As Long) As String
Dim buf As String
Dim lr As Long
buf = String$(1000, vbNullChar)
lr = GetLocaleInfo(lcid, LOCALE_SENGLANGUAGE, StrPtr(buf), ByVal 1000&)
If lr Then
GetLangNameFullByCultureCode = Left$(buf, lr - 1)
End If
End Function
Private Function RegRead_REG_SZ(strKey As String, strParam As String) As String
On Error GoTo ErrorHandler
Const KEY_QUERY_VALUE As Long = &H1&
Dim buf As String
Dim hKey As LongPtr
Dim ordType As Long
Dim cData As Long
RegOpenKeyEx HKEY_LOCAL_MACHINE, StrPtr(strKey), 0&, KEY_QUERY_VALUE Or (IsWin64_ And KEY_WOW64_64KEY), hKey
If hKey = 0 Then Exit Function
RegQueryValueExLong hKey, StrPtr(strParam), 0&, ordType, 0&, cData
If cData > 1 Then
buf = String$(cData - 1&, vbNullChar)
RegQueryValueExStr hKey, StrPtr(strParam), 0&, ordType, StrPtr(buf), cData
End If
buf = Left$(buf, lstrlenW(StrPtr(buf)))
RegRead_REG_SZ = buf
If hKey <> 0 Then RegCloseKey hKey
Exit Function
ErrorHandler:
ErrorMsg Err, "clsOSver.RegRead_REG_SZ"
If hKey <> 0 Then RegCloseKey hKey
End Function
Private Function RegRead_REG_DWORD(strKey As String, strParam As String) As Long
On Error GoTo ErrorHandler
Const KEY_QUERY_VALUE As Long = &H1&
Dim lData As Long
Dim hKey As LongPtr
Dim ordType As Long
Dim cData As Long
RegOpenKeyEx HKEY_LOCAL_MACHINE, StrPtr(strKey), 0&, KEY_QUERY_VALUE Or (IsWin64_ And KEY_WOW64_64KEY), hKey
If hKey = 0 Then Exit Function
RegQueryValueExLong hKey, StrPtr(strParam), 0&, ordType, 0&, cData
If cData = 4 Then
If ERROR_SUCCESS = RegQueryValueEx(hKey, StrPtr(strParam), 0&, ordType, VarPtr(lData), cData) Then
RegRead_REG_DWORD = lData
End If
End If
If hKey <> 0 Then RegCloseKey hKey
Exit Function
ErrorHandler:
ErrorMsg Err, "clsOSver.RegRead_REG_SZ"
If hKey <> 0 Then RegCloseKey hKey
End Function
Private Function IsProcessElevated(Optional hProcess As LongPtr) As Boolean
On Error GoTo ErrorHandler
Dim hToken As LongPtr
Dim dwLengthNeeded As Long
Dim dwIsElevated As Long
' < Win Vista. Óñòàíàâëèâàåì true, åñëè ïîëüçîâàòåëü ñîñòîèò â ãðóïïå "Àäìèíèñòðàòîðû"
If osi.dwMajorVersion < 6 Then IsProcessElevated = (GetUserType() = "Administrators"): Exit Function
If hProcess = 0 Then hProcess = GetCurrentProcess()
If OpenProcessToken(hProcess, TOKEN_QUERY, hToken) Then
If 0 <> GetTokenInformation(hToken, TokenElevation, dwIsElevated, 4&, dwLengthNeeded) Then
IsProcessElevated = (dwIsElevated <> 0)
End If
CloseHandle hToken: hToken = 0
End If
Exit Function
ErrorHandler:
ErrorMsg Err, "clsOSver.IsProcessElevated"
If hToken Then CloseHandle hToken: hToken = 0
End Function
Private Function GetUserType() As String
On Error GoTo ErrorHandler
Const TOKEN_QUERY As Long = &H8&
Const SECURITY_NT_AUTHORITY As Long = 5&
Const TokenGroups As Long = 2&
Const SECURITY_BUILTIN_DOMAIN_RID As Long = &H20&
Const DOMAIN_ALIAS_RID_ADMINS As Long = &H220&
Const DOMAIN_ALIAS_RID_USERS As Long = &H221&
Const DOMAIN_ALIAS_RID_GUESTS As Long = &H222&
Const DOMAIN_ALIAS_RID_POWER_USERS As Long = &H223&