📄 frmpjb_about.frm
字号:
VERSION 5.00
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form FrmPJB_About
BackColor = &H00FFC0C0&
BorderStyle = 1 'Fixed Single
Caption = "关于"
ClientHeight = 3660
ClientLeft = 45
ClientTop = 330
ClientWidth = 5655
Icon = "FrmPJB_About.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3660
ScaleWidth = 5655
StartUpPosition = 2 'CenterScreen
Begin VB.TextBox txtEMail
BackColor = &H00FF8080&
BorderStyle = 0 'None
Height = 225
Left = 1995
Locked = -1 'True
MouseIcon = "FrmPJB_About.frx":0CCA
MousePointer = 99 'Custom
TabIndex = 1
Text = "bingtai@bingtai.com.cn"
Top = 2100
Width = 1845
End
Begin VB.TextBox txtURL
BackColor = &H00FF8080&
BorderStyle = 0 'None
Height = 225
Left = 1995
Locked = -1 'True
MouseIcon = "FrmPJB_About.frx":0E1C
MousePointer = 99 'Custom
TabIndex = 0
Text = "http://www.bingtai.com.cn"
Top = 1740
Width = 2655
End
Begin XPControls.XPCommandButton CmdOK
Height = 375
Left = 4155
TabIndex = 2
Top = 2640
Width = 1335
_ExtentX = 2355
_ExtentY = 661
Caption = "确定"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin XPControls.XPCommandButton CmdSysInfo
Height = 375
Left = 4155
TabIndex = 3
Top = 3120
Width = 1335
_ExtentX = 2355
_ExtentY = 661
Caption = "系统信息"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Image Image1
Height = 480
Left = 225
Picture = "FrmPJB_About.frx":0F6E
Top = 780
Width = 480
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "EMail："
Height = 195
Left = 1125
TabIndex = 9
Top = 2115
Width = 570
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "或登录："
Height = 195
Left = 1125
TabIndex = 8
Top = 1770
Width = 720
End
Begin VB.Label lblTitle
BackColor = &H00FFC0C0&
BackStyle = 0 'Transparent
Caption = "秉泰健康体检普及版"
BeginProperty Font
Name = "宋体"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 480
Left = 1110
TabIndex = 7
Tag = "Application Title"
Top = 240
Width = 3405
End
Begin VB.Line Line1
BorderColor = &H00FF0000&
BorderStyle = 6 'Inside Solid
Index = 1
X1 = 60
X2 = 5492
Y1 = 2430
Y2 = 2430
End
Begin VB.Line Line1
BorderColor = &H00FFFFFF&
BorderWidth = 2
Index = 0
X1 = 60
X2 = 5477
Y1 = 150
Y2 = 150
End
Begin VB.Label lblVersion
BackColor = &H00FFC0C0&
BackStyle = 0 'Transparent
Caption = "Version 3.3.0"
Height = 225
Left = 1125
TabIndex = 6
Tag = "Version"
Top = 780
Width = 4095
End
Begin VB.Label lblDisclaimer
BackColor = &H00FFC0C0&
BackStyle = 0 'Transparent
Caption = "警告： 禁止对本软件作包括反向工程在内的任何更改！对于侵犯版权的个人或团体，秉泰公司将在法律许可范围内进行最大程度的起诉！"
ForeColor = &H00000000&
Height = 825
Left = 90
TabIndex = 5
Tag = "Warning: ..."
Top = 2625
Width = 3870
End
Begin VB.Label lblDescription
BackColor = &H00FFC0C0&
BackStyle = 0 'Transparent
Caption = "本软件由秉泰软件科技有限公司开发，如果你对本软件有任何建议或疑问，请致电： (010)65079919，86005709，81915562"
ForeColor = &H00000000&
Height = 570
Left = 1110
TabIndex = 4
Tag = "App Description"
Top = 1080
Width = 4095
End
End
Attribute VB_Name = "FrmPJB_About"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Reg Key Security Options...
Const KEY_ALL_ACCESS = &H2003F
' 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 Sub Form_Load()
' lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
' lblTitle.Caption = App.Title
txtURL.Width = frmAbout.TextWidth(txtURL.Text) + 50
txtEMail.Width = frmAbout.TextWidth(txtEMail.Text) + 50
End Sub
Private Sub cmdSysInfo_Click()
Call StartSysInfo
End Sub
Private Sub cmdOK_Click()
Unload Me
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", vbInformation, "提示"
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
tmpVal = VBA.Left(tmpVal, InStr(tmpVal, VBA.Chr(0)) - 1)
'------------------------------------------------------------
' 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_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ClearEffect
End Sub
Private Sub lblDescription_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ClearEffect
End Sub
Private Sub lblDisclaimer_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ClearEffect
End Sub
Private Sub lblTitle_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ClearEffect
End Sub
Private Sub lblVersion_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
ClearEffect
End Sub
Private Sub txtEMail_Click()
ShellExecute Me.hWnd, "open", "mailto:" & txtEMail.Text, vbNullString, vbNullString, SW_SHOW
End Sub
Private Sub txtEMail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
txtEMail.BackColor = &H80000018
txtEMail.FontUnderline = True
txtEMail.FontBold = True
txtEMail.Width = frmAbout.TextWidth(txtEMail.Text) * 1.18 + 50
txtURL.BackColor = txtURL.Container.BackColor
txtURL.FontUnderline = False
txtURL.FontBold = False
txtURL.Width = frmAbout.TextWidth(txtURL.Text) + 50
End Sub
Private Sub txtURL_Click()
ShellExecute Me.hWnd, "open", txtURL.Text, vbNullString, vbNullString, SW_SHOW
End Sub
Private Sub txtURL_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
txtEMail.BackColor = txtEMail.Container.BackColor
txtEMail.FontUnderline = False
txtEMail.FontBold = False
txtEMail.Width = frmAbout.TextWidth(txtEMail.Text) + 50
txtURL.BackColor = &H80000018
txtURL.FontUnderline = True
txtURL.FontBold = True
txtURL.Width = frmAbout.TextWidth(txtURL.Text) * 1.18 + 50
End Sub
'清除文本框的特效
Private Sub ClearEffect()
txtEMail.BackColor = txtEMail.Container.BackColor
txtEMail.FontUnderline = False
txtEMail.FontBold = False
txtEMail.Width = frmAbout.TextWidth(txtEMail.Text) + 50
txtURL.BackColor = txtURL.Container.BackColor
txtURL.FontUnderline = False
txtURL.FontBold = False
txtURL.Width = frmAbout.TextWidth(txtURL.Text) + 50
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -