frmabout.frm

来自「对ACCESS数据库的数据根据用户的选择做简单分类」· FRM 代码 · 共 214 行

VERSION 5.00
Begin VB.Form frmAbout 
   Caption         =   "About"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdSysInfo 
      Caption         =   "SysInfo"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   2640
      TabIndex        =   3
      Top             =   2520
      Width           =   1095
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "OK"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   960
      TabIndex        =   2
      Top             =   2520
      Width           =   1095
   End
   Begin VB.Label lblTitle 
      Alignment       =   2  'Center
      Caption         =   "Label2"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   15.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   480
      TabIndex        =   1
      Top             =   1560
      Width           =   3735
   End
   Begin VB.Label lblVersion 
      Alignment       =   2  'Center
      Caption         =   "Label1"
      BeginProperty Font 
         Name            =   "Times New Roman"
         Size            =   15.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   600
      TabIndex        =   0
      Top             =   600
      Width           =   3495
   End
End
Attribute VB_Name = "frmAbout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

', * w * * * *w *-*ww** **** *** *w*** ***** *** ****** **** * *****w* ***** * -ww
' Module: fndout. frn
' Prograrner: Kevin Col6n
' * ** *w * ** *** w****** *w* ******** *** ***** ** * * *** * **** *********--*

' Reg Key Security Options...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEYS = &H8
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_KEYS + 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 teminated string
Const REG_DWORD = 4 '32-bit nuMber

Const gREGKEYSYSINFOLOC = "S0FTWARE\Microsoft\Shared Tools Location"
Const gREGVALSYSINFOLOC = "MSINFO"
Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Const gREGVALSYSINFO = "PATH"

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 cmdSysInfo_Click()
       Call StartSysInfo
End Sub


Private Sub cmdOK_Click()
            
            frmMain.Show
            frmMain.Enabled = True
            Unload Me
End Sub
Private Sub Form_load()
       Me.Caption = "About" & App.Title
       lblVersion.Caption = "Version" & App.Major & "." & App.Minor & "." & App.Revision
       lblTitle.Caption = App.Title
End Sub
Public Sub StartSysInfo()
       On Error GoTo SysInfoErr
       Dim rc As Long
       Dim SysInfoPath As String
       
' Try To Get System Info Prograxn Path\Name From Reqistry. -.
       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 Infornation Is Unavai1able 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 ' Hand1e To An 0pen Reqistry Key
       Dim hDepth As Long '
       Dim KeyValTyPe As Long ' Data type 0f A Registry Key
       Dim tmpVal As String ' Tempory  Storage For A Registry Key Value
       Dim KeyValSize As Long ' Size 0f Registry Key Variable
' - - - - - - - - - - - - - - - ~ - - - - - - - - - ~ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' 0pen RegKcy Under KeyRoot { HKEYTh0 CALM H I NE... }
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
       rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 0Pen Registry KEY
       If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Error...
       tmpVal = String$(1024, 0) ' A11ocate Variable Space
       KeyValSize = 1024 ' M8rk Variab1e Size
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ~ - - - - - - - - -
' Retrieve Registry Key Value...
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ~ - - - - - - - - - - - -
       rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValTyPe, tmpVal, KeyValSize) 'Get /Create Key Va1ue
       If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Handle Errors
       If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then   ' Win95 Adds Null Terninated String...
                tmpVal = Left(tmpVal, KeyValSize - 1) ' Nul1 Found, Extract From String
           Else ' WiANT Does N0T Null Teruinate String...
                tmpVal = Left(tmpVal, KeyValSize) ' Null Not Found, Extract String 0nly
       End If
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' Deternine Key Value type For Conversion...
' - - - - - - - - - - - ~ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ~ - ~ - ~ -
       Select Case KeyValTyPe ' Search Data toes...
          Case REG_SZ ' String Registry Key Data twe
                  KeyVal = tmpVal ' Copy String Value
          Case REG_DWORD ' Double Word Registry Key Data twe
             For i = Len(tmpVal) To 1 Step -1 ' Comiert 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 ' Returu Suc c es s
       rc = RegCloseKey(hKey) ' Close Registry KEY ' Exit
       Exit Function ' Exit
       
GetKeyError: ' C1eanup After An Error Has 0ccured-.,
         KeyVal = "" ' Set Return Va1 To forty Strina
         GetKeyValue = False ' Return Fa ilure
         rc = RegCloseKey(hKey) ' Close Registry KEY
End Function
Private Sub Form_unload(Cance1 As Integer)
       Unload Me
End Sub