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