home *** CD-ROM | disk | FTP | other *** search
/ Chip Hitware 7 B / CHIP_HITWARE_7B.iso / Edukacja / WorldView / worldview.exe / %MAINDIR% / Source / About.frm (.txt) next >
Encoding:
Visual Basic Form  |  2000-02-21  |  12.5 KB  |  308 lines

  1. VERSION 5.00
  2. Begin VB.Form frmAbout 
  3.    BorderStyle     =   3  'Fixed Dialog
  4.    Caption         =   "About MyApp"
  5.    ClientHeight    =   3195
  6.    ClientLeft      =   2340
  7.    ClientTop       =   1935
  8.    ClientWidth     =   5730
  9.    ClipControls    =   0   'False
  10.    HelpContextID   =   10
  11.    Icon            =   "About.frx":0000
  12.    LinkTopic       =   "Form2"
  13.    MaxButton       =   0   'False
  14.    MinButton       =   0   'False
  15.    ScaleHeight     =   2205.246
  16.    ScaleMode       =   0  'User
  17.    ScaleWidth      =   5380.766
  18.    ShowInTaskbar   =   0   'False
  19.    StartUpPosition =   2  'CenterScreen
  20.    Tag             =   "lblComments"
  21.    Begin VB.PictureBox picIcon 
  22.       AutoSize        =   -1  'True
  23.       ClipControls    =   0   'False
  24.       Height          =   540
  25.       Left            =   240
  26.       ScaleHeight     =   337.12
  27.       ScaleMode       =   0  'User
  28.       ScaleWidth      =   337.12
  29.       TabIndex        =   6
  30.       Top             =   240
  31.       Width           =   540
  32.    End
  33.    Begin VB.CommandButton cmdOK 
  34.       Cancel          =   -1  'True
  35.       Caption         =   "OK"
  36.       Default         =   -1  'True
  37.       Height          =   345
  38.       Left            =   4320
  39.       TabIndex        =   0
  40.       Top             =   1920
  41.       Width           =   1260
  42.    End
  43.    Begin VB.CommandButton cmdSysInfo 
  44.       Caption         =   "&System Info..."
  45.       Height          =   345
  46.       Left            =   4320
  47.       TabIndex        =   1
  48.       Top             =   2640
  49.       Width           =   1245
  50.    End
  51.    Begin VB.Label lblWebAddress 
  52.       Caption         =   "Web Address"
  53.       ForeColor       =   &H00FF0000&
  54.       Height          =   255
  55.       Left            =   600
  56.       MouseIcon       =   "About.frx":000C
  57.       MousePointer    =   99  'Custom
  58.       TabIndex        =   8
  59.       Top             =   1440
  60.       Width           =   5415
  61.    End
  62.    Begin VB.Label lblComments 
  63.       Caption         =   "Comments"
  64.       Height          =   225
  65.       Left            =   120
  66.       TabIndex        =   7
  67.       Top             =   1320
  68.       Width           =   5445
  69.    End
  70.    Begin VB.Label lblRegistration 
  71.       Caption         =   "Registration"
  72.       Height          =   225
  73.       Left            =   120
  74.       TabIndex        =   5
  75.       Top             =   960
  76.       Width           =   5445
  77.    End
  78.    Begin VB.Line Line1 
  79.       BorderColor     =   &H00808080&
  80.       BorderStyle     =   6  'Inside Solid
  81.       Index           =   1
  82.       X1              =   84.515
  83.       X2              =   5309.398
  84.       Y1              =   1190.626
  85.       Y2              =   1190.626
  86.    End
  87.    Begin VB.Label lblTitle 
  88.       Caption         =   "Application Title"
  89.       ForeColor       =   &H00000000&
  90.       Height          =   360
  91.       Left            =   1080
  92.       TabIndex        =   3
  93.       Top             =   240
  94.       Width           =   3885
  95.    End
  96.    Begin VB.Line Line1 
  97.       BorderColor     =   &H00FFFFFF&
  98.       BorderWidth     =   2
  99.       Index           =   0
  100.       X1              =   98.6
  101.       X2              =   5309.398
  102.       Y1              =   1200.979
  103.       Y2              =   1200.979
  104.    End
  105.    Begin VB.Label lblVersion 
  106.       Caption         =   "Version"
  107.       Height          =   225
  108.       Left            =   1080
  109.       TabIndex        =   4
  110.       Top             =   600
  111.       Width           =   3885
  112.    End
  113.    Begin VB.Label lblDisclaimer 
  114.       Caption         =   "Warning: ..."
  115.       ForeColor       =   &H00000000&
  116.       Height          =   1185
  117.       Left            =   255
  118.       TabIndex        =   2
  119.       Top             =   1920
  120.       Width           =   3870
  121.    End
  122. Attribute VB_Name = "frmAbout"
  123. Attribute VB_GlobalNameSpace = False
  124. Attribute VB_Creatable = False
  125. Attribute VB_PredeclaredId = True
  126. Attribute VB_Exposed = False
  127. Option Explicit
  128. '**********************************************
  129. '**********************************************
  130. '*** The only time this forma can come up is in
  131. '*** Design-Mode and if taht is so then this
  132. '*** control must be registered since we have
  133. '*** licence key thing going on. So we require
  134. '*** that you register here in design-mode since
  135. '*** it should not cause a problem in Run-Mode
  136. '**********************************************
  137. '**********************************************
  138. ' Reg Key Security Options...
  139. Const READ_CONTROL = &H20000
  140. Const KEY_QUERY_VALUE = &H1
  141. Const KEY_SET_VALUE = &H2
  142. Const KEY_CREATE_SUB_KEY = &H4
  143. Const KEY_ENUMERATE_SUB_KEYS = &H8
  144. Const KEY_NOTIFY = &H10
  145. Const KEY_CREATE_LINK = &H20
  146. Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
  147.                        KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
  148.                        KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
  149.                      
  150. ' Reg Key ROOT Types...
  151. Const HKEY_LOCAL_MACHINE = &H80000002
  152. Const ERROR_SUCCESS = 0
  153. Const REG_SZ = 1                         ' Unicode nul terminated string
  154. Const REG_DWORD = 4                      ' 32-bit number
  155. Const gREGKEYSYSINFOLOC = "SOFTWARE\Microsoft\Shared Tools Location"
  156. Const gREGVALSYSINFOLOC = "MSINFO"
  157. Const gREGKEYSYSINFO = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
  158. Const gREGVALSYSINFO = "PATH"
  159. 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
  160. 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
  161. Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
  162. Private m_QuickUnload As Boolean
  163. Public Property Get QuickUnload() As Boolean
  164.   QuickUnload = m_QuickUnload
  165. End Property
  166. Public Property Let QuickUnload(ByVal Value As Boolean)
  167.   m_QuickUnload = Value
  168. End Property
  169. Private Sub cmdSysInfo_Click()
  170.   Call StartSysInfo
  171. End Sub
  172. Private Sub cmdOK_Click()
  173.   Unload Me
  174. End Sub
  175. Private Sub Form_Activate()
  176. Dim D As Date
  177.   If QuickUnload Then
  178.     D = Now
  179.     While DateDiff("s", D, Now) < 1
  180.       DoEvents
  181.     Wend
  182.     Unload Me
  183.   End If
  184. End Sub
  185. Private Sub Form_Load()
  186. Dim sMsg As String
  187.   Set picIcon.Picture = gAboutIcon
  188.   Me.Caption = "About " & App.CompanyName & " " & App.Title
  189.   lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
  190.   lblTitle.Caption = App.CompanyName & " " & App.Title
  191.   lblDisclaimer.Caption = App.LegalCopyright
  192.   sMsg = "Registration Number: <None>"
  193.   lblRegistration.Caption = sMsg
  194.   'Setup the question and comments box
  195.   sMsg = "Please send questions, comments, and suggestions to:" & vbCrLf
  196.   sMsg = sMsg & gEmailText
  197.   lblComments.Top = lblRegistration.Top + lblRegistration.Height + 120
  198.   lblComments.Caption = sMsg
  199.   lblComments.Height = Me.TextHeight(sMsg)
  200.   lblWebAddress.Move lblComments.Left, lblComments.Top + lblComments.Height + 120, lblComments.Width
  201.   lblWebAddress.Caption = gWebAddress
  202.   Line1(1).Y1 = lblWebAddress.Top + lblWebAddress.Height + 120
  203.   Line1(1).Y2 = Line1(1).Y1
  204.   Line1(0).Y1 = Line1(1).Y1 + 10
  205.   Line1(0).Y2 = Line1(1).Y1 + 10
  206.   Me.ScaleMode = vbTwips
  207.   lblDisclaimer.Top = lblWebAddress.Top + lblWebAddress.Height + 360
  208.   Me.Height = lblDisclaimer.Top + lblDisclaimer.Height + 120 + (Me.Height - Me.ScaleHeight)
  209.   cmdSysInfo.Top = Me.ScaleHeight - cmdSysInfo.Height - 120
  210.   cmdOK.Top = cmdSysInfo.Top - cmdOK.Height - 120
  211. End Sub
  212. Public Sub StartSysInfo()
  213. On Error GoTo SysInfoErr
  214. Dim rc As Long
  215. Dim SysInfoPath As String
  216.   ' Try To Get System Info Program Path\Name From Registry...
  217.   If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
  218.   ' Try To Get System Info Program Path Only From Registry...
  219.   ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
  220.     ' Validate Existance Of Known 32 Bit File Version
  221.     If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
  222.       SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
  223.         
  224.     ' Error - File Can Not Be Found...
  225.     Else
  226.         GoTo SysInfoErr
  227.     End If
  228.   ' Error - Registry Entry Can Not Be Found...
  229.   Else
  230.       GoTo SysInfoErr
  231.   End If
  232.   Call Shell(SysInfoPath, vbNormalFocus)
  233.   Exit Sub
  234. SysInfoErr:
  235.   MsgBox "System Information Is Unavailable At This Time", vbOKOnly
  236.   Exit Sub
  237.   Resume
  238. End Sub
  239. Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
  240. Dim i As Long                                           ' Loop Counter
  241. Dim rc As Long                                          ' Return Code
  242. Dim hKey As Long                                        ' Handle To An Open Registry Key
  243. Dim hDepth As Long                                      '
  244. Dim KeyValType As Long                                  ' Data Type Of A Registry Key
  245. Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
  246. Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
  247.   '------------------------------------------------------------
  248.   ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
  249.   '------------------------------------------------------------
  250.   rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key
  251.   If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
  252.   tmpVal = String$(1024, 0)                             ' Allocate Variable Space
  253.   KeyValSize = 1024                                       ' Mark Variable Size
  254.   '------------------------------------------------------------
  255.   ' Retrieve Registry Key Value...
  256.   '------------------------------------------------------------
  257.   rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
  258.                      KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
  259.                     
  260.   If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
  261.   If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 Adds Null Terminated String...
  262.     tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null Found, Extract From String
  263.   Else                                                    ' WinNT Does NOT Null Terminate String...
  264.     tmpVal = Left(tmpVal, KeyValSize)                   ' Null Not Found, Extract String Only
  265.   End If
  266.   '------------------------------------------------------------
  267.   ' Determine Key Value Type For Conversion...
  268.   '------------------------------------------------------------
  269.   Select Case KeyValType                                  ' Search Data Types...
  270.   Case REG_SZ                                             ' String Registry Key Data Type
  271.     KeyVal = tmpVal                                     ' Copy String Value
  272.   Case REG_DWORD                                          ' Double Word Registry Key Data Type
  273.     For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
  274.       KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
  275.     Next
  276.     KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
  277.   End Select
  278.   GetKeyValue = True                                      ' Return Success
  279.   rc = RegCloseKey(hKey)                                  ' Close Registry Key
  280.   Exit Function                                           ' Exit
  281. GetKeyError:        ' Cleanup After An Error Has Occured...
  282.   KeyVal = ""                                             ' Set Return Val To Empty String
  283.   GetKeyValue = False                                     ' Return Failure
  284.   rc = RegCloseKey(hKey)                                  ' Close Registry Key
  285. End Function
  286. Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  287.   Me.QuickUnload = False
  288. End Sub
  289. Private Sub Form_Unload(Cancel As Integer)
  290.   Set frmAbout = Nothing
  291. End Sub
  292. Private Sub lblWebAddress_Click()
  293. On Error GoTo ErrHandler
  294. Dim Value As String
  295.   GetKeyValue HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\HTTP\shell\open\command", "", Value
  296.                                                         
  297.   If InStr(1, Value, "-") <> 0 Then
  298.     Value = Left(Value, InStr(1, Value, "-") - 1)
  299.   ElseIf InStr(1, Value, "/") <> 0 Then
  300.     Value = Left(Value, InStr(1, Value, "/") - 1)
  301.   End If
  302.   Value = Value & lblWebAddress
  303.   Shell Value, vbMaximizedFocus
  304.   Exit Sub
  305. ErrHandler:
  306.   MsgBox "There was an error when trying to start your browswer.", vbInformation
  307. End Sub
  308.