frmAbout.frm

 VERSION 5.00
Begin VB.Form frmAbout
   BorderStyle     =   3  'Fixed Dialog
   ClientHeight    =   4305
   ClientLeft      =   3060
   ClientTop       =   1845
   ClientWidth     =   5400
   ClipControls    =   0   'False
   Icon            =   "frmAbout.frx":0000
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2971.387
   ScaleMode       =   0  'User
   ScaleWidth      =   5070.879
   Begin VB.Frame Frame1
      Caption         =   "Special thanks"
      Height          =   1965
      Left            =   300
      TabIndex        =   6
      Top             =   1275
      Width           =   4815
      Begin VB.Label lblVBnetWeb
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "www.mvps.org/vbnet/index.html"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FF0000&
         Height          =   195
         Left            =   1050
         MouseIcon       =   "frmAbout.frx":030A
         TabIndex        =   12
         Tag             =   "http://www.mvps.org/vbnet/index.html"
         Top             =   1500
         Width           =   2310
      End
      Begin VB.Label lblMsg
         BackStyle       =   0  'Transparent
         Caption         =   "Randy Birch at VBnet web site.  Great code snippets."
         Height          =   315
         Index           =   5
         Left            =   375
         TabIndex        =   11
         Top             =   1275
         Width           =   4140
      End
      Begin VB.Label lblVBZipWeb
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "www.richsoftcomputing.btinternet.co.uk"
         BeginProperty Font
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   -1  'True
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FF0000&
         Height          =   195
         Left            =   1050
         MouseIcon       =   "frmAbout.frx":045C
         TabIndex        =   8
         Tag             =   "http://www.richsoftcomputing.btinternet.co.uk"
         Top             =   825
         Width           =   2805
      End
      Begin VB.Label lblMsg
         BackStyle       =   0  'Transparent
         Caption         =   "Richard Southey of RichSoft Computing for the freeware VBZip_Control.ocx"
         Height          =   465
         Index           =   1
         Left            =   375
         TabIndex        =   7
         Top             =   375
         Width           =   4515
      End
   End
   Begin VB.CommandButton cmdChoice
      Height          =   690
      Index           =   0
      Left            =   3600
      Picture         =   "frmAbout.frx":05AE
      Style           =   1  'Graphical
      TabIndex        =   4
      ToolTipText     =   "System Information"
      Top             =   3450
      Width           =   690
   End
   Begin VB.CommandButton cmdChoice
      Height          =   690
      Index           =   1
      Left            =   4425
      Picture         =   "frmAbout.frx":09F0
      Style           =   1  'Graphical
      TabIndex        =   3
      ToolTipText     =   "Return to main screen"
      Top             =   3450
      Width           =   690
   End
   Begin VB.PictureBox Picture1
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Index           =   0
      Left            =   300
      Picture         =   "frmAbout.frx":0CFA
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   1
      Top             =   150
      Width           =   480
   End
   Begin VB.PictureBox Picture1
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   480
      Index           =   1
      Left            =   4650
      Picture         =   "frmAbout.frx":1004
      ScaleHeight     =   480
      ScaleWidth      =   480
      TabIndex        =   0
      Top             =   150
      Width           =   480
   End
   Begin VB.Label lblMsg
      BackStyle       =   0  'Transparent
      Caption         =   "MyStuff"
      Height          =   540
      Index           =   4
      Left            =   300
      TabIndex        =   10
      Top             =   3675
      Width           =   2115
   End
   Begin VB.Label lblMyEmail
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "kenaso@home.com"
      BeginProperty Font
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   -1  'True
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   195
      Left            =   2100
      TabIndex        =   9
      Tag             =   "mailto:kenaso@home.com?subject=ZipDater 1.0"
      Top             =   975
      Width           =   1425
   End
   Begin VB.Label lblMsg
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Freeware by Kenneth Ives"
      Height          =   195
      Index           =   0
      Left            =   1875
      TabIndex        =   5
      Top             =   750
      Width           =   1860
   End
   Begin VB.Label lblTitle
      Alignment       =   2  'Center
      BackStyle       =   0  'Transparent
      BeginProperty Font
         Name            =   "Times New Roman"
         Size            =   27.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   690
      Left            =   300
      TabIndex        =   2
      Top             =   75
      Width           =   4815
   End
End
Attribute VB_Name = "frmAbout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' ---------------------------------------------------------------------------
' Reg Key Security Options...
' ---------------------------------------------------------------------------
Private Const MAX_BUFFER              As Long = 1024
Private Const READ_CONTROL            As Long = &H20000
Private Const KEY_QUERY_VALUE         As Long = &H1
Private Const KEY_SET_VALUE           As Long = &H2
Private Const KEY_CREATE_SUB_KEY      As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS  As Long = &H8
Private Const KEY_NOTIFY              As Long = &H10
Private Const KEY_CREATE_LINK         As Long = &H20
Private Const KEY_ALL_ACCESS          As Long = KEY_QUERY_VALUE Or _
                                                KEY_SET_VALUE Or _
                                                KEY_CREATE_SUB_KEY Or _
                                                KEY_ENUMERATE_SUB_KEYS Or _
                                                KEY_NOTIFY Or _
                                                KEY_CREATE_LINK Or _
                                                READ_CONTROL
                    
' ---------------------------------------------------------------------------
' Reg Key ROOT Types...
' ---------------------------------------------------------------------------
Private Const HKEY_LOCAL_MACHINE       As Long = &H80000002
Private Const ERROR_SUCCESS            As Long = 0
Private Const REG_SZ                   As Long = 1   ' Unicode nul terminated string
Private Const REG_DWORD                As Long = 4   ' 32-bit number

Private Const gREGKEYSYSINFOLOC        As String = "SOFTWARE\Microsoft\Shared Tools Location"
Private Const gREGVALSYSINFOLOC        As String = "MSINFO"
Private Const gREGKEYSYSINFO           As String = "SOFTWARE\Microsoft\Shared Tools\MSINFO"
Private Const gREGVALSYSINFO           As String = "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
       
' ---------------------------------------------------------------------------
' API Call which drives the Hyperlink
' ---------------------------------------------------------------------------
Private Declare Function ShellExecute Lib "shell32.dll" _
        Alias "ShellExecuteA" (ByVal hwnd As Long, _
        ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long

Public Sub HyperJump(ByVal URL As String)

' Function to execute the Hyperlink
    Call ShellExecute(0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus)

End Sub

Private Sub lblMyEmail_Click()

' ---------------------------------------------------------------------------
' Send an email to Kenaso
' ---------------------------------------------------------------------------
  HyperJump lblMyEmail.Tag
 
End Sub

Private Sub lblVBnetWeb_Click()

' ---------------------------------------------------------------------------
' Go to VBnet website
' ---------------------------------------------------------------------------
  HyperJump lblVBnetWeb.Tag
 
End Sub

Private Sub lblVBZipWeb_Click()

' ---------------------------------------------------------------------------
' Go to VBZip website
' ---------------------------------------------------------------------------
  HyperJump lblVBZipWeb.Tag
 
End Sub

Private Sub cmdChoice_Click(Index As Integer)

  Select Case Index
          
         Case 0  ' System information
              Call StartSysInfo

         Case 1  ' return to main form
              frmMain.Show
              frmAbout.Hide
  End Select
 
End Sub

Private Sub Form_Initialize()

' ---------------------------------------------------------------------------
' Center form on the screen.  I use this statement here because of a bug in
' the Form property "Startup Position".  In the VB IDE, under
' Tools\Options\Advanced, when you place a checkmark in the SDI Development
' Environment check box and set the form property to startup in the center
' of the screen, it works while in the IDE.  Whenever you leave the IDE, the
' property reverts back to the default [0-Manual].  This is a known bug with
' Microsoft.
' ---------------------------------------------------------------------------
  Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2

End Sub

Private Sub Form_Load()
 
' ---------------------------------------------------------------------------
' Hide this form
' ---------------------------------------------------------------------------
  With frmAbout
       .Caption = "About " & g_strVersion
       .lblTitle = g_strVersion
       .lblMsg(4) = App.FileDescription & vbCrLf & _
                    "Rel.  " & App.Major & "." & App.Minor
       .Hide
  End With

End Sub

Public Sub StartSysInfo()

  On Error GoTo StartSysInfo_Error
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim lngRetCode      As Long
  Dim strSysInfoPath  As String
   
' ---------------------------------------------------------------------------
' Try To Get System Info Program Path\Name From Registry...
' ---------------------------------------------------------------------------
  If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, strSysInfoPath) Then
      ' fall thru and make the API call
       
  ' Try To Get System Info Program Path Only From Registry...
  ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, strSysInfoPath) Then
       
      ' Validate Existance Of Known 32 Bit File Version
      If (Dir(strSysInfoPath & "\MSINFO32.EXE") <> "") Then
          strSysInfoPath = strSysInfoPath & "\MSINFO32.EXE"
      Else
          ' Error - File Can Not Be Found...
          GoTo StartSysInfo_Error
      End If
       
  ' Error - Registry Entry Can Not Be Found...
  Else
      GoTo StartSysInfo_Error
  End If
   
' ---------------------------------------------------------------------------
' Make the API call to show the System information screen
' ---------------------------------------------------------------------------
  Call Shell(strSysInfoPath, vbNormalFocus)
  Exit Sub
   
' ---------------------------------------------------------------------------
' An Error Has Occured
' ---------------------------------------------------------------------------
StartSysInfo_Error:
  MsgBox "System Information Is Unavailable At This Time", vbOKOnly
   
End Sub

Public Function GetKeyValue(lngKeyRoot As Long, _
                            strKeyName As String, _
                            strSubKeyRef As String, _
                            ByRef strKeyValue As String) As Boolean
   
  On Error GoTo GetKeyValue_Error
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim hKey          As Long        ' Handle To An Open Registry Key
  Dim lngIndex      As Long        ' Loop Counter
  Dim lngRetCode    As Long        ' Return Code
  Dim lngKeyType    As Long        ' Data Type Of A Registry Key
  Dim lngKeyLength  As Long        ' Size Of Registry Key Variable
  Dim strTmpValue   As String      ' Temporary Storage For A Registry Key Value
   
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strTmpValue = String$(MAX_BUFFER, 0)    ' Preload return buffer area with spaces
  lngKeyLength = MAX_BUFFER               ' Adjust length of the key
   
' ---------------------------------------------------------------------------
' Open RegKey Under lngKeyRoot {HKEY_LOCAL_MACHINE}
' ---------------------------------------------------------------------------
  lngRetCode = RegOpenKeyEx(lngKeyRoot, strKeyName, 0, KEY_ALL_ACCESS, hKey)
 
  If (lngRetCode <> ERROR_SUCCESS) Then
      GoTo GetKeyValue_Error
  End If
   
' ---------------------------------------------------------------------------
' Retrieve Registry Key Value...
' ---------------------------------------------------------------------------
  lngRetCode = RegQueryValueEx(hKey, strSubKeyRef, 0, _
                               lngKeyType, strTmpValue, lngKeyLength)
                       
  If (lngRetCode <> ERROR_SUCCESS) Then
      GoTo GetKeyValue_Error
  End If
   
' ---------------------------------------------------------------------------
' remove all trailing null values
' ---------------------------------------------------------------------------
  strTmpValue = Remove_Nulls(strTmpValue)
   
' ---------------------------------------------------------------------------
' Determine Key Value Type For Conversion...
' ---------------------------------------------------------------------------
  Select Case lngKeyType
 
         Case REG_SZ       ' String Registry Key Data Type
              strKeyValue = strTmpValue   ' Save the String Value
             
         Case REG_DWORD    ' Double Word Registry Key Data Type
              ' Convert to a string
              For lngIndex = Len(strTmpValue) To 1 Step -1
                  ' Build Value Char By Char
                  strKeyValue = strKeyValue & Hex(Asc(Mid$(strTmpValue, lngIndex, 1)))
              Next
       
              strKeyValue = Format$("&h" & strKeyValue)  ' Convert Double Word To String
  End Select
   
  GetKeyValue = True                     ' Return Success
 
Normal_Exit:
  lngRetCode = RegCloseKey(hKey)         ' Close Registry Key
  Exit Function
   
' ---------------------------------------------------------------------------
' An Error Has Occured
' ---------------------------------------------------------------------------
GetKeyValue_Error:
  strKeyValue = ""                       ' Set Return Val To Empty String
  GetKeyValue = False                    ' Return Failure
  GoTo Normal_Exit

End Function

Private Function Remove_Nulls(strInput As String) As String
   
' ***************************************************************************
' Routine:       Remove_Nulls
'
' Description:   Receives a data string and looks for the first null.  If
'                found, the string is truncated at that point and returned.
'
' Parameters:    strInput - Input string to be inspected
'
' Returns:       Data string with the trailing nulls
'
' ===========================================================================
'    DATE      NAME / DESCRIPTION
' -----------  --------------------------------------------------------------
' 23-FEB-2000  Kenneth Ives  kenaso@home.com
'              Routine created
' ***************************************************************************

' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intPosition As Integer
   
' ---------------------------------------------------------------------------
' Look for first null in the data string
' ---------------------------------------------------------------------------
  intPosition = InStr(1, strInput, Chr$(0))
 
' ---------------------------------------------------------------------------
' if we found one, then save all the data up to that position
' ---------------------------------------------------------------------------
  If intPosition Then
      Remove_Nulls = Left$(strInput, intPosition - 1)
  Else
      Remove_Nulls = strInput     ' no nulls found
  End If
     
End Function

Project Homepage: