frmAbout.frm
上传用户:fulizhu2
上传日期:2007-06-21
资源大小:34k
文件大小:9k
源码类别:

酒店行业

开发平台:

Visual Basic

  1. VERSION 5.00
  2. Begin VB.Form frmAbout 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "About Hotel_Mis"
  5.    ClientHeight    =   3636
  6.    ClientLeft      =   36
  7.    ClientTop       =   336
  8.    ClientWidth     =   5892
  9.    ClipControls    =   0   'False
  10.    LinkTopic       =   "Form1"
  11.    MaxButton       =   0   'False
  12.    MinButton       =   0   'False
  13.    ScaleHeight     =   3636
  14.    ScaleWidth      =   5892
  15.    ShowInTaskbar   =   0   'False
  16.    StartUpPosition =   1  'CenterOwner
  17.    Tag             =   "About Hotel_Mis"
  18.    Begin VB.PictureBox picIcon 
  19.       AutoSize        =   -1  'True
  20.       BackColor       =   &H00C0C0C0&
  21.       ClipControls    =   0   'False
  22.       Height          =   432
  23.       Left            =   240
  24.       Picture         =   "frmAbout.frx":0000
  25.       ScaleHeight     =   374.634
  26.       ScaleMode       =   0  'User
  27.       ScaleWidth      =   374.634
  28.       TabIndex        =   2
  29.       TabStop         =   0   'False
  30.       Top             =   240
  31.       Width           =   432
  32.    End
  33.    Begin VB.CommandButton cmdOK 
  34.       Cancel          =   -1  'True
  35.       Caption         =   "OK"
  36.       Default         =   -1  'True
  37.       Height          =   345
  38.       Left            =   4245
  39.       TabIndex        =   0
  40.       Tag             =   "OK"
  41.       Top             =   2625
  42.       Width           =   1467
  43.    End
  44.    Begin VB.CommandButton cmdSysInfo 
  45.       Caption         =   "&System Info..."
  46.       Height          =   345
  47.       Left            =   4260
  48.       TabIndex        =   1
  49.       Tag             =   "&System Info..."
  50.       Top             =   3075
  51.       Width           =   1452
  52.    End
  53.    Begin VB.Label lblDescription 
  54.       Caption         =   "App Description"
  55.       ForeColor       =   &H00000000&
  56.       Height          =   1170
  57.       Left            =   1050
  58.       TabIndex        =   6
  59.       Tag             =   "App Description"
  60.       Top             =   1125
  61.       Width           =   4092
  62.    End
  63.    Begin VB.Label lblTitle 
  64.       Caption         =   "Application Title"
  65.       ForeColor       =   &H00000000&
  66.       Height          =   480
  67.       Left            =   1050
  68.       TabIndex        =   5
  69.       Tag             =   "Application Title"
  70.       Top             =   240
  71.       Width           =   4092
  72.    End
  73.    Begin VB.Line Line1 
  74.       BorderColor     =   &H00808080&
  75.       BorderStyle     =   6  'Inside Solid
  76.       Index           =   1
  77.       X1              =   225
  78.       X2              =   5657
  79.       Y1              =   2430
  80.       Y2              =   2430
  81.    End
  82.    Begin VB.Line Line1 
  83.       BorderColor     =   &H00FFFFFF&
  84.       BorderWidth     =   2
  85.       Index           =   0
  86.       X1              =   240
  87.       X2              =   5657
  88.       Y1              =   2445
  89.       Y2              =   2445
  90.    End
  91.    Begin VB.Label lblVersion 
  92.       Caption         =   "Version"
  93.       Height          =   225
  94.       Left            =   1050
  95.       TabIndex        =   4
  96.       Tag             =   "Version"
  97.       Top             =   780
  98.       Width           =   4092
  99.    End
  100.    Begin VB.Label lblDisclaimer 
  101.       Caption         =   "Warning: ..."
  102.       ForeColor       =   &H00000000&
  103.       Height          =   825
  104.       Left            =   255
  105.       TabIndex        =   3
  106.       Tag             =   "Warning: ..."
  107.       Top             =   2625
  108.       Width           =   3870
  109.    End
  110. End
  111. Attribute VB_Name = "frmAbout"
  112. Attribute VB_GlobalNameSpace = False
  113. Attribute VB_Creatable = False
  114. Attribute VB_PredeclaredId = True
  115. Attribute VB_Exposed = False
  116. ' Reg Key Security Options...
  117. Const KEY_ALL_ACCESS = &H2003F
  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 = "SOFTWAREMicrosoftShared Tools Location"
  125. Const gREGVALSYSINFOLOC = "MSINFO"
  126. Const gREGKEYSYSINFO = "SOFTWAREMicrosoftShared ToolsMSINFO"
  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 Form_Load()
  132.     lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
  133.     lblTitle.Caption = App.Title
  134. End Sub
  135. Private Sub cmdSysInfo_Click()
  136.         Call StartSysInfo
  137. End Sub
  138. Private Sub cmdOK_Click()
  139.         Unload Me
  140. End Sub
  141. Public Sub StartSysInfo()
  142.     On Error GoTo SysInfoErr
  143.         Dim rc As Long
  144.         Dim SysInfoPath As String
  145.         
  146.         ' Try To Get System Info Program PathName 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.         
  163.         Call Shell(SysInfoPath, vbNormalFocus)
  164.         
  165.         Exit Sub
  166. SysInfoErr:
  167.         MsgBox "System Information Is Unavailable At This Time", vbOKOnly
  168. End Sub
  169. Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
  170.         Dim i As Long                                           ' Loop Counter
  171.         Dim rc As Long                                          ' Return Code
  172.         Dim hKey As Long                                        ' Handle To An Open Registry Key
  173.         Dim hDepth As Long                                      '
  174.         Dim KeyValType As Long                                  ' Data Type Of A Registry Key
  175.         Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
  176.         Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
  177.         '------------------------------------------------------------
  178.         ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
  179.         '------------------------------------------------------------
  180.         rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
  181.         
  182.         If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
  183.         
  184.         tmpVal = String$(1024, 0)                             ' Allocate Variable Space
  185.         KeyValSize = 1024                                       ' Mark Variable Size
  186.         
  187.         '------------------------------------------------------------
  188.         ' Retrieve Registry Key Value...
  189.         '------------------------------------------------------------
  190.         rc = RegQueryValueEx(hKey, SubKeyRef, 0, KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
  191.                                                 
  192.         If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
  193.         
  194.         tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
  195.         '------------------------------------------------------------
  196.         ' Determine Key Value Type For Conversion...
  197.         '------------------------------------------------------------
  198.         Select Case KeyValType                                  ' Search Data Types...
  199.         Case REG_SZ                                             ' String Registry Key Data Type
  200.                 KeyVal = tmpVal                                     ' Copy String Value
  201.         Case REG_DWORD                                          ' Double Word Registry Key Data Type
  202.                 For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
  203.                         KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
  204.                 Next
  205.                 KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
  206.         End Select
  207.         
  208.         GetKeyValue = True                                      ' Return Success
  209.         rc = RegCloseKey(hKey)                                  ' Close Registry Key
  210.         Exit Function                                           ' Exit
  211.         
  212. GetKeyError:    ' Cleanup After An Error Has Occured...
  213.         KeyVal = ""                                             ' Set Return Val To Empty String
  214.         GetKeyValue = False                                     ' Return Failure
  215.         rc = RegCloseKey(hKey)                                  ' Close Registry Key
  216. End Function