home *** CD-ROM | disk | FTP | other *** search
/ distrib.akp.su/Programming/Vb-6+Rus/ / distrib.akp.su.tar / distrib.akp.su / Programming / Vb-6+Rus / VB98 / TEMPLATE / FORMS / ABTDLG.FRM (.txt) < prev    next >
Visual Basic Form  |  1998-06-18  |  10KB  |  214 lines
  1. VERSION 5.00
  2. Begin VB.Form frmAbout 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "About MyApp"
  5.    ClientHeight    =   3555
  6.    ClientLeft      =   2340
  7.    ClientTop       =   1935
  8.    ClientWidth     =   5730
  9.    ClipControls    =   0   'False
  10.    LinkTopic       =   "Form2"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   2453.724
  14.    ScaleMode       =   0  'User
  15.    ScaleWidth      =   5380.766
  16.    ShowInTaskbar   =   0   'False
  17.    Begin VB.PictureBox picIcon 
  18.       AutoSize        =   -1  'True
  19.       ClipControls    =   0   'False
  20.       Height          =   540
  21.       Left            =   240
  22.       Picture         =   "About Dialog.frx":0000
  23.       ScaleHeight     =   337.12
  24.       ScaleMode       =   0  'User
  25.       ScaleWidth      =   337.12
  26.       TabIndex        =   1
  27.       Top             =   240
  28.       Width           =   540
  29.    End
  30.    Begin VB.CommandButton cmdOK 
  31.       Cancel          =   -1  'True
  32.       Caption         =   "OK"
  33.       Default         =   -1  'True
  34.       Height          =   345
  35.       Left            =   4245
  36.       TabIndex        =   0
  37.       Top             =   2625
  38.       Width           =   1260
  39.    End
  40.    Begin VB.CommandButton cmdSysInfo 
  41.       Caption         =   "&System Info..."
  42.       Height          =   345
  43.       Left            =   4260
  44.       TabIndex        =   2
  45.       Top             =   3075
  46.       Width           =   1245
  47.    End
  48.    Begin VB.Line Line1 
  49.       BorderColor     =   &H00808080&
  50.       BorderStyle     =   6  'Inside Solid
  51.       Index           =   1
  52.       X1              =   84.515
  53.       X2              =   5309.398
  54.       Y1              =   1687.583
  55.       Y2              =   1687.583
  56.    End
  57.    Begin VB.Label lblDescription 
  58.       Caption         =   "App Description"
  59.       ForeColor       =   &H00000000&
  60.       Height          =   1170
  61.       Left            =   1050
  62.       TabIndex        =   3
  63.       Top             =   1125
  64.       Width           =   3885
  65.    End
  66.    Begin VB.Label lblTitle 
  67.       Caption         =   "Application Title"
  68.       ForeColor       =   &H00000000&
  69.       Height          =   480
  70.       Left            =   1050
  71.       TabIndex        =   5
  72.       Top             =   240
  73.       Width           =   3885
  74.    End
  75.    Begin VB.Line Line1 
  76.       BorderColor     =   &H00FFFFFF&
  77.       BorderWidth     =   2
  78.       Index           =   0
  79.       X1              =   98.6
  80.       X2              =   5309.398
  81.       Y1              =   1697.936
  82.       Y2              =   1697.936
  83.    End
  84.    Begin VB.Label lblVersion 
  85.       Caption         =   "Version"
  86.       Height          =   225
  87.       Left            =   1050
  88.       TabIndex        =   6
  89.       Top             =   780
  90.       Width           =   3885
  91.    End
  92.    Begin VB.Label lblDisclaimer 
  93.       Caption         =   "Warning: ..."
  94.       ForeColor       =   &H00000000&
  95.       Height          =   825
  96.       Left            =   255
  97.       TabIndex        =   4
  98.       Top             =   2625
  99.       Width           =   3870
  100.    End
  101. Attribute VB_Name = "frmAbout"
  102. Attribute VB_GlobalNameSpace = False
  103. Attribute VB_Creatable = False
  104. Attribute VB_PredeclaredId = True
  105. Attribute VB_Exposed = False
  106. Option Explicit
  107. ' Reg Key Security Options...
  108. Const READ_CONTROL = &H20000
  109. Const KEY_QUERY_VALUE = &H1
  110. Const KEY_SET_VALUE = &H2
  111. Const KEY_CREATE_SUB_KEY = &H4
  112. Const KEY_ENUMERATE_SUB_KEYS = &H8
  113. Const KEY_NOTIFY = &H10
  114. Const KEY_CREATE_LINK = &H20
  115. Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
  116.                        KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
  117.                        KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
  118.                      
  119. ' Reg Key ROOT Types...
  120. Const HKEY_LOCAL_MACHINE = &H80000002
  121. Const ERROR_SUCCESS = 0
  122. Const REG_SZ = 1                         ' Unicode nul terminated string
  123. Const REG_DWORD = 4                      ' 32-bit number
  124. Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
  125. Const gREGVALSYSINFOLOC = "MSINFO"
  126. Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
  127. Const gREGVALSYSINFO = "PATH"
  128. 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
  129. 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
  130. Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
  131. Private Sub cmdSysInfo_Click()
  132.   Call StartSysInfo
  133. End Sub
  134. Private Sub cmdOK_Click()
  135.   Unload Me
  136. End Sub
  137. Private Sub Form_Load()
  138.     Me.Caption = "About " & App.Title
  139.     lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
  140.     lblTitle.Caption = App.Title
  141. End Sub
  142. Public Sub StartSysInfo()
  143.     On Error GoTo SysInfoErr
  144.     Dim rc As Long
  145.     Dim SysInfoPath As String
  146.     ' Try To Get System Info Program Path\Name From Registry...
  147.     If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
  148.     ' Try To Get System Info Program Path Only From Registry...
  149.     ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
  150.         ' Validate Existance Of Known 32 Bit File Version
  151.         If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
  152.             SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
  153.             
  154.         ' Error - File Can Not Be Found...
  155.         Else
  156.             GoTo SysInfoErr
  157.         End If
  158.     ' Error - Registry Entry Can Not Be Found...
  159.     Else
  160.         GoTo SysInfoErr
  161.     End If
  162.     Call Shell(SysInfoPath, vbNormalFocus)
  163.     Exit Sub
  164. SysInfoErr:
  165.     MsgBox "System Information Is Unavailable At This Time", vbOKOnly
  166. End Sub
  167. Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
  168.     Dim i As Long                                           ' Loop Counter
  169.     Dim rc As Long                                          ' Return Code
  170.     Dim hKey As Long                                        ' Handle To An Open Registry Key
  171.     Dim hDepth As Long                                      '
  172.     Dim KeyValType As Long                                  ' Data Type Of A Registry Key
  173.     Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
  174.     Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
  175.     '------------------------------------------------------------
  176.     ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
  177.     '------------------------------------------------------------
  178.     rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
  179.     If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
  180.     tmpVal = String$(1024, 0)                             ' Allocate Variable Space
  181.     KeyValSize = 1024                                       ' Mark Variable Size
  182.     '------------------------------------------------------------
  183.     ' Retrieve Registry Key Value...
  184.     '------------------------------------------------------------
  185.     rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
  186.                          KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
  187.                         
  188.     If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
  189.     If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 Adds Null Terminated String...
  190.         tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null Found, Extract From String
  191.     Else                                                    ' WinNT Does NOT Null Terminate String...
  192.         tmpVal = Left(tmpVal, KeyValSize)                   ' Null Not Found, Extract String Only
  193.     End If
  194.     '------------------------------------------------------------
  195.     ' Determine Key Value Type For Conversion...
  196.     '------------------------------------------------------------
  197.     Select Case KeyValType                                  ' Search Data Types...
  198.     Case REG_SZ                                             ' String Registry Key Data Type
  199.         KeyVal = tmpVal                                     ' Copy String Value
  200.     Case REG_DWORD                                          ' Double Word Registry Key Data Type
  201.         For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
  202.             KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
  203.         Next
  204.         KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
  205.     End Select
  206.     GetKeyValue = True                                      ' Return Success
  207.     rc = RegCloseKey(hKey)                                  ' Close Registry Key
  208.     Exit Function                                           ' Exit
  209. GetKeyError:      ' Cleanup After An Error Has Occured...
  210.     KeyVal = ""                                             ' Set Return Val To Empty String
  211.     GetKeyValue = False                                     ' Return Failure
  212.     rc = RegCloseKey(hKey)                                  ' Close Registry Key
  213. End Function
  214.