frmabout.frm

就是定时刷新

         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000C0&
      Height          =   372
      Left            =   432
      TabIndex        =   2
      Top             =   3264
      Width           =   2640
   End
End
Attribute VB_Name = "frmAbout"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Option Explicit

' 注册键安全选项...
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
                     
' 注册键 ROOT 类型...
Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode 以 Null 结尾的字符串
Const REG_DWORD = 4                      ' 32-位数字

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 Sub cmdSysInfo_Click()
  Call StartSysInfo
End Sub

Private Sub cmdOK_Click()
  Unload frmAbout
End Sub

Public Sub StartSysInfo()
    On Error GoTo SysInfoErr
  
    Dim rc As Long
    Dim SysInfoPath As String
    
    ' 试图从注册表得到系统信息程序路径\名称...
    If GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFO, gREGVALSYSINFO, SysInfoPath) Then
    ' 试图从注册表得到系统信息程序路径...
    ElseIf GetKeyValue(HKEY_LOCAL_MACHINE, gREGKEYSYSINFOLOC, gREGVALSYSINFOLOC, SysInfoPath) Then
        ' 验证已知 32 位文件版本的存在
        If (Dir(SysInfoPath & "\MSINFO32.EXE") <> "") Then
            SysInfoPath = SysInfoPath & "\MSINFO32.EXE"
            
        ' 错误 - 文件未找到...
        Else
            GoTo SysInfoErr
        End If
    ' 错误 - 注册项未找到...
    Else
        GoTo SysInfoErr
    End If
    
    Call Shell(SysInfoPath, vbNormalFocus)
    
    Exit Sub
SysInfoErr:
    MsgBox "此时系统信息无效", vbOKOnly
End Sub

Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
    Dim I As Long                                           ' 循环指针
    Dim rc As Long                                          ' 返回代码
    Dim hKey As Long                                        ' 打开的注册键的句柄
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' 注册键的数据类型
    Dim tmpVal As String                                    ' 注册键的临时存储区
    Dim KeyValSize As Long                                  ' 注册键变量的大小
    '------------------------------------------------------------
    ' 在根键 {HKEY_LOCAL_MACHINE...} 下打开注册键
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册键
    
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 句柄错误...
    
    tmpVal = String$(1024, 0)                             ' 分配变量空间
    KeyValSize = 1024                                       ' 标记变量大小
    
    '------------------------------------------------------------
    ' 检索注册键值...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
                         KeyValType, tmpVal, KeyValSize)    ' 获得/创建键值
                        
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 句柄错误
    
    If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 添加以 Null 结尾的字符串...
        tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null 找到，从字符串提取
    Else                                                    ' WinNT 不需要以 Null 结束字符串...
        tmpVal = Left(tmpVal, KeyValSize)                   ' Null 未找到， 仅提取字符串
    End If
    '------------------------------------------------------------
    ' 为了转换而决定键值类型..
    '------------------------------------------------------------
    Select Case KeyValType                                  ' 搜索数据类型...
    Case REG_SZ                                             ' 字符串型注册键数据类型
        KeyVal = tmpVal                                     ' 复制字符串值
    Case REG_DWORD                                          ' 双字型注册键数据类型
        For I = Len(tmpVal) To 1 Step -1                    ' 转换每一位
            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, I, 1)))   ' 一个字符一个字符地建立值
        Next
        KeyVal = Format$("&h" + KeyVal)                     ' 转换双字型为字符串型
    End Select
    
    GetKeyValue = True                                      ' 返回成功
    rc = RegCloseKey(hKey)                                  ' 关闭注册键
    Exit Function                                           ' 退出
    
GetKeyError:      ' 发生错误后清除...
    KeyVal = ""                                             ' 设置返回值为空字符串
    GetKeyValue = False                                     ' 返回失败
    rc = RegCloseKey(hKey)                                  ' 关闭注册键
End Function

Private Sub Form_Load()
    Me.Show
    Me.Picture2.FontName = "隶书"
    Me.Picture2.FontSize = 13
    TeShuFont Me.Picture2, "网站作弊器", "D", 70, 10, 4
    Me.Picture2.FontName = "宋体"
    Me.Picture2.FontSize = 8
    TeShuFont Me.Picture2, "谢谢使用，不得修改", "F", 10, 320, 3
    Image1.Visible = True
  '-------------------------
    Label3.Top = Picture1.ScaleHeight
    Label4.Top = Picture1.ScaleHeight + Label3.Height + 30
    hh0$ = Chr$(13) + Chr$(10)
    SM$ = "网站作弊器1.0" + hh0$
    SM$ = SM$ + "" + hh0$
    SM$ = SM$ + "程序编制：杨海军" + hh0$
    SM$ = SM$ + "" + hh0$
    SM$ = SM$ + "界面设计：杨海军" + hh0$
    Label3.Caption = SM$
    SM$ = "         网站作弊器1.0公告" + hh0$
    SM$ = SM$ + "" + hh0$
    SM$ = SM$ + "     网站作弊器1.0属免费软件。作者自" + hh0$
    SM$ = SM$ + "学VB一年有余，深知编程之苦、之乐，有" + hh0$
    SM$ = SM$ + "时为某一功能的实现要花费许多时间，概" + hh0$
    SM$ = SM$ + "因周围无可交流人员。为使后学者在某些" + hh0$
    SM$ = SM$ + "方面少走弯路，特制作此软件，并公布源" + hh0$
    SM$ = SM$ + "程序，您可以免费传播、使用。欢迎到我" + hh0$
    SM$ = SM$ + "主页：cehome.yeah.net访问并下载。同" + hh0$
    SM$ = SM$ + "时也希望更多的程序员公布自己的源代码，" + hh0$
    SM$ = SM$ + "促进中国软件事业的发展。若您有疑问，" + hh0$
    SM$ = SM$ + "可写信至：" + hh0$
    SM$ = SM$ + "电力部北京勘测设计研究院勘测科研分院" + hh0$
    SM$ = SM$ + "       杨海军 收" + hh0$
    SM$ = SM$ + "邮编：100024" + hh0$
    SM$ = SM$ + "E-mail:[e-mail]" + hh0$
    SM$ = SM$ + "     " + hh0$
    SM$ = SM$ + "              海军最后修改于99年12月" + hh0$
    Label4.Caption = SM$
End Sub

Private Sub Label1_Click()
 ShellExecute 0&, vbNullString, "MailTo:[e-mail]", vbNullString, vbNullString, vbNormalFocus
End Sub

Private Sub Label2_Click()
  ShellExecute 0&, vbNullString, "Http:\\cehome.yeah.net", vbNullString, vbNullString, vbNormalFocus
End Sub

Private Sub Timer1_Timer()
 iStep = 20
 Label3.Top = Label3.Top - iStep
 Label4.Top = Label4.Top - iStep
 If Label4.Top + Label4.Height < Picture1.Top + Picture1.Height Then
    Label3.Top = Picture1.ScaleHeight
   If Label4.Top + Label4.Height < 20 Then
    Label4.Top = Picture1.ScaleHeight + Label3.Height + 30
   End If
 End If
End Sub