Attribute VB_Name = "OSVersion"
' Module fournissant les différentes informations sur le PC
' =========================================================
' - Nom de l'ordinateur
' - Type de l'ordinateur
' - Version de Windows
' - Version du service Pack
' - Nom de l'utilisateur enregistré
' - Nom de la société enregistrée
' - N° de licence
' - Clé de la licence


Option Explicit

' Constante nécessaire pour GetVersionEx
Public Const VER_PLATEFORM_WIN32S = 0           '3.xx
Public Const VER_PLATEFORM_WIN32_WINDOWS = 1    ' 95 / 98
Public Const VER_PLATEFORM_WIN32_NT = 2         ' NT, 2000, XP

Public Const VER_NT_WORKSTATION = &H1
Public Const VER_NT_DOMAIN_CONTROLLER = &H2
Public Const VER_NT_SERVER = &H3

Public Const VER_SUITE_SMALLBUSINESS = &H1
Public Const VER_SUITE_ENTERPRISE = &H2
Public Const VER_SUITE_BACKOFFICE = &H4
Public Const VER_SUITE_COMMUNICATION = &H8
Public Const VER_SUITE_TERMINAL = &H10
Public Const VER_SUITE_SMALLBUSINESS_RESTRICTED = &H20
Public Const VER_SUITE_EMBEDDEDNT = &H40
Public Const VER_SUITE_DATACENTER = &H80
Public Const VER_SUITE_SINGLEUSERTS = &H100
Public Const VER_SUITE_PERSONNAL = &H200
' Fonctions API utilisées
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFOEX) As Long
' Structures systeme pour GetVersionEx
Public Type OSVERSIONINFOEX
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
    wServicePackMajor As Integer
    wServicePackMinor As Integer
    wSuiteMask As Integer
    wProductType As Byte
    wRest As Byte
End Type

' Api pour acces à la base de registre
'Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpsubkey As String, phkeyResult As Long) As Long
'Declare Function RegQueryValueEx Lib "advapi32.dll" 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 RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, _
    ByVal lpsubkey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
'Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
' Constante pour acces à la base de registre
'Public Const HKEY_CLASSES_ROOT = &H80000000
'Public Const HKEY_CURRENT_CONFIG = &H80000005
'Public Const HKEY_CURRENT_USER = &H80000001
'Public Const HKEY_LOCAL_MACHINE = &H80000002
'Public Const KEY_ALL_ACCESS As Long = &HF0063
'Public Const ERROR_SUCCESS As Long = 0
'Public Const REG_SZ As Long = 1         ' Valeur en type chaine
'Public Const REG_DWORD As Long = 4      ' Valeur en Dword

' Nom de l'ordinateur et de l'utilisateur
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Const PROCESSOR_ALPHA_21064 = 21064
Private Const PROCESSOR_INTEL_386 = 386
Private Const PROCESSOR_INTEL_486 = 486
Private Const PROCESSOR_INTEL_PENTIUM = 586
Private Const PROCESSOR_MIPS_R4000 = 4000

' Nombre de processeur
Public Type SystemInfo
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
    wProcessorLevel As Integer
    wProcessorRevision As Integer
    
End Type

'    Private 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
'    End Type

Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SystemInfo)

' Mémoire
Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MemoryStatus)
Type MemoryStatus 'Utilise une structure MEMORYSTATUS pour stocker le résultat.
    dwLength As Long 'dwLength est la taille de la structure.
    dwMemoryLoad As Long 'dwMemoryLoad est le pourcentage de mémoire actuellement utilisé.
    dwTotalPhys As Long 'dwTotalPhys est la taille totale de la mémoire physique (en octets).
    dwAvailPhys As Long 'dwAvailPhys est la taille de la mémoire physique disponible (en octets).
    dwTotalPageFile As Long 'dwTotalPageFile donne la taille totale que peut atteindre le fichier d'échange (en octets).
    dwAvailPageFile As Long 'dwAvailPageFile indique l'espace disponible dans le fichier d'échange (en octets).
    dwTotalVirtual As Long 'dwTotalVirtual retourne la mémoire totale pouvant être utilisée par l'application courante (en octets).
    dwAvailVirtual As Long 'dwAvailVirtual représente l'espace libre totale (en octets).
End Type

' Langue
'Private Const LOCALE_SNATIVELANGNAME = &H4
'Private Const LOCALE_SNATIVECTRYNAME = &H8

Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Public Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer
Public Declare Function VerLanguageName Lib "kernel32" Alias "VerLanguageNameA" (ByVal wLang As Long, ByVal szLang As String, ByVal nSize As Long) As Long
Public Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Public Const LOCALE_SCOUNTRY = &H6          '  localized name of country
Public Const LOCALE_SNATIVELANGNAME = &H4   '  native name of language
Private Const LOCALE_SNATIVECTRYNAME = &H8
Public Const LOCALE_SENGCOUNTRY = &H1002    '  English name of country
Public Const LOCALE_SENGLANGUAGE = &H1001   '  English name of language


Private Const HORZRES = 8
Private Const VERTRES = 10
    Private Const BITSPIXEL = 12
    Private Const PLANES = 14

Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Public Const MAX_PROCESSOR = 2
Public Const MAX_DISK = 26

' Structure d'exploitation des résultats
' ======================================
Public Type TDataInfoSystem
    OSName As String * 80               ' Description de l'os
    ServicePack As String * 80          ' Description du service pack
    
    PCName As String * 255              ' Nom du PC
    CurrentUser As String * 255         ' Nom de l'utilisateur courant
    Language As String * 255
    Country As String * 255
    CPUInfo As String * 255
    ScreenResolution As String * 255
    ScreenColorPalette As String * 255
    
    MemoryTotal As Long
    MemoryTotalKo As Long
    MemoryTotalMo As Long
    MemoryFree As Long
    MemoryFreeKo As Long
    MemoryFreeMo As Long
    MemoryUsed As Long
    MemoryUsedKo As Long
    MemoryUsedMo As Long
    OS95 As Boolean
    OS98 As Boolean
    OSNT As Boolean
    OS2000 As Boolean
    OSXP As Boolean
   
End Type

    

Public Sub SystemToolsGetWindowsVersion(Data As TDataInfoSystem)
' Retourne La version de windows et de service pack
Dim Os As OSVERSIONINFOEX
Dim CallBack As Long
Dim OSName As String
Dim ServicePack As String


Os.dwOSVersionInfoSize = 148
Os.szCSDVersion = Space$(128)
CallBack = GetVersionEx(Os)



' Type de Plateforme
Select Case Os.dwPlatformId
    Case VER_PLATEFORM_WIN32S
    ' Windows 3.1

    Case VER_PLATEFORM_WIN32_WINDOWS
    ' Windows 95 ou 98
    If Os.dwMinorVersion < 10 Then
        ' Windows 95
        If Os.dwBuildNumber = 950 Then
            OSName = "Windows 95"
        ElseIf Os.dwBuildNumber > 950 And Os.dwBuildNumber <= 1080 Then
            OSName = "Windows 95 - SP1"
        Else
            OSName = "Windows 95 - SP2"
        End If
        Data.OS95 = True

    ElseIf Os.dwMinorVersion = 10 Then
        ' Windows 98
        If Os.dwBuildNumber = 1998 Then
            OSName = "Windows 98"
        ElseIf Os.dwBuildNumber > 1998 And Os.dwBuildNumber < 2183 Then
            OSName = "Windows 98 - SP1"
        ElseIf Os.dwBuildNumber >= 2183 Then
            OSName = "Windows 98 - SE"
        End If
        Data.OS98 = True

        ' Release Pack
    Else
        OSName = "Windows ME"
    End If
    
    Case VER_PLATEFORM_WIN32_NT
    ' Windows NT,2000, XP
    If Os.dwMajorVersion <= 4 Then
        ' NT
        OSName = "Windows NT" & Os.dwMajorVersion & "." & Os.dwMinorVersion
        Data.OSNT = True
    ElseIf Os.dwMajorVersion = 5 And Os.dwMinorVersion = 0 Then
        ' 2000
        OSName = "Windows 2000"
        Data.OS2000 = True
    ElseIf Os.dwMajorVersion = 5 And Os.dwMinorVersion = 1 Then
        ' XP
        OSName = "Windows XP"
        Data.OSXP = True
    End If
    
    
    If Os.dwMajorVersion > 4 Then
        ' Pour 2000, XP et >
        Select Case Os.wProductType
            Case 0
            If Os.wSuiteMask And VER_SUITE_PERSONNAL Then
                OSName = OSName & " Edition Familiale"
            Else
                OSName = OSName & " Professionnel"
            End If
    
            Case VER_NT_WORKSTATION
            If Os.wSuiteMask And VER_SUITE_PERSONNAL Then
                OSName = OSName & " Edition Familiale"
            Else
                OSName = OSName & " Professionnel"
            End If
    
            Case VER_NT_SERVER
            If Os.wSuiteMask And VER_SUITE_DATACENTER Then
                OSName = OSName & " DataCenter"
            ElseIf Os.wSuiteMask And VER_SUITE_ENTERPRISE Then
                OSName = OSName & " Advanced Center"
            Else
                OSName = OSName & " Server"
            End If
    
        End Select
    Else
        Select Case Os.wProductType
            Case VER_NT_WORKSTATION
            OSName = OSName & " Workstation"
    
            Case VER_NT_SERVER
            OSName = OSName & " Server"

            Case VER_NT_DOMAIN_CONTROLLER
            OSName = OSName & " Controlleur de domaine"
        End Select


    End If
    
    
    Case Else
    
End Select

OSName = OSName & " (" & Os.dwMajorVersion & "." & Os.dwMinorVersion & ")"

If Os.wServicePackMajor < 1 Then
    ServicePack = ""
    If InStr(Os.szCSDVersion, Chr$(0)) > 1 Then
        ServicePack = Left$(Os.szCSDVersion, InStr(Os.szCSDVersion, Chr$(0)) - 1)
    End If
Else
    ServicePack = "Service Pack " & Os.wServicePackMajor & "." & Os.wServicePackMinor
End If

'MsgBox "Version : " + OSName + vbCrLf + ServicePack



Data.OSName = OSName
Data.ServicePack = ServicePack


End Sub


Public Sub SystemToolsGetCurrentUserName(Data As TDataInfoSystem)
Dim stTmp As String, lgTmp As Long
stTmp = String$(255, 0)
lgTmp = 255
Call GetUserName(stTmp, lgTmp)

If lgTmp > 0 Then
    Data.CurrentUser = Left$(stTmp, lgTmp)
Else
    Data.CurrentUser = ""
End If

End Sub

Public Sub SystemToolsGetComputerName(Data As TDataInfoSystem)

Dim stTmp As String, lgTmp As Long
stTmp = String$(255, 0)
lgTmp = 255
Call GetComputerName(stTmp, lgTmp)

If lgTmp > 0 Then
    Data.PCName = Left$(stTmp, lgTmp)
Else
    Data.PCName = ""
End If

End Sub

Public Sub SystemToolsGetMemoryData(Data As TDataInfoSystem)
Dim DataMemory As MemoryStatus
Dim TotalPhysique As Long       ' en ko
Dim DispoPhysique As Long       ' en ko

GlobalMemoryStatus DataMemory

' Total
Data.MemoryTotal = DataMemory.dwTotalPhys
TotalPhysique = DataMemory.dwTotalPhys / 1024
Data.MemoryTotalKo = TotalPhysique
Data.MemoryTotalMo = Data.MemoryTotalKo / 1024
' Disponible
Data.MemoryFree = DataMemory.dwAvailPhys
DispoPhysique = DataMemory.dwAvailPhys / 1024
Data.MemoryFreeKo = DispoPhysique
Data.MemoryFreeMo = Data.MemoryFreeKo / 1024
' Utilisé
Data.MemoryUsed = Data.MemoryTotal - Data.MemoryFree
Data.MemoryUsedKo = Data.MemoryTotalKo - Data.MemoryFreeKo
Data.MemoryUsedMo = Data.MemoryUsedKo / 1024
End Sub





Public Sub SystemToolsGetLanguageAndCountry(Data As TDataInfoSystem)
  ' Retourne la langue et le Pays
  Const MAXSIZE As Integer = 100
  Dim sTmp As String * MAXSIZE
  Dim lLCID As Long
  Dim lLen As Long
  Dim SysLanguage As String
  Dim SysCountry As String

  lLCID = GetUserDefaultLCID()
  If (lLCID <> 0) Then
    ' Language
    ' ========
    lLen = GetLocaleInfo(lLCID, LOCALE_SNATIVELANGNAME, sTmp, MAXSIZE - 1)
    If (lLen) Then
      SysLanguage = Left$(sTmp, lLen - 1)
    End If
    ' Country
    ' =======
    lLen = GetLocaleInfo(lLCID, LOCALE_SNATIVECTRYNAME, sTmp, MAXSIZE - 1)
    If (lLen) Then
      SysCountry = Left$(sTmp, lLen - 1)
    End If
  End If

    Data.Country = SysCountry
    Data.Language = SysLanguage
    
  
End Sub

Public Sub SystemToolsGetCpuInfo(Data As TDataInfoSystem)
  Dim SYSINFO As SystemInfo
    
  Dim strModel As String
  Dim strStepping As String
  Dim strTemp As String
  Dim SysCPUInfo As String
  
  Call GetSystemInfo(SYSINFO)

  Select Case SYSINFO.dwProcessorType
    Case PROCESSOR_INTEL_386
      SysCPUInfo = "Intel 386"
    Case PROCESSOR_INTEL_486
      SysCPUInfo = "Intel 386"
    Case PROCESSOR_INTEL_PENTIUM
      'Check which version
      If SYSINFO.wProcessorLevel = 6 Then
        strTemp = Hex(SYSINFO.wProcessorRevision)
        Do While Len(strTemp) < 4
          strTemp = "0" & strTemp
        Loop
        'First int of Hex(SystemInfo.wProcessorRevision) is model #
        strModel = Left$(strTemp, 2)
        'Third int of Hex(SystemInfo.wProcessorRevision) is stepping #
        strStepping = Mid$(strTemp, 3, 2)
        Select Case Val(strModel) 'Check model number
          Case 1
            SysCPUInfo = "Intel Pentium Pro, Model " & strModel & ", Stepping " & strStepping
          Case 3
            SysCPUInfo = "Intel Pentium II, Model 3" & " Stepping " & strStepping
          Case 5
            SysCPUInfo = "Intel Pentium II Model 5, Pentium II Xeon Model 5, or Celeron Model 5," & " Stepping " & strStepping
          Case 6
            SysCPUInfo = "Intel Celeron Model 6" & " Stepping, " & strStepping
          Case 7 To 8
            SysCPUInfo = "Intel Pentium III or Pentium III Xeon Model, " & strModel & " Stepping " & strStepping
          Case Else
            SysCPUInfo = "Unable to determine processor type"
        End Select
        'end fix
      Else
        SysCPUInfo = "Pentium"
      End If
    Case PROCESSOR_MIPS_R4000
      SysCPUInfo = "MIPS R4000"
    Case PROCESSOR_ALPHA_21064
      SysCPUInfo = "Alpha 21064"
    Case Else
      SysCPUInfo = "Unknown"
  End Select
    
    Data.CPUInfo = SysCPUInfo

End Sub

Public Sub SystemToolsGetScreenResolution(Data As TDataInfoSystem)
  'Gets the current display Resolution
  Dim lDC As Long
  Dim lHwnd As Long
  Dim sTmp As String
  Dim lTotalBits As Long
  Dim SysDisplayRes As String
  Dim SysColorPalette As String


  lHwnd = GetDesktopWindow()
  If (lHwnd) Then
    lDC = GetDC(lHwnd)
    If (lDC) Then
      sTmp = GetDeviceCaps(lDC, HORZRES) & " x " & GetDeviceCaps(lDC, VERTRES)
      'Call ReleaseDC(lHwnd, lDC)
    End If
    SysDisplayRes = sTmp
    
    
    If (lDC) Then
      lTotalBits = (GetDeviceCaps(lDC, BITSPIXEL) * GetDeviceCaps(lDC, PLANES))
      If (lTotalBits = 24) Then
        sTmp = "True Color"
      Else
        sTmp = 2 ^ CLng(lTotalBits)
      End If
      SysColorPalette = sTmp
    End If
    
    If (lDC) Then
        Call ReleaseDC(lHwnd, lDC)
    End If
  End If

  
  
  Data.ScreenResolution = SysDisplayRes
  Data.ScreenColorPalette = SysColorPalette
  
End Sub
