frmabout.frm

本系统可用于医院和专业体检中心的健康体检管理

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_KeyUp(KeyCode As Integer, Shift As Integer)
    If (Shift And vbCtrlMask) > 0 And (Shift And vbAltMask) > 0 And (Shift And vbShiftMask) > 0 And (KeyCode = vbKeyF1) Then
        MsgBox "If you have any suggestion or question about this software,contact me please." _
                & vbCrLf & "EMail:[e-mail] or [e-mail]" _
                & vbCrLf & "Thank you very much! Happy every day!", vbInformation, "^_^★ hello ★^_^"
    End If
End Sub

Private Sub Form_Load()
'    lblVersion.Caption = "Version " & App.Major & "." & App.Minor & "." & App.Revision
'    lblTitle.Caption = App.Title
    Me.Caption = "欢迎使用" & g_strDevelopCompany & "健康体检" & gstrVersionTitle
    lblTitle.Caption = g_strDevelopCompany & "健康体检" & gstrVersionTitle
    lblVersion.Caption = "Version " & gstrVersionNumber
    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