VERSION 5.00 Begin VB.Form frmAbout AutoRedraw = -1 'True BorderStyle = 3 'Fixed Dialog Caption = "О программе" ClientHeight = 2895 ClientLeft = 2340 ClientTop = 1935 ClientWidth = 3855 ClipControls = 0 'False Icon = "Uravnenie_About.frx":0000 LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False Picture = "Uravnenie_About.frx":69C2 ScaleHeight = 1998.18 ScaleMode = 0 'User ScaleWidth = 3620.044 ShowInTaskbar = 0 'False StartUpPosition = 2 'CenterScreen Begin VB.CommandButton cmdAboutUGATU BackColor = &H0000FFFF& Caption = "&Об УГАТУ" Height = 345 Left = 1357 MouseIcon = "Uravnenie_About.frx":2BC2A MousePointer = 99 'Custom Style = 1 'Graphical TabIndex = 2 Top = 2473 Width = 1140 End Begin VB.PictureBox picIcon AutoSize = -1 'True ClipControls = 0 'False Height = 540 Left = 3960 Picture = "Uravnenie_About.frx":2BD7C ScaleHeight = 337.12 ScaleMode = 0 'User ScaleWidth = 337.12 TabIndex = 1 Top = 0 Width = 540 End Begin VB.CommandButton cmdOK BackColor = &H0000C000& Cancel = -1 'True Caption = "&OK" Default = -1 'True Height = 345 Left = 120 MouseIcon = "Uravnenie_About.frx":2C086 MousePointer = 99 'Custom Style = 1 'Graphical TabIndex = 0 ToolTipText = "Закрыть" Top = 2473 Width = 1140 End Begin VB.CommandButton cmdSysInfo BackColor = &H000000FF& Caption = "&System Info..." Height = 345 Left = 2594 MouseIcon = "Uravnenie_About.frx":2C1D8 MousePointer = 99 'Custom Style = 1 'Graphical TabIndex = 3 ToolTipText = "Информация о системе" Top = 2473 Width = 1140 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& BorderWidth = 2 Index = 2 X1 = 98.6 X2 = 3514.87 Y1 = 911.087 Y2 = 911.087 End Begin VB.Label lblDescription BackStyle = 0 'Transparent Caption = $"Uravnenie_About.frx":2C32A BeginProperty Font Name = "Times New Roman" Size = 9 Charset = 204 Weight = 400 Underline = 0 'False Italic = -1 'True Strikethrough = 0 'False EndProperty ForeColor = &H80000017& Height = 945 Left = 240 TabIndex = 6 ToolTipText = "Краткое описание приложения" Top = 406 Width = 3360 End Begin VB.Label lblTitle Alignment = 2 'Center AutoSize = -1 'True BackStyle = 0 'Transparent Caption = """Уравнение""/""Uravnenie.exe""" BeginProperty Font Name = "MS Serif" Size = 12 Charset = 204 Weight = 700 Underline = -1 'True Italic = -1 'True Strikethrough = 0 'False EndProperty ForeColor = &H00400000& Height = 285 Left = 180 TabIndex = 4 ToolTipText = "Заголовок приложения" Top = 0 Width = 3540 End Begin VB.Label lblVersion AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Версия 1" BeginProperty Font Name = "MS Serif" Size = 8.25 Charset = 204 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00400000& Height = 195 Left = 1440 TabIndex = 5 ToolTipText = "Версия" Top = 240 Width = 735 End Begin VB.Line Line1 BorderColor = &H00FFFFFF& BorderWidth = 2 Index = 0 X1 = 98.6 X2 = 3514.87 Y1 = 1656.522 Y2 = 1656.522 End Begin VB.Line Line1 BorderColor = &H00808080& BorderStyle = 6 'Inside Solid Index = 1 X1 = 84.515 X2 = 3514.87 Y1 = 1656.522 Y2 = 1656.522 End Begin VB.Label lblDisclaimer BackStyle = 0 'Transparent Caption = $"Uravnenie_About.frx":2C3CB ForeColor = &H80000017& Height = 975 Left = 240 TabIndex = 7 ToolTipText = "Информация об авторе и защите авторских прав при работе с данным приложением" Top = 1369 Width = 3360 End End Attribute VB_Name = "frmAbout" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit ' Reg Key Security Options... Const READ_CONTROL = &H20000 Const KEY_QUERY_VALUE = &H1 Const KEY_SET_VALUE = &H2 Const KEY_CREATE_SUB_KEY = &H4 Const KEY_ENUMERATE_SUB_KEYS = &H8 Const KEY_NOTIFY = &H10 Const KEY_CREATE_LINK = &H20 Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _ KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _ KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL ' Reg Key ROOT Types... Const HKEY_LOCAL_MACHINE = &H80000002 Const ERROR_SUCCESS = 0 Const REG_SZ = 1 ' Unicode nul terminated string Const REG_DWORD = 4 ' 32-bit number Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location" Const gREGVALSYSINFOLOC = "MSINFO" Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO" Const gREGVALSYSINFO = "PATH" Private Start As Double Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long Private Sub cmdAboutUGATU_Click() If Dir("intro.exe") = "intro.exe" Then 'Файл "intro.exe" присутствует Start = Shell("intro.exe", vbMaximizedFocus) Else 'Файл "intro.exe" отсутствует MsgBox "Файл " & Chr(34) & "intro.exe" & Chr(34) & " не найден.", vbCritical, "Ошибка №53" Exit Sub End If End Sub Private Sub cmdSysInfo_Click() Call StartSysInfo End Sub Private Sub cmdOK_Click() Unload frmAbout End Sub Private Sub Form_Load() frmAbout.Caption = "О программе " & Chr(34) & App.Title & Chr(34) lblVersion.Caption = "Версия " & App.Major & "." & App.Minor & "." & App.Revision lblTitle.Caption = Chr(34) & "Уравнение" & Chr(34) & "/" & Chr(34) & "Uravnenie.exe" & Chr(34) End Sub Public Sub StartSysInfo() On Error GoTo SysInfoErr Dim rc As Long Dim SysInfoPath As String ' Try To Get System Info Program Path\Name From Registry... If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then ' Try To Get System Info Program Path Only From Registry... ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then ' Validate Existance Of Known 32 Bit File Version If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then SysInfoPath = SysInfoPath & "\MSINFO32.EXE" ' Error - File Can Not Be Found... Else GoTo SysInfoErr End If ' Error - Registry Entry Can Not Be Found... Else GoTo SysInfoErr End If Call Shell(SysInfoPath, vbNormalFocus) Exit Sub SysInfoErr: MsgBox "System Information Is Unavailable At This Time", vbOKOnly End Sub Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean Dim i As Long ' Loop Counter Dim rc As Long ' Return Code Dim hKey As Long ' Handle To An Open Registry Key Dim hDepth As Long ' Dim KeyValType As Long ' Data Type Of A Registry Key Dim tmpVal As String ' Tempory Storage For A Registry Key Value Dim KeyValSize As Long ' Size Of Registry Key Variable '------------------------------------------------------------ ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...} '------------------------------------------------------------ rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error... tmpVal = String$(1024, 0) ' Allocate Variable Space KeyValSize = 1024 ' Mark Variable Size '------------------------------------------------------------ ' Retrieve Registry Key Value... '------------------------------------------------------------ rc = RegQueryValueEx(hKey, SubKeyRef, 0, _ KeyValType, tmpVal, KeyValSize) ' Get/Create Key Value If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then ' Win95 Adds Null Terminated String... tmpVal = Left(tmpVal, KeyValSize - 1) ' Null Found, Extract From String Else ' WinNT Does NOT Null Terminate String... tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String Only End If '------------------------------------------------------------ ' Determine Key Value Type For Conversion... '------------------------------------------------------------ Select Case KeyValType ' Search Data Types... Case REG_SZ ' String Registry Key Data Type KeyVal = tmpVal ' Copy String Value Case REG_DWORD ' Double Word Registry Key Data Type For i = Len(tmpVal) To 1 Step -1 ' Convert Each Bit KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Build Value Char. By Char. Next KeyVal = Format$("&h" + KeyVal) ' Convert Double Word To String End Select GetKeyValue = True ' Return Success rc = RegCloseKey(hKey) ' Close Registry Key Exit Function ' Exit GetKeyError: ' Cleanup After An Error Has Occured... KeyVal = "" ' Set Return Val To Empty String GetKeyValue = False ' Return Failure rc = RegCloseKey(hKey) ' Close Registry Key End Function