frmlogin.frm

用vb做的防vista的登录界面

      BCOLO           =   14933984
      FCOL            =   65280
      FCOLO           =   0
      MCOL            =   12632256
      MPTR            =   1
      MICON           =   "frmLogin.frx":9593
      PICN            =   "frmLogin.frx":95AF
      PICH            =   "frmLogin.frx":9A4F
      UMCOL           =   -1  'True
      SOFT            =   0   'False
      PICPOS          =   1
      NGREY           =   0   'False
      FX              =   0
      HAND            =   0   'False
      CHECK           =   0   'False
      VALUE           =   0   'False
   End
   Begin VB.Image Image3 
      Height          =   330
      Left            =   120
      Picture         =   "frmLogin.frx":9F63
      Stretch         =   -1  'True
      Top             =   45
      Width           =   1455
   End
   Begin VB.Image Image2 
      Height          =   1455
      Left            =   480
      Picture         =   "frmLogin.frx":33EB9
      Stretch         =   -1  'True
      Top             =   1850
      Width           =   2025
   End
   Begin VB.Label barraprogreso 
      BackColor       =   &H0000FF00&
      Caption         =   "                                   加载中"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00000000&
      Height          =   60
      Left            =   80
      TabIndex        =   14
      Top             =   3360
      Width           =   15
   End
   Begin VB.Line Line2 
      BorderColor     =   &H0000FF00&
      BorderWidth     =   3
      X1              =   4440
      X2              =   4440
      Y1              =   2280
      Y2              =   2520
   End
   Begin VB.Label lblbaraloding 
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      Caption         =   "分析基本日期..."
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C0FFC0&
      Height          =   180
      Left            =   360
      TabIndex        =   13
      Top             =   3510
      Width           =   1350
   End
   Begin VB.Label cmdNuevoUsuario 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      Caption         =   "新建用户"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   4800
      MouseIcon       =   "frmLogin.frx":35134
      MousePointer    =   99  'Custom
      TabIndex        =   12
      Top             =   2280
      Width           =   735
   End
   Begin VB.Label cmdhideNew 
      Alignment       =   2  'Center
      AutoSize        =   -1  'True
      BackColor       =   &H00000000&
      Caption         =   "取消新建"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   180
      Left            =   3360
      MouseIcon       =   "frmLogin.frx":3543E
      MousePointer    =   99  'Custom
      TabIndex        =   11
      Top             =   2280
      Width           =   735
   End
   Begin VB.Image Image1 
      Height          =   3735
      Left            =   0
      Picture         =   "frmLogin.frx":35748
      Stretch         =   -1  'True
      Top             =   0
      Width           =   6615
   End
End
Attribute VB_Name = "frmlogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Download by http://www.codefans.net
      ' Declare Type for API call:
      Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128   '  Maintenance string for PSS usage
      End Type

      ' API declarations:
      Private Declare Function GetVersionEx Lib "kernel32" _
         Alias "GetVersionExA" _
         (lpVersionInformation As OSVERSIONINFO) As Long

      Private Declare Sub keybd_event Lib "user32" _
         (ByVal bVk As Byte, _
          ByVal bScan As Byte, _
          ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

      Private Declare Function GetKeyboardState Lib "user32" _
         (pbKeyState As Byte) As Long

      Private Declare Function SetKeyboardState Lib "user32" _
         (lppbKeyState As Byte) As Long

      ' Constant declarations:
      Const VK_NUMLOCK = &H90
      Const VK_SCROLL = &H91
      Const VK_CAPITAL = &H14
      Const KEYEVENTF_EXTENDEDKEY = &H1
      Const KEYEVENTF_KEYUP = &H2
      Const VER_PLATFORM_WIN32_NT = 2
      Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Sub CapsLock()
 Dim o As OSVERSIONINFO
        Dim NumLockState As Boolean
        Dim ScrollLockState As Boolean
        Dim CapsLockState As Boolean

        o.dwOSVersionInfoSize = Len(o)
        GetVersionEx o
        Dim keys(0 To 255) As Byte
        GetKeyboardState keys(0)

  

        ' CapsLock handling:
        CapsLockState = keys(VK_CAPITAL)
        If CapsLockState <> True Then    'Turn capslock on
          If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then  '===== Win95
            keys(VK_CAPITAL) = 1
            SetKeyboardState keys(0)
          ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then   '===== WinNT
          'Simulate Key Press
            keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
          'Simulate Key Release
            keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY _
               Or KEYEVENTF_KEYUP, 0
          End If
        End If
   
  
End Sub


Private Sub cmdenter2_Click()

End Sub


Private Sub cmdExit_Click(Index As Integer)
If MsgBox("确认想现在退出本程序?", vbQuestion + vbYesNo, "退出 ?") = vbYes Then
End
Unload Me
End If
End Sub

Private Sub cmdhideNew_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdhideNew.FontBold = True
cmdhideNew.ForeColor = &HFF0000

End Sub

Private Sub CmdMin_Click()
Me.WindowState = 1
End Sub

Private Sub cmdNuevoUsuario_Click()
On Error Resume Next


lblconfpass.Visible = True
txtConfirmPass.Visible = True
CmdGuardar.Visible = True
cmdhideNew.Visible = True
txtbuscaruser.Visible = False
txtbuscarpass.Visible = False
txtAdminpass.Visible = True
lbladminpass.Visible = True

txtUser.Enabled = False
txtpass.Enabled = False
txtConfirmPass.Enabled = False
txtAdminpass.SetFocus
End Sub

Private Sub cmdhideNew_Click()
On Error Resume Next
lblconfpass.Visible = False
cmdNuevoUsuario.Visible = True
CmdGuardar.Visible = False
txtConfirmPass.Visible = False
txtbuscaruser.Visible = True
txtbuscarpass.Visible = True
txtAdminpass.Visible = False
lbladminpass.Visible = False

End Sub


Private Sub cmdNuevoUsuario_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdNuevoUsuario.FontBold = True
cmdNuevoUsuario.ForeColor = &HFF0000
End Sub

Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

End Sub


Private Sub Command1_Click()


End Sub

Private Sub Form_Load()
Call CapsLock
   
   frmlogin.Left = -4000
  
        
End Sub

Private Sub frmlogin_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdNuevoUsuario.FontBold = False
cmdNuevoUsuario.ForeColor = &H0
cmdhideNew.FontBold = False
cmdhideNew.ForeColor = &H0
End Sub




Private Sub Label2_Click()
 On Error Resume Next
  Dim intobj As Object
   Set intobj = CreateObject("InternetExplorer.Application")
    intobj.Visible = -1
     intobj.Navigate "CodeFans.net"
      Do Until intobj.busy = False
       Loop
End Sub

'
Private Sub Picture1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdhideNew.FontBold = False
cmdhideNew.ForeColor = &HFF0000
cmdNuevoUsuario.FontBold = False
cmdNuevoUsuario.ForeColor = &HFF0000
End Sub


Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cmdhideNew.FontBold = False
cmdhideNew.ForeColor = &HFF00&
cmdNuevoUsuario.FontBold = False
cmdNuevoUsuario.ForeColor = &HFF00&
End Sub


Private Sub Timer1_Timer()
frmlogin.Left = frmlogin.Left + 150
If frmlogin.Left >= 2600 Then
Timer1.Enabled = False
For D = -100 To 80

Next
Timer1.Enabled = False
End If

End Sub



Private Sub Timer2_Timer()
If Timer1.Enabled = False Then
If barraprogreso.Width < 3500 Then
 barraprogreso.Width = barraprogreso.Width + 100
 Else
 barraprogreso.Width = 3500
 Timer2.Enabled = False
 barraprogreso.Visible = False
 lblbaraloding.Visible = False
 'txtbuscaruser.SetFocus
 Exit Sub
 End If
End If
End Sub

Private Sub CmdGuardar_Click()

  If txtAdminpass.Text = "ADMINISTRATOR" Then
    txtUser.Enabled = True
    txtpass.Enabled = True
    txtConfirmPass.Enabled = True
  End If
  
  If txtAdminpass.Text = "" Then
     MsgBox ("请输入超级管理员密码."), vbExclamation, "管理员"
     Exit Sub
  End If
   
  If txtAdminpass.Text <> "ADMINISTRATOR" Then
     MsgBox (" 管理员密码不正确，请重新输入."), vbCritical, "管理员"
     Exit Sub
  End If
  

If txtpass.Text = "" Or txtConfirmPass.Text = "" Then
MsgBox ("新建用户帐号必须输入用户名和密码！"), vbExclamation, "管理员"
Exit Sub
End If
If txtpass.Text <> txtConfirmPass.Text Then
MsgBox (" 两次的密码不一致，请重新确认输入!"), vbCritical, "错误"
If txtAdminpass.Text <> txtpass.Text Then
MsgBox ("")
Exit Sub
End If
Else
If txtpass.Text = txtConfirmPass.Text Then
lblconfpass.Visible = False
cmdNuevoUsuario.Visible = True
CmdGuardar.Visible = False
txtbuscaruser.Visible = True
txtbuscarpass.Visible = True
txtAdminpass.Visible = False
lbladminpass.Visible = False
txtConfirmPass.Visible = False
End If
End If

Open "SysFile.vbe" For Append As #1
Write #1, txtUser, txtpass, txtConfirmPass, txtAdminpass
Close #1


End Sub

Private Sub cmdEnter_Click()
On Error Resume Next

If txtbuscaruser.Text = "" Or txtbuscarpass.Text = "" Then
 MsgBox ("请输入密码和用户！"), vbCritical, "错误"
   txtbuscarpass.Text = ""
   txtbuscaruser.Text = ""
   txtbuscaruser.SetFocus
  Exit Sub
End If



On Error GoTo ErrorHandler
   Dim campo1 As Variant
   Dim campo2 As Variant
   Dim campo3 As Variant
   Dim campo4 As Variant

Open "SysFile.vbe" For Input As #1
  Do Until EOF(1)
    Input #1, campo1, campo2, campo3, campo4
       txtUser.Text = campo1
       txtpass.Text = campo2
       txtConfirmPass.Text = campo3
       txtAdminpass.Text = campo4

If txtbuscaruser.Text = campo1 And txtbuscarpass.Text = campo2 Then
  Unload Me
  MDIHome.Show
    Exit Sub
     Exit Do
End If

   Loop

Close #1

ErrorHandler:
 If txtbuscaruser.Text <> campo1 Or txtbuscarpass.Text <> campo2 Then
  MsgBox ("用户名或者密码错误. "), vbCritical, "错误"
   txtbuscarpass.Text = ""
   txtbuscaruser.Text = ""
   txtbuscaruser.SetFocus
 Exit Sub
End If


 End Sub


Private Sub txtAdminbuscPass_Change()
Call CapsLock
End Sub

Private Sub txtbuscarpass_GotFocus()
txtbuscarpass.BackColor = &HFF00&
End Sub


Private Sub txtbuscarpass_LostFocus()
txtbuscarpass.BackColor = &HC0C0C0
End Sub


Private Sub txtbuscaruser_Click()
Call CapsLock
End Sub

Private Sub txtbuscaruser_GotFocus()
txtbuscaruser.BackColor = &HFF00&
End Sub


Private Sub txtbuscaruser_LostFocus()
txtbuscaruser.BackColor = &HC0C0C0
End Sub




Private Sub txtUser_Change()
Call CapsLock
End Sub


Private Sub txtUser_Click()
Call CapsLock
End Sub