Attribute VB_Name = "Module1"
Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function GetVersion Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
#Else
    Private Declare Function GetVersion Lib "kernel32" () As Long
    Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
#End If

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
 
Private Sub GetComputerOSandVersion()
 
    Dim OSInfo As OSVERSIONINFO
    OSInfo.dwOSVersionInfoSize = Len(OSInfo)
    Dim PId As String
 
    If GetVersionEx(OSInfo) = 0 Then MsgBox$ "Error Getting Version Information": Exit Sub
    Select Case OSInfo.dwPlatformId
        Case 0
            PId = "Windows 32s"
        Case 1
            PId = "Windows 95/98"
        Case 2
            PId = "Windows NT"
    End Select
 
    Dim OS As String
    Dim WinVersion As String
    Dim Build As String

    'XP - Windows NT
    OS = "OS: " + PId
    'XP - 5,1
    WinVersion = "Win version:" + Str$(OSInfo.dwMajorVersion) + "." + LTrim(Str(OSInfo.dwMinorVersion))
    'XP - 2600
    Build = "Build: " + Str(OSInfo.dwBuildNumber)
    MsgBox$ OS & Chr(13) & WinVersion & Chr(13) & Build
 
End Sub
Public Function GetWinOSType() As String
    Dim xOS As String
    #If Win64 Then
        xOS = "amd64"
    #Else
        xOS = "x86"
    #End If
    GetWinOSType = xOS
End Function

Public Function GetWinVersion() As String
    Dim Ver As Long, WinVer As Long
    Ver = GetVersion()
    WinVer = Ver And &HFFFF&
    'retrieve the windows version
    GetWinVersion = Format((WinVer Mod 256) + ((WinVer \ 256) / 100), "Fixed")
End Function
Private Sub Form_Load()
'KPD-Team 1999
'URL: [url]http://www.allapi.net/[/url]
'E-Mail: [email]KPDTeam@Allapi.net[/email]
MsgBox "Windows version: " + GetWinVersion
End Sub
' *******************************************************
' Procedure GetOffice_Version
' This Function will Check the Version of the
' Microsoft Office Aplication and Put it into a Message Box
' *******************************************************

Public Sub GetOffice_Version()
    Dim version As String
    Dim anApplication As String
    Dim anApplicationFullPath As String
    Dim fso As Object
    Dim bFlag As Boolean
    
    Dim major As String
    Dim majorup As String
    Dim minor As String
    Dim minorup As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    anApplication = "Winword.exe"
    anApplicationFullPath = Application.Path + "\" + anApplication

    ' List of references
        version = fso.GetFileVersion(anApplicationFullPath)
        major = RetrievePart(version, 0)
        majorup = RetrievePart(version, 1)
        minor = RetrievePart(version, 2)
        minorup = RetrievePart(version, 3)

        MsgBox anApplication & " : " & major & "." & majorup & "." & minor & "." & minorup
        
        version = Application.BuildFull
        major = RetrievePart(version, 0)
        majorup = RetrievePart(version, 1)
        minor = RetrievePart(version, 2)
        minorup = RetrievePart(version, 3)

        MsgBox Application.Name & " : " & major & "." & majorup & "." & minor & "." & minorup
        
        MsgBox "Windows Version: " & GetWinVersion & vbNewLine & "Windows Type: " & GetWinOSType & vbNewLine
        
        GetComputerOSandVersion
        GetXlLang

        bFlag = CheckComputerOSandOfficeVersion()
        If Not bFlag Then
            MsgBox "Ошибка при проверки версии операционной системы и офиса." & vbNewLine & _
            "Данный документ откроется только в 64-х битной русской" & vbNewLine & _
            "операционной системе Microsoft Windows 8.1/10/11 или Microsoft" & vbNewLine & _
            "Windows Server 2012R2/2016/2019/2022 и установленным" & vbNewLine & _
            "Microsoft Office 2007 и выше." & vbNewLine & vbNewLine & _
            "Пожалуйста, обновите Вашу систему!", vbCritical Or vbOKOnly, "System Error"
        End If
        
End Sub

Private Function CheckComputerOSandOfficeVersion() As Boolean
    Dim officeVersion As String
    Dim osType As String
    Dim anOfficeMajor As Integer
    Dim aWindowsMajor As Long
    Dim aWindowsMinor As Long
    Dim OfficeMajor As String
    Dim lngCode As Long

    lngCode = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
    If lngCode <> 1049 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox "Error! An OS Language is " & GetLocale(lngCode) & vbNewLine & "which is not corresponded Russian Language.", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    
    
    osType = GetWinOSType
    If StrComp(osType, "amd64") <> 0 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox "Error! An OS Type is " & osType & vbNewLine & "which is not corresponded amd64.", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    officeVersion = Application.BuildFull
    OfficeMajor = RetrievePart(officeVersion, 0)
    anOfficeMajor = CInt(OfficeMajor)
    If anOfficeMajor < 12 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox "Error! A Microsoft Office Version is " & OfficeMajor & vbNewLine & "which is not corresponded Microsoft Office 2007 (15) and greater.", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    Dim OSInfo As OSVERSIONINFO
    OSInfo.dwOSVersionInfoSize = Len(OSInfo)
    
    Dim PId As String
 
    If GetVersionEx(OSInfo) = 0 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox$ "Error Getting Version Information." & vbNewLine & "May OS not to be Recognized?", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    
    Select Case OSInfo.dwPlatformId
        Case 0
            PId = "Windows 32s"
        Case 1
            PId = "Windows 95/98"
        Case 2
            PId = "Windows NT"
    End Select
    
    If OSInfo.dwPlatformId <> 2 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox$ "Error Getting OS Version Information." & vbNewLine & "OS must be Windows NT Series", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
 
    aWindowsMajor = OSInfo.dwMajorVersion
    aWindowsMinor = OSInfo.dwMinorVersion
    
    If aWindowsMajor < 6 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox$ "Error Getting OS Version." & vbNewLine & "OS must be Windows 8.1 and greater", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    
    If aWindowsMajor = 6 And aWindowsMinor < 3 Then
        CheckComputerOSandOfficeVersion = False
        MsgBox$ "Error Getting OS Version." & vbNewLine & "OS must be Windows 8.1 and greater", vbCritical Or vbOKOnly, "System Error"
        Exit Function
    End If
    CheckComputerOSandOfficeVersion = True
End Function

' *****************************************************
' Function RetrieveDllVersion
' This Function will Retrieve the Version of the DLL
' File by its Path
'
' PARAMETERS:   dll as String is a full path to dll file
' RETURNS:      as String the Version of the dll file
' *****************************************************
Private Function RetrieveDllVersion(ByVal dll As String) As String
  Dim fso As Object 'Scripting.FileSystemObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  RetrieveDllVersion = fso.GetFileVersion(dll)
End Function

' *****************************************************
' Function RetrievePart
' The Function will Retrieve a Part of the String 'version'
' in Position 'pos' Delimited per dots
'
' PARAMETERS:   version as Sring is a Version Sring with dot delimiter
'               pos as Integer is a position of string withing delimiter (begin with 0)
' RETURNS:      as String a part of the splited string with version at ponted position
'******************************************************
Private Function RetrievePart(ByVal version As String, ByVal pos As Integer) As String
    RetrievePart = Split(version, ".")(pos)
End Function


Private Sub GetXlLang()
    Dim lngCode As Long
    lngCode = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
'    MsgBox "Code is: " & lngCode & vbNewLine & GetLngCodeToTxt(lngCode)
    MsgBox "Code is: " & lngCode & vbNewLine & GetLocale(lngCode)
End Sub

Private Function GetLngCodeToTxt(ByVal lngCode) As String
    Dim objXmlHTTP As Object
    Dim objRegex As Object
    Dim objRegMC As Object
    Dim strResponse As String
    Dim strSite As String

    Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")
    strSite = "http://msdn.microsoft.com/en-us/goglobal/bb964664"

    On Error GoTo ErrHandler
    With objXmlHTTP
        .Open "GET", strSite, False
        .send
        If .Status = 200 Then strResponse = .responseText
    End With
    On Error GoTo 0

    strResponse = Replace(strResponse, "</td><td>", vbNullString)
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .Pattern = "><td>([a-zA-Z- ]+)[A-Fa-f0-9]{4}" & lngCode
        If .test(strResponse) Then
            Set objRegMC = .Execute(strResponse)
            GetLngCodeToTxt = objRegMC(0).submatches(0)
        Else
            GetLngCodeToTxt = "Value not found from " & strSite
        End If
    End With
    Set objRegex = Nothing
    Set objXmlHTTP = Nothing
    Exit Function
ErrHandler:
    If Not objXmlHTTP Is Nothing Then Set objXmlHTTP = Nothing
    GetLngCodeToTxt = strSite & " unable to be accessed"
End Function

Private Function GetLocale(ByVal lngCode) As String
    Dim html            As Object
    Dim http            As Object
    Dim htmlTable       As Object
    Dim htmlRow         As Object
    Dim htmlCell        As Object
    Dim url             As String

    Set html = CreateObject("htmlfile")
    Set http = CreateObject("MSXML2.XMLHTTP")
    url = "https://www.science.co.il/language/Locale-codes.php"

    On Error GoTo ErrHandler
        With http
            .Open "GET", url, False
            .send
            If .Status = 200 Then html.body.innerHTML = .responseText
        End With
    On Error GoTo 0

    Set htmlTable = html.getElementsByTagName("table")(0)

    For Each htmlRow In htmlTable.getElementsByTagName("tr")
        For Each htmlCell In htmlRow.Children
            If htmlCell.innerText = CStr(lngCode) Then
                GetLocale = htmlRow.getElementsByTagName("td")(0).innerText
                Exit For
            End If
        Next htmlCell
    Next htmlRow

    If GetLocale = "" Then GetLocale = "Value Not Found From " & url

    Exit Function
ErrHandler:
    If Not http Is Nothing Then Set http = Nothing
    GetLocale = url & " Unable To Be Accessed"
End Function