home *** CD-ROM | disk | FTP | other *** search
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.PictureBox picIcon AutoSize = -1 'True ClipControls = 0 'False Height = 540 Left = 240 ScaleHeight = 337.12 ScaleMode = 0 'User ScaleWidth = 337.12 TabIndex = 6 Top = 240 Width = 540 End 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 = 8 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 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 
(.txt)