/trunk/TestTest/About.frm

VERSION 5.00

Begin VB.Form frmAbout 

   BorderStyle     =   3  'Fixed Dialog

   Caption         =   "About MyApp"

   ClientHeight    =   3195

   ClientLeft      =   2340

   ClientTop       =   1935

   ClientWidth     =   5730

   ClipControls    =   0   'False

   HelpContextID   =   10

   Icon            =   "About.frx":0000

   LinkTopic       =   "Form2"

   MaxButton       =   0   'False

   MinButton       =   0   'False

   ScaleHeight     =   2205.246

   ScaleMode       =   0  'User

   ScaleWidth      =   5380.766

   ShowInTaskbar   =   0   'False

   StartUpPosition =   2  'CenterScreen

   Tag             =   "lblComments"

   Begin VB.CommandButton cmdOK 

      Cancel          =   -1  'True

      Caption         =   "OK"

      Default         =   -1  'True

      Height          =   345

      Left            =   4320

      TabIndex        =   0

      Top             =   1920

      Width           =   1260

   End

   Begin VB.CommandButton cmdSysInfo 

      Caption         =   "&System Info..."

      Height          =   345

      Left            =   4320

      TabIndex        =   1

      Top             =   2640

      Width           =   1245

   End

   Begin VB.Label lblWebAddress 

      Caption         =   "Web Address"

      ForeColor       =   &H00FF0000&

      Height          =   255

      Left            =   600

      MouseIcon       =   "About.frx":000C

      MousePointer    =   99  'Custom

      TabIndex        =   6

      Top             =   1440

      Width           =   5415

   End

   Begin VB.Label lblComments 

      Caption         =   "Comments"

      Height          =   225

      Left            =   120

      TabIndex        =   7

      Top             =   1320

      Width           =   5445

   End

   Begin VB.Label lblRegistration 

      Caption         =   "Registration"

      Height          =   225

      Left            =   120

      TabIndex        =   5

      Top             =   960

      Width           =   5445

   End

   Begin VB.Line Line1 

      BorderColor     =   &H00808080&

      BorderStyle     =   6  'Inside Solid

      Index           =   1

      X1              =   84.515

      X2              =   5309.398

      Y1              =   1190.626

      Y2              =   1190.626

   End

   Begin VB.Label lblTitle 

      Caption         =   "Application Title"

      ForeColor       =   &H00000000&

      Height          =   360

      Left            =   1080

      TabIndex        =   3

      Top             =   240

      Width           =   3885

   End

   Begin VB.Line Line1 

      BorderColor     =   &H00FFFFFF&

      BorderWidth     =   2

      Index           =   0

      X1              =   98.6

      X2              =   5309.398

      Y1              =   1200.979

      Y2              =   1200.979

   End

   Begin VB.Label lblVersion 

      Caption         =   "Version"

      Height          =   225

      Left            =   1080

      TabIndex        =   4

      Top             =   600

      Width           =   3885

   End

   Begin VB.Label lblDisclaimer 

      Caption         =   "Warning: ..."

      ForeColor       =   &H00000000&

      Height          =   1185

      Left            =   255

      TabIndex        =   2

      Top             =   1920

      Width           =   3870

   End

End

Attribute VB_Name = "frmAbout"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit



'**********************************************

'**********************************************

'*** The only time this forma can come up is in

'*** Design-Mode and if taht is so then this

'*** control must be registered since we have

'*** licence key thing going on. So we require

'*** that you register here in design-mode since

'*** it should not cause a problem in Run-Mode

'**********************************************

'**********************************************





' Reg Key Security Options...

Const READ_CONTROL = &H20000

Const KEY_QUERY_VALUE = &H1

Const KEY_SET_VALUE = &H2

Const KEY_CREATE_SUB_KEY = &H4

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_KEY + 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 terminated string

Const REG_DWORD = 4                      ' 32-bit number



Const gREGKEYSYSINFOLOC = "SOFTWARE\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 m_QuickUnload As Boolean

Public Property Get QuickUnload() As Boolean

  QuickUnload = m_QuickUnload

End Property

Public Property Let QuickUnload(ByVal Value As Boolean)

  m_QuickUnload = Value

End Property

Private Sub cmdSysInfo_Click()

  Call StartSysInfo

End Sub



Private Sub cmdOk_Click()

  Unload Me

End Sub



Private Sub Form_Activate()



Dim D As Date



  If QuickUnload Then

    D = Now

    While DateDiff("s", D, Now) < 1

      DoEvents

    Wend

    Unload Me

  End If



End Sub



Private Sub Form_Load()

  

Dim sMsg As String

  

  'Set picIcon.Picture = gAboutIcon

  

  Me.Caption = "About " & App.CompanyName & " " & App.Title

  lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision

  lblTitle.Caption = App.CompanyName & " " & App.Title

  lblDisclaimer.Caption = App.LegalCopyright

  sMsg = "Registration Number: <None>"

  lblRegistration.Caption = sMsg

  

  'Setup the question and comments box

  sMsg = "Please send questions, comments, and suggestions to:" & vbCrLf

  sMsg = sMsg & gEmailText

  lblComments.Top = lblRegistration.Top + lblRegistration.Height + 120

  lblComments.Caption = sMsg

  lblComments.Height = Me.TextHeight(sMsg)

  

  lblWebAddress.Move lblComments.Left, lblComments.Top + lblComments.Height + 120, lblComments.Width

  lblWebAddress.Caption = gWebAddress

  

  Line1(1).Y1 = lblWebAddress.Top + lblWebAddress.Height + 120

  Line1(1).Y2 = Line1(1).Y1

  Line1(0).Y1 = Line1(1).Y1 + 10

  Line1(0).Y2 = Line1(1).Y1 + 10

  

  Me.ScaleMode = vbTwips

  lblDisclaimer.Top = lblWebAddress.Top + lblWebAddress.Height + 360

  Me.Height = lblDisclaimer.Top + lblDisclaimer.Height + 120 + (Me.Height - Me.ScaleHeight)

  cmdSysInfo.Top = Me.ScaleHeight - cmdSysInfo.Height - 120

  cmdOK.Top = cmdSysInfo.Top - cmdOK.Height - 120



End Sub

Public Sub StartSysInfo()

    

On Error GoTo SysInfoErr



Dim rc As Long

Dim SysInfoPath As String

  

  ' Try To Get System Info Program Path\Name From Registry...

  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 Information Is Unavailable At This Time", vbOKOnly

  Exit Sub

  Resume

    

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                                        ' Handle To An Open Registry Key

Dim hDepth As Long                                      '

Dim KeyValType As Long                                  ' Data Type Of A Registry Key

Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value

Dim KeyValSize As Long                                  ' Size Of Registry Key Variable

    

  '------------------------------------------------------------

  ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}

  '------------------------------------------------------------

  rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Open Registry Key

  

  If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...

  

  tmpVal = String$(1024, 0)                             ' Allocate Variable Space

  KeyValSize = 1024                                       ' Mark Variable Size

  

  '------------------------------------------------------------

  ' Retrieve Registry Key Value...

  '------------------------------------------------------------

  rc = RegQueryValueEx(hKey, SubKeyRef, 0, _

                     KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value

                    

  If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors

  

  If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 Adds Null Terminated String...

    tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null Found, Extract From String

  Else                                                    ' WinNT Does NOT Null Terminate String...

    tmpVal = Left(tmpVal, KeyValSize)                   ' Null Not Found, Extract String Only

  End If

  '------------------------------------------------------------

  ' Determine Key Value Type For Conversion...

  '------------------------------------------------------------

  Select Case KeyValType                                  ' Search Data Types...

  Case REG_SZ                                             ' String Registry Key Data Type

    KeyVal = tmpVal                                     ' Copy String Value

  Case REG_DWORD                                          ' Double Word Registry Key Data Type

    For i = Len(tmpVal) To 1 Step -1                    ' Convert 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                                      ' Return Success

  rc = RegCloseKey(hKey)                                  ' Close Registry Key

  Exit Function                                           ' Exit

  

GetKeyError:        ' Cleanup After An Error Has Occured...

  KeyVal = ""                                             ' Set Return Val To Empty String

  GetKeyValue = False                                     ' Return Failure

  rc = RegCloseKey(hKey)                                  ' Close Registry Key



End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

  Me.QuickUnload = False

End Sub

Private Sub Form_Unload(Cancel As Integer)

  Set frmAbout = Nothing

End Sub

Private Sub lblWebAddress_Click()



On Error GoTo ErrHandler



Dim Value As String



  GetKeyValue HKEY_LOCAL_MACHINE, "SOFTWARE\Classes\HTTP\shell\open\command", "", Value

                                                        

  If InStr(1, Value, "-") <> 0 Then

    Value = Left(Value, InStr(1, Value, "-") - 1)

  ElseIf InStr(1, Value, "/") <> 0 Then

    Value = Left(Value, InStr(1, Value, "/") - 1)

  End If

  Value = Value & lblWebAddress

  Shell Value, vbMaximizedFocus

  Exit Sub

  

ErrHandler:

  MsgBox "There was an error when trying to start your browswer.", vbInformation



End Sub