- Code : Tout sélectionner
' Registry Reserved Key Handles
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_BINARY = 3 ' Free form binary
Public Const REG_DWORD = 4 ' 32-bit number
Public Const ERROR_SUCCESS = 0&
Const PROCESSOR_INTEL_386 = 386
Const PROCESSOR_INTEL_486 = 486
Const PROCESSOR_INTEL_PENTIUM = 586
Const PROCESSOR_MIPS_R4000 = 4000
Const PROCESSOR_ALPHA_21064 = 21064
Const PROCESSOR_PPC_601 = 601
Const PROCESSOR_PPC_603 = 603
Const PROCESSOR_PPC_604 = 604
Const PROCESSOR_PPC_620 = 620
Const PROCESSOR_HITACHI_SH3 = 10003 'Windows CE
Const PROCESSOR_HITACHI_SH3E = 10004 'Windows CE
Const PROCESSOR_HITACHI_SH4 = 10005 'Windows CE
Const PROCESSOR_MOTOROLA_821 = 821 'Windows CE
Const PROCESSOR_SHx_SH3 = 103 'Windows CE
Const PROCESSOR_SHx_SH4 = 104 'Windows CE
Const PROCESSOR_STRONGARM = 2577 'Windows CE - 0xA11
Const PROCESSOR_ARM720 = 1824 'Windows CE - 0x720
Const PROCESSOR_ARM820 = 2080 'Windows CE - 0x820
Const PROCESSOR_ARM920 = 2336 'Windows CE - 0x920
Const PROCESSOR_ARM_7TDMI = 70001 'Windows CE
Const PROCESSOR_ARCHITECTURE_INTEL = 0
Const PROCESSOR_ARCHITECTURE_MIPS = 1
Const PROCESSOR_ARCHITECTURE_ALPHA = 2
Const PROCESSOR_ARCHITECTURE_PPC = 3
Const PROCESSOR_ARCHITECTURE_SHX = 4
Const PROCESSOR_ARCHITECTURE_ARM = 5
Const PROCESSOR_ARCHITECTURE_IA64 = 6
Const PROCESSOR_ARCHITECTURE_ALPHA64 = 7
Const PROCESSOR_ARCHITECTURE_UNKNOWN = &HFFFF&
Const PROCESSOR_LEVEL_80386 = 3
Const PROCESSOR_LEVEL_80486 = 4
Const PROCESSOR_LEVEL_PENTIUM = 5
Const PROCESSOR_LEVEL_PENTIUMII = 6
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const MAX_WSADescription = 256
Const MAX_WSASYSStatus = 128
Const WS_VERSION_REQD = &H101
Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Const MIN_SOCKETS_REQD = 1
Const SOCKET_ERROR = -1
Const IBM_83 = 1' IBM PC/AT oder kompatible mit 83 Tasten
Const OLIVETTI_102 = 2 ' Olivetti 'ICO' Tastatur mit 102 Tasten
Const IBM_84 = 3' IBM AT oder ähnliche Tastatur mit 84 Tasten
Const IBM_102 = 4' IBM Erweiterte Tastatur 101 oder 102 Tasten
Const NOKIA_1050 = 5' Nokia 1050 oder ähnliche Tastatur
Const NOKIA_9140 = 6' Nokia 9140 oder ähnliche Tastatur
Const JAPAN = 7' Japanische Tastatur
Const BITSPIXEL = 12
Const PLANES = 14
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Const LANG_USER_DEFAULT = &H400&
Const FS_CASE_IS_PRESERVED = &H2
Const FS_CASE_SENSITIVE = &H1
Const FS_UNICODE_STORED_ON_DISK = &H4
Const FS_PERSISTENT_ACLS = &H8
Const FS_FILE_COMPRESSION = &H10
Const FS_VOLUME_IS_COMPRESSED = &H8000
Const FILE_NAMED_STREAMS = &H40000
Const FILE_SUPPORTS_ENCRYPTION = &H20000
Const FILE_SUPPORTS_OBJECT_IDS = &H10000
Const FILE_SUPPORTS_REPARSE_POINTS = &H80
Const FILE_SUPPORTS_SPARSE_FILES = &H40
Const FILE_VOLUME_QUOTAS = &H20
Const INVALID_DRIVE_LETTER = "Invalid drive letter"
Const WIN2000_ONLY = "This function is only available in Windows 2000"
Const sCPURegKey = "HARDWARE\DESCRIPTION\System\CentralProcessor\0"
Const DISK = "HARDWARE\DEVICEMAP\SCSI\SCSI Port 0\SCSI Bus 0\Target ID 0\LOGICAL Unit ID 0"
Const INTERNET_CONNECTION_MODEM = &H1
Const INTERNET_CONNECTION_LAN = &H2
Const INTERNET_CONNECTION_PROXY = &H4
Const INTERNET_CONNECTION_MODEM_BUSY = &H8
Const INTERNET_RAS_INSTALLED = &H10
Const INTERNET_CONNECTION_OFFLINE = &H20
Const INTERNET_CONNECTION_CONFIGURED = &H40
Const NoForce = 0
Const Force = 1
Const ForceIfHung_Win2K = 2
Const ShutDown = 1
Const Reboot = 2
Const LogOff = 4
Const PowerOff = 8
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Const EWX_FORCEIFHUNG = 16
Const VER_PLATFORM_WIN32_NT = 2
Const PROCESS_TERMINATE = &H1
Type RECT
x1 As Long
y1 As Long
x2 As Long
y2 As Long
End Type
Type SYSTEM_INFO
dwOemID As Long
dwPageSize As Long
lpMinimumApplicationAddress As Long
lpMaximumApplicationAddress As Long
dwActiveProcessorMask As Long
dwNumberOfProcessors As Long
dwProcessorType As Long
dwAllocationGranularity As Long
wProcessorLevel As Integer
wProcessorRevision As Integer
End Type
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Long
szSystemStatus(0 To MAX_WSASYSStatus) As Long
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Type DCB
DCBlength As Long
BaudRate As Long
fBitFields As Long
wReserved As Integer
XonLim As Integer
XoffLim As Integer
VariantSize As Variant
Parity As Variant
StopBits As Variant
XonChar As Variant
XoffChar As Variant
ErrorChar As Variant
EofChar As Variant
EvtChar As Variant
wReserved1 As Integer
End Type
Type COMMCONFIG
dwSize As Long
wVersion As Integer
wReserved As Integer
dcbx As DCB
dwProviderSubType As Long
dwProviderOffset As Long
dwProviderSize As Long
wcProviderData As Variant
End Type
Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Type LUID
UsedPart As Long
IgnoredForNowHigh32BitPart As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
'// added 09.04.2004 to determine the Internet Explorer Version
Type DllVersionInfo
cbSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformID As Long
End Type
Declare Function DllGetVersion Lib "Shlwapi.dll" (dwVersion As DllVersionInfo) As Long
Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (pBlock As Any, Byval lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
'// end
'//added 08.04 for function GetCurrentUser
Declare Function GetLastError Lib "kernel32" () As Long
'//end
Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" (Byval nBufferLength As Long, Byval lpBuffer As String) As Long
Declare Function AdjustTokenPrivileges Lib "advapi32" _
(Byval TokenHandle As Long, Byval DisableAllPrivileges _
As Long, NewState As TOKEN_PRIVILEGES, Byval _
BufferLength As Long, PreviousState As _
TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Declare Function OpenProcess Lib "kernel32" (Byval _
dwDesiredAccess As Long, Byval bInheritHandle As Long, _
Byval dwProcessId As Long) As Long
Declare Function GetDriveType _
Lib "kernel32" Alias "GetDriveTypeA" ( _
Byval nDrive As String) _
As Long
Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
(Byval dwFlags As Long, lpSource As Any, _
Byval dwMessageId As Long, Byval dwLanguageId As Long, _
Byval lpBuffer As String, Byval nSize As Long, _
Arguments As Long) As Long
Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
"GetVolumeInformationA" (Byval lpRootPathName As String, Byval lpVolumeNameBuffer _
As String, Byval nVolumeNameSize As Long, lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, lpFileSystemFlags As Long, Byval _
lpFileSystemNameBuffer As String, Byval nFileSystemNameSize As Long) As Long
Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (Byval lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Declare Function GetWindowThreadProcessId Lib "user32" (Byval hwnd As Long, lpdwProcessId As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (Byval lpClassName As String, Byval lpWindowName As String) As Long
Declare Function TerminateProcess Lib "kernel32" (Byval hProcess As Long, Byval uExitCode As Long) As Long
Declare Function CloseHandle Lib "kernel32" (Byval hObject As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (Byval dwOptions As Long, Byval dwReserved As Long) As Long
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Declare Function OpenProcessToken Lib "advapi32" ( Byval ProcessHandle As Long, Byval DesiredAccess As Long, TokenHandle As Long) As Long
Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (Byval lpSystemName As String, Byval lpName As String, lpLuid As LUID) As Long
Declare Function InternetGetConnectedState Lib "wininet.dll" (lpSFlags As Long, Byval dwReserved As Long) As Long
Declare Function LockWorkStation Lib "user32.dll" () As Long 'Win2000 only
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Declare Function GetDefaultCommConfig Lib "kernel32" Alias "GetDefaultCommConfigA" (Byval lpszName As String, lpCC As COMMCONFIG, lpdwSize As Long) As Long
Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Declare Function WSAStartup Lib "WSOCK32.DLL" (Byval wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (Byval lpbuffer As String, nSize As Long) As Long
Declare Function gethostname Lib "WSOCK32.DLL" (Byval szHost As String, Byval dwHostLen As Long) As Long
Declare Function gethostbyname Lib "WSOCK32.DLL" (Byval szHost As String) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, Byval hpvSource As Long, Byval cbCopy As Long)
Declare Function GetWindowRect Lib "user32" (Byval hwnd As Long, lpRect As RECT) As Long
Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetDC Lib "user32" (Byval hwnd As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (Byval hdc As Long, Byval nIndex As Long) As Long
Declare Function ReleaseDC Lib "user32" (Byval hwnd As Long, Byval hdc As Long) As Long
Declare Function OSGetExecutableDirectory Lib "NNOTES.DLL" Alias "OSGetExecutableDirectory" (Byval DirName As String,Byval Size As Long) As Long
Declare Function GetSystemDirectory Lib "Kernel32" Alias "GetSystemDirectoryA" (Byval lpBuffer As String, Byval nSize As Long) As Long
Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
Declare Function RegCloseKey Lib "advapi32" (Byval hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32" Alias "RegOpenKeyA" (Byval hKey As Long, Byval lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA"(Byval hKey As Long, _
Byval lpValueName As String, Byval lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
'Declare Function waveOutGetNumDevs Lib "MMSYSTEM" () As Integer ' 16BIT Version
Declare Function waveOutGetNumDevs Lib "winmm.dll" Alias "waveOutGetNumDevs" () As Long
Declare Function GetKeyboardType Lib "user32" Alias "GetKeyboardType" (Byval nTypeFlag As Long) As Long
Declare Function GetDoubleClickTime Lib "user32" () As Long
Declare Function SetDoubleClickTime Lib "user32" Alias "SetDoubleClickTime" (Byval wCount As Long) As Long
Dim hKey As Long
Dim Speed As Long
Dim SI As SYSTEM_INFO
Dim tmp As String
Dim volname As String ' receives volume name
Dim sn As Long ' receives serial number
Dim snstr As String ' display form of serial number
Dim maxcomplen As Long ' receives maximum component length
Dim sysflags As Long ' receives file system flags
Dim sysname As String ' receives the file system name
Dim retval As Long ' return value
Class SysInfo
'System Stuff
Declare Public Function GetProcessorType() As String
Declare Public Function GetProcessorLevel () As String
Declare Public Function GetProcessorRevision () As String
Declare Public Function GetCPUSpeed () As String
Declare Public Function GetNumberOfProcessors () As Integer
Declare Public Function GetWindowsVersion() As String
Declare Public Function GetWindowsSysDir() As String
Declare Public Function SmallFonts() As String
Declare Public Function GetScreenResolution As String
Declare Public Function GetIPAddress As String
Declare Public Function GetLocalHostName() As String
Declare Public Function IsSoundAvailable As String
Declare Public Function GetKeybType As String
Declare Public Function GetNumOfFunctionKeys As Integer
Declare Public Function GetNumOfColors As String
Declare Public Function IsCOMPortAvailable(port As Integer) As Long
Declare Public Function GetTotalRAM As String
Declare Public Function GetTotalVirtualRAM As String
Declare Public Function GetDriveVolumeName ( strDrive As String ) As String
Declare Public Function GetDriveFIleSystem ( strDrive As String ) As String
Declare Public Function GetDriveSerialNumber ( strDrive As String ) As String
Declare Public Sub LockWS
Declare Public Sub ExitWindowsSession( Action As Integer)
Declare Public Function GetNotesProgramDirectory As String
Declare Public Function GetNetConnectionState() As String
Declare Public Function GetCard() As String
Declare Public Function HDSIZE(drvStr As String) As String
Declare Public Function HDNAME() As String
'Private functions and subs
Declare Private Function HiByte(Byval wParam As Integer) As Variant
Declare Private Function LoByte(Byval wParam As Integer) As Variant
Declare Private Function GetAPIErrorStr(ErrCode As Long) As String
Declare Private Function AddBackSlash (strDrive As String ) As String
Declare Private Function GetRegValue(hKey As Long, strPath As String, strValue As String) As String
Declare Private Sub TerminateExplorer()
Declare Private Sub SetShutdownPrivilege()
'//added 08.04.2004, determine IE Version
Declare Private Function GetIEVersion(DVI As DllVersionInfo) As Long
Declare Private Function GetIEVersionString() As String
Declare Public Function GetIEVersionFriendlyName() As String
Declare Public Function GetCurrentUser() As String
Declare Public Function GetDrives() As String
Declare Public Function CDROM() As String
Public Function CDROM () As String
Dim DriveNum As String
Dim DriveType As Long
DriveNum = 64
Do
DriveNum = DriveNum + 1
DriveType = GetDriveType(Chr$(DriveNum) & ":\")
If DriveType = 1 And DriveNum > 67 Then Exit Do
If DriveType = 5 Then
CDROM = "CD ROM found, Drive " & Chr$(DriveNum) & ":\"
Exit Function
Else
CDROM ="no CD ROM"
End If
Loop
End Function
Public Function GetDrives() As String
Dim tmp As String
Dim iCount As Integer
Dim strDrives As String
strDrives = Space$(64)
Call GetLogicalDriveStrings(Len(strDrives), strDrives)
For iCount = 1 To Len(strDrives) Step 4
tmp = tmp & " " + Mid$(strDrives, iCount, 1)
Next iCount
GetDrives = Trim(tmp)
End Function
Private Function GetIEVersion(DVI As DllVersionInfo) As Long
DVI.cbSize = Len(DVI)
Call DllGetVersion(DVI)
GetIEVersion = DVI.dwMajorVersion
End Function
Private Function GetIEVersionString() As String
Dim DVI As DllVersionInfo
DVI.cbSize = Len(DVI)
Call DllGetVersion(DVI)
GetIEVersionString = "Internet Explorer " & _
DVI.dwMajorVersion & "." & _
DVI.dwMinorVersion & "." & _
DVI.dwBuildNumber
End Function
Public Function GetIEVersionFriendlyName() As String
Dim s As String
Dim DVI As DllVersionInfo
Call GetIEVersion(DVI)
Select Case DVI.dwMajorVersion
Case 4
Select Case DVI.dwMinorVersion
Case 70
Select Case DVI.dwBuildNumber
Case 1155: s = "3.0"
Case 1158: s = "3.0 (OSR2)"
Case 1215: s = "3.01"
Case 1300: s = "3.02 and 3.02a"
Case Else: s = "3 (Unknown)"
End Select
Case 71
Select Case DVI.dwBuildNumber
Case 1008: s = "4.0 PP2"
Case 1712: s = "4.0"
Case Else: s = "4.0 (Unknown)"
End Select
Case 72
Select Case DVI.dwBuildNumber
Case 2106: s = "4.01"
Case 3110: s = "4.01 Service Pack 1"
Case 3612: s = "4.01 SP2"
Case 3711: s = "4.x with Update"
Case Else: s = "4.0 (Unknown)"
End Select
Case Else: s = "(Unknown)"
End Select
Case 5
Select Case DVI.dwMinorVersion
Case 0
Select Case DVI.dwBuildNumber
Case 518: s = "5 Developer Preview (Beta 1)"
Case 910: s = "5 Beta (Beta 2)"
Case 2014: s = "5"
Case 2314: s = "5 (Office 2000)"
Case 2516: s = "5.01 (Windows 2000 Beta 3)"
Case 2614: s = "5 (Windows 98 Second Edition)"
Case 2717, 2721, 2723: s = "5 with update"
Case 2919: s = "5.01 (Windows 2000 RC1&2/Office 2000 SR-1/Update)"
Case 2920: s = "5.01 (Windows 2000)"
Case 3103: s = "5.01 SP1 (Windows 2000)"
Case 3105: s = "5.01 SP1 (Windows 95/98, NT 4.0)"
Case 3314: s = "5.01 SP2 (Windows 95/98 ,NT 4.0)"
Case 3315: s = "5.01 SP2 (Windows 2000)"
Case Else: s = "5 (Unknown)"
End Select
Case 50
Select Case DVI.dwBuildNumber
Case 3825: s = "5.5 Developer Preview (Beta)"
Case 4030: s = "5.5 & Internet Tools Beta"
Case 4134: s = "5.5"
Case 4308: s = "5.5 Advanced Security Privacy Beta"
Case 4522: s = "5.5 Service Pack 1"
Case 4807: s = "5.5 Service Pack 2"
Case Else: s = "5.5 (Unknown)"
End Select
Case Else: s = GetIEVersionString()
End Select
Case 6
Select Case DVI.dwMinorVersion
Case 0
Select Case DVI.dwBuildNumber
Case 2462: s = "6 Public Preview (Beta)"
Case 2479: s = "6 Public Preview (Beta) Refresh"
Case 2600: s = "6"
Case 2800: s = "6 SP1 (Windows XP SP1)"
Case 3663 : s = "6 for Server 2003 RC1"
Case 3718 : s = "6 for 2003 RC2"
Case 3790 : s = "6 for2003 (released)"
Case Else: s = "6 (Unknown)"
End Select
Case Else: s = GetIEVersionString()
End Select
Case Else: s = GetIEVersionString()
End Select
GetIEVersionFriendlyName = "Internet Explorer " & s
End Function
Public Function GetCurrentUser As String
Dim RetUserName As Long
Dim lpUserName As String
Dim nSize As Long
Dim RetLastError As Long
Dim RetVal As Long
Dim lpMessageBuffer As String
Dim varia As String
lpUserName = Space(255)
nSize = Len(lpUserName)
RetUserName = GetUserName(lpUserName, nSize)
If RetUserName <> 0 Then 'UserName ausgeben.
varia = Left(lpUserName, nSize - 1)
Else 'Username nicht verfügbar.
RetLastError = GetLastError()
lpMessageBuffer = Space(255)
nSize = Len(lpMessageBuffer)
RetVal = FormatMessage(0, 0, RetLastError, 0, lpMessageBuffer, nSize, 0)
If RetVal <> 0 Then
varia = "Error " & RetLastError & ": " & lpMessageBuffer
Else
varia = "Error " & RetLastError & ": kein angemeldeter Benutzer"
End If
End If
GetCurrentUser= varia
End Function
'// end 08.04.2004
Public Function HDSIZE(drvStr As String) As String
Dim ApiRes As Long
Dim SectorsPerCluster As Long
Dim BytesPerSector As Long
Dim NumberOfFreeClusters As Long
Dim TotalNumberOfClusters As Long
Dim FreeBytes As Long
ApiRes = GetDiskFreeSpace(drvStr, SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)
FreeBytes = (NumberOfFreeClusters * SectorsPerCluster * BytesPerSector)/1024
HDSize = Cstr( Round (((TotalNumberOfClusters)/1024 * (SectorsPerCluster)/1024 * (BytesPerSector)/1024),2))
'HDSIZE= Cstr(FreeBytes) + " KBytes."
End Function
Public Function GetCard() As String
Dim iRet As String
iRet = getRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards\1","Title")
If iRet = "" Then
iRet = getRegValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\NetworkCards\1","Title")
End If
GetCard=iRet
End Function
Public Function HDNAME() As String
Dim iRet As String
iRet = getRegValue(HKEY_LOCAL_MACHINE, DISK,"Identifier")
If iRet = "" Then
iRet = getRegValue(HKEY_LOCAL_MACHINE, DISK,"Identifier")
End If
HDNAME=iRet
End Function
Public Sub LockWS
If Ucase(GetWindowsVersion) = "WINDOWS 2000" Then
retval = LockWorkStation
Else
Msgbox WIN2000_ONLY
End If
End Sub
Public Function GetDriveSerialNumber ( strDrive As String ) As String
volname = Space(256)
sysname = Space(256)
retval = GetVolumeInformation( AddBackSlash(strDrive), volname, Len(volname), sn, maxcomplen, sysflags, sysname, Len(sysname))
snstr = Trim(Hex(sn))
snstr = String(8 - Len(snstr), "0") & snstr
snstr = Left(snstr, 4) & "-" & Right(snstr, 4)
If retval = 0 Then
GetDriveSerialNumber = INVALID_DRIVE_LETTER
Else
GetDriveSerialNumber = Trim(snstr)
End If
End Function
Public Function GetDriveFileSystem ( strDrive As String ) As String
volname = Space(256)
sysname = Space(256)
retval = GetVolumeInformation( AddBackSlash(strDrive), volname, Len(volname), sn, maxcomplen, sysflags, sysname, Len(sysname))
If retval = 0 Then
GetDriveFileSystem = INVALID_DRIVE_LETTER
Else
GetDriveFileSystem = Trim(sysname)
End If
End Function
Public Function GetDriveVolumeName ( strDrive As String ) As String
volname = Space(256)
sysname = Space(256)
retval = GetVolumeInformation( AddBackSlash(strDrive), volname, Len(volname), sn, maxcomplen, sysflags, sysname, Len(sysname))
If retval = 0 Then
GetDriveVolumeName = INVALID_DRIVE_LETTER
Else
GetDriveVolumeName = Trim(volname)
End If
End Function
Public Function GetTotalRAM As String
Dim memsts As MEMORYSTATUS
Dim memory As Long
GlobalMemoryStatus memsts
memory = memsts.dwTotalPhys
GetTotalRAM = Cstr((Memory / 1024)) + " KB"
End Function
Public Function GetTotalVirtualRAM As String
Dim memsts As MEMORYSTATUS
Dim memory As Long
GlobalMemoryStatus memsts
memory = memsts.dwTotalVirtual
GetTotalVirtualRAM = Cstr((Memory / 1024)) + " KB"
End Function
Public Function GetProcessorType() As String
tmp = ""
Call GetSystemInfo(SI)
Select Case SI.dwProcessorType
Case PROCESSOR_INTEL_386: tmp = "386"
Case PROCESSOR_INTEL_486: tmp = "486"
Case PROCESSOR_INTEL_PENTIUM: tmp = "Pentium"
Case PROCESSOR_MIPS_R4000: tmp = "MIPS 4000"
Case PROCESSOR_ALPHA_21064: tmp = "Alpha"
End Select
GetProcessorType = Cstr ( SI.dwProcessorType ) + " - " + tmp
End Function
Public Function GetNumberOfProcessors () As Integer
Call GetSystemInfo (SI)
GetNumberOfProcessors = SI.dwNumberOfProcessors
End Function
Public Function GetProcessorLevel () As String
tmp= ""
Call GetSystemInfo(SI)
Select Case SI.wProcessorLevel
Case PROCESSOR_LEVEL_80386: tmp = "Intel 80386"
Case PROCESSOR_LEVEL_80486: tmp = "Intel 80486"
Case PROCESSOR_LEVEL_PENTIUM: tmp = "Intel Pentium"
Case PROCESSOR_LEVEL_PENTIUMII: tmp = "Intel Pentium Pro, II, III or 4"
End Select
GetProcessorLevel = Cstr ( SI.wProcessorLevel ) + ", " + tmp
End Function
Public Function GetProcessorRevision () As String
Call GetSystemInfo(SI)
GetProcessorRevision = Cstr ( SI.wProcessorRevision ) +_
", Model " + Cstr ( HiByte(SI.wProcessorRevision) ) +_
", Stepping " + Cstr ( LoByte(SI.wProcessorRevision) )
End Function
Public Function GetCPUSpeed () As String
Call RegOpenKey(HKEY_LOCAL_MACHINE, sCPURegKey, hKey)
Call RegQueryValueEx(hKey, "~MHz", 0, 0, Speed, 4)
Call RegCloseKey(hKey)
GetCPUSpeed = Cstr ( Speed ) + " MHz"
End Function
Public Function GetWindowsVersion() As String
tmp = ""
Dim OS As OSVERSIONINFO
Dim ret As Integer
OS.dwOSVersionInfoSize = 148
OS.szCSDVersion = Space$(128)
ret = GetVersionExA( OS )
Select Case OS.dwPlatformId
Case 1
Select Case OS.dwMajorVersion
Case 0: tmp = "Windows 95"
Case 10: tmp = "Windows 98"
End Select
Case 2
Select Case OS.dwMajorVersion
Case 3
Select Case OS.dwMinorVersion
Case 0: tmp = "Windows NT3"
Case 1: tmp = "Windows NT3.1"
Case 5: tmp = "Windows NT3.5"
Case 51: tmp = "Windows NT3.51"
End Select
Case 4: tmp = "Windows NT 4.0"
Case 5
Select Case OS.dwMinorVersion
Case 0: tmp = "Windows 2000"
Case 1: tmp = "Windows XP"
End Select
End Select
Case Else
tmp = "unknown"
End Select
GetWindowsVersion = tmp
End Function
Public Function GetWindowsSysDir() As String
Dim Gwdvar As String, Gwdvar_Length As Integer
Gwdvar = Space(255)
Gwdvar_Length = GetSystemDirectory(Gwdvar, 255)
GetWindowsSysDir = Left(Gwdvar, Gwdvar_Length)
End Function
Public Function GetScreenResolution As String
Dim R As Rect
Dim hWnd As Long
Dim RetVal As Long
hWnd = GetDesktopWindow ()
RetVal = GetWindowRect(hWnd, R)
GetScreenResolution = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
End Function
Public Function GetIPAddress As String
Dim HostName As String * 256
Dim HostPointer As Long
Dim HostStruct As HOSTENT
Dim HostAddressPointer As Long
Dim HostAddress As Long
Dim AddressNum As String
Dim Address As String
gethostname HostName, 256
HostName = Trim(HostName)
HostPointer = gethostbyname(HostName)
CopyMemory HostStruct, HostPointer, Len(HostStruct)
CopyMemory HostAddressPointer, HostStruct.hAddrList, 4
CopyMemory HostAddress, HostAddressPointer, 4
AddressNum = Trim(Hex(HostAddress))
AddressNum = String(8-Len(AddressNum), Asc("0")) & AddressNum
Address = Cstr(Cint("&H" & Mid(AddressNum, 7))) & "." & Cstr(Cint("&H" & Mid(AddressNum, 5, 2))) & "." & Cstr(Cint("&H" & Mid(AddressNum, 3, 2))) & "." & Cstr(Cint("&H" & Left(AddressNum, 2)))
GetIPAddress = Address
End Function
Public Function GetLocalHostName() As String
Dim sName$
sName = String(256, 0)
If gethostname(sName, 256) Then
sName = WSA_NoName
Else
If Instr(sName, Chr(0)) Then
sName = Left(sName, Instr(sName, Chr(0)) - 1)
End If
End If
GetLocalHostName = Ucase(sName)
End Function
Public Function IsSoundAvailable As String
tmp = ""
If waveOutGetNumDevs() = 0 Then
tmp = "SOUND = NO"
Else
tmp = "SOUND = YES"
End If
IsSoundAvailable = tmp
End Function
Public Function GetKeybType As String
tmp = ""
i% = Cint ( GetKeyboardType(0) )
Select Case i%
Case IBM_83 : tmp= "IBM PC/AT oder kompatible mit 83 Tasten"
Case OLIVETTI_102 : tmp= "Olivetti 'ICO' Tastatur mit 102 Tasten"
Case IBM_84 : tmp = " IBM AT oder ähnliche Tastatur mit 84 Tasten"
Case IBM_102 :tmp = "IBM Erweiterte Tastatur 101 oder 102 Tasten"
Case NOKIA_1050 : tmp = "Nokia 1050 oder ähnliche Tastatur"
Case NOKIA_9140 :tmp = "Nokia 9140 oder ähnliche Tastatur"
Case JAPAN : tmp = "Japanische Tastatur"
End Select
GetKeybType = tmp
End Function
Public Function GetNumOfFunctionKeys As Integer
GetNumOfFunctionKeys = GetKeyboardType(2)
End Function
Public Function GetNotesProgramDirectory As String
Dim DirPath As String*512
Dim Size As Long
Dim Handle As Long
GetNotesProgramDirectory=""
Handle=OSGetExecutableDirectory(DirPath,Size)
GetNotesProgramDirectory=DirPath
End Function
Public Function SmallFonts () As String
Dim hWndDesk As Long
Dim hDCDesk As Long
Dim logPix As Long
SmallFonts = "SMALL FONTS = NO"
hWndDesk = GetDesktopWindow()
hDCDesk = GetDC(hWndDesk)
logPix = GetDeviceCaps(hDCDesk, LOGPIXELSX)
Call ReleaseDC(hWndDesk, hDCDesk)
If logPix = 96 Then
SmallFonts = "SMALL FONTS = YES"
End If
End Function
Public Function GetNumOfColors As String
tmp = ""
Dim ColorPixel%, hDC&, Result&
hDC = GetDC(0)
ColorPixel = GetDeviceCaps(hDC, BITSPIXEL) * GetDeviceCaps(hDC, PLANES)
Result = ReleaseDC(0, hDC)
Select Case ColorPixel
Case 1: tmp = "Monochrom"
Case 4: tmp = "Indexfarben"
Case 8: tmp = "256 Colour"
Case 16: tmp = "High Colour"
Case 32: tmp = "True Colour"
End Select
tmp = tmp & " [" & ColorPixel & " Bit]" & " = " & 2 ^ ColorPixel & " Colours"
GetNumOfColors = tmp
End Function
Public Function IsCOMPortAvailable(port As Integer) As Long
Dim cc As COMMCONFIG, ccsize As Long
ccsize = Len(cc)
IsCOMPortAvailable = GetDefaultCommConfig("COM" + Trim(Str(port)) + Chr(0), cc, ccsize)
End Function
Private Function HiByte(Byval wParam As Integer) As Variant
HiByte = (wParam And &HFF00&) \ (&H100)
End Function
Private Function LoByte(Byval wParam As Integer) As Variant
LoByte = wParam And &HFF&
End Function
Private Function GetAPIErrorStr(ErrCode As Long) As String
Dim msgbuf As String, LenG As Long
msgbuf$ = Space$(257)
LenG& = FormatMessage( _
FORMAT_MESSAGE_FROM_SYSTEM Or _
FORMAT_MESSAGE_IGNORE_INSERTS Or _
FORMAT_MESSAGE_MAX_WIDTH_MASK, _
Byval 0, ErrCode, LANG_USER_DEFAULT, _
Byval msgbuf, 256, 0)
If LenG Then
GetAPIErrorStr = Left$(msgbuf, LenG)
Else
GetAPIErrorStr = "Unknown Windows-Error: &H" & Hex$(ErrCode)
End If
End Function
Private Function AddBackSlash (strTmpDrive As String ) As String
strTmpDrive = Trim(strTmpDrive)
If Right$(strTmpDrive,1) = "\" Then
AddBackSlash = strTmpDrive
Else
AddBackSlash = strTmpDrive + "\"
End If
End Function
Private Sub SetShutdownPrivilege()
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Dim hProcessHandle As Long
Dim hTokenHandle As Long
Dim PrivLUID As LUID
Dim TokenPriv As TOKEN_PRIVILEGES
Dim tkpDummy As TOKEN_PRIVILEGES
Dim lDummy As Long
' Ermittlung eines Prozess-Handles dieser Anwendung
hProcessHandle = GetCurrentProcess()
' Für unseren Prozess soll ein Token geändert werden.
OpenProcessToken hProcessHandle, (TOKEN_ADJUST_PRIVILEGES Or _
TOKEN_QUERY), hTokenHandle
' Die repräsentierende LUID für das "SeShutdownPrivilege" ermitteln
LookupPrivilegeValue "", "SeShutdownPrivilege", PrivLUID
' Vorbereitungen auf das Ändern des Tokens Anzahl der Privilegien
TokenPriv.PrivilegeCount = 1
' LUID-Struktur für das Privileg
TokenPriv.TheLuid = PrivLUID
' Das Privileg soll gesetzt werden
TokenPriv.Attributes = SE_PRIVILEGE_ENABLED
' Jetzt wird das Token für diesen Prozess gesetzt, um
' unserem Prozess das Recht für ein Herunterfahren / einen
'Neustart zuzuteilen:
AdjustTokenPrivileges hTokenHandle, False, TokenPriv, _
Len(tkpDummy), tkpDummy, lDummy
' Handle auf das geoeffnete Token freigeben
CloseHandle hTokenHandle
End Sub
Private Sub TerminateExplorer()
' Beendet den Explorer-Prozess unter Win9x.
' (Für Windows NT / 2000 wäre zusätzlich das Privileg
' SE_DEBUG_NAME = "SeDebugPrivilege" zu setzen.)
Dim ProcessIDExplorer As Long
Dim hProcessExplorer As Long
Dim hExplorerWindow As Long
' Handle des Programm-Manager-Fensters ermitteln (gehört zu Explorer.exe)
hExplorerWindow = FindWindow("progman", "program manager")
' Die Prozess-ID des Explorers ermitteln
GetWindowThreadProcessId hExplorerWindow, ProcessIDExplorer
' Durch OpenProcess ein Pseudo-Handle für den Explorer-Prozess ermitteln:
hProcessExplorer = OpenProcess(PROCESS_TERMINATE, 0&, ProcessIDExplorer)
' Den Explorer-Prozess terminieren
If hProcessExplorer <> 0 Then
TerminateProcess hProcessExplorer, 1&
End If
' Das Pseudo-Handle auf den Explorer-Prozess freigeben
CloseHandle hProcessExplorer
End Sub
Public Sub ExitWindowsSession( Action As Integer )
Dim ShutdownFlags As Long
' Zuerst setzen wir das Shutdown-Privileg, falls es sich um WIndows NT oder WIndows 2000 handelt:
tmp = GetWindowsVersion
If tmp = "Windows NT 4.0" Or tmp = "Windows 2000"Then
SetShutdownPrivilege
End If
' Nun kann das System heruntergefahren werden (respektive
' anderer Möglichkeiten, die im Parameter Action angeboten
' werden)
Select Case Action
Case ShutDown
ShutdownFlags = EWX_SHUTDOWN
Case Reboot
ShutdownFlags = EWX_SHUTDOWN + EWX_REBOOT
Case LogOff
ShutdownFlags = EWX_LOGOFF
Case PowerOff
ShutdownFlags = EWX_SHUTDOWN + EWX_POWEROFF
End Select
ForceMode = ForceIfHung_Win2K
' Prüfen, ob ForceIfHung unter Win95/98/NT4 angegeben wurde (sinnlos)
If ForceMode = ForceIfHung_Win2K And tmp <> "Windows 2000" Then
ForceMode = Force
End If
' Falls nun der Force-Parameter für Win95/98/NT4 gesetzt ist, wird EWX_FORCE addiert
If ForceMode = Force Then
ShutdownFlags = ShutdownFlags + EWX_FORCE
End If
' Win2000: Falls der ForceIfHung-Parameter gesetzt ist, wird EWX_FORCEIFHUNG addiert
If ForceMode = ForceIfHung_Win2K Then
ShutdownFlags = ShutdownFlags + EWX_FORCEIFHUNG
End If
' Unter Windows 95/98 wird der Benutzer bei EWX_LOGOFF mit
' EWX_FORCE nicht komplett abgemeldet - sein Desktop bleibt
' bestehen. Um dies zu vermeiden, muß zuerst der Explorer-
' Prozess terminiert werden:
If tmp <> "Windows NT 4.0" _
And Action = LogOff _
And ForceMode = Force Then TerminateExplorer
' Schließlich: Befehl zum Beenden (etc.) von Windows ausführen
ExitWindowsEx ShutdownFlags, &HFFFF
End Sub
Public Function GetNetConnectionState() As String
Dim dwflags As Long
Dim msg As String
If InternetGetConnectedState(dwflags, 0&) Then
If dwflags And INTERNET_CONNECTION_CONFIGURED Then
msg = msg & "You have a network connection configured." & vbCrLf
End If
If dwflags And INTERNET_CONNECTION_LAN Then
msg = msg & "The local system connects to the Internet via a LAN"
End If
If dwflags And INTERNET_CONNECTION_PROXY Then
msg = msg & ", and uses a proxy server. "
Else
msg = msg & "."
End If
If dwflags And INTERNET_CONNECTION_MODEM Then
msg = msg & "The local system uses a modem to connect to the Internet. "
End If
If dwflags And INTERNET_CONNECTION_OFFLINE Then
msg = msg & "The connection is currently offline. "
End If
If dwflags And INTERNET_CONNECTION_MODEM_BUSY Then
msg = msg & "The local system's modem is busy with a non-Internet connection. "
End If
If dwflags And INTERNET_RAS_INSTALLED Then
msg = msg & "Remote Access Services are installed on this system."
End If
Else
msg = "Not connected to the internet now."
End If
GetNetConnectionState = msg
End Function
Private Function GetRegValue(hKey As Long, strPath As String, strValue As String) As String
Dim hCurKey As Long
Dim lResult As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
GetSettingString = ""
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, Byval 0&, lDataBufferSize)
If lRegResult = ERROR_SUCCESS Then
If lValueType = REG_SZ Then
strBuffer = String(lDataBufferSize, " ")
lResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, Byval strBuffer, lDataBufferSize)
intZeroPos = Instr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
GetRegValue = Left$(strBuffer, intZeroPos - 1)
Else
GetRegValue = strBuffer
End If
End If
Else
End If
lRegResult = RegCloseKey(hCurKey)
End Function
End Class
Source : le masque Quick Call de l'appli !!HELP!!
