前言：所有软件一开始第一个功能都是登录，所以登录可以说是用户体验度非常重要的一个环节。假如：你的登录页面做的非常的不好看，而且用户登录的时间还长。这个会大大的影响到用户后面的功能体验，所以登录功能担任的非常重要的角色。

目录

界面：

流程图：

功能代码：

模块：

获取计算机名称:：

权限声明： 

程序入口：

窗体：

登录窗体：

主窗体：

界面：

流程图：

功能代码：

模块：

获取计算机名称:：

      '用于获得计算机名的api函数
      Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal
      lpBuffer As String, nSize As Long) As Long '用于获取计算机名
  
 

      Function ComputerName() As String '定义获取当前计算机名的函数
      Dim CoName As String
      CoName = String(255, Chr$(0))
      GetComputerName CoName, 255
      CoName = Left(CoName, InStr(1, CoName, Chr$(0)) - 1)
      ComputerName = CoName
      End Function
  
 

权限声明： 

Public Userlevel As String '获取用户等级，方便做权限的判断。
 

程序入口：

      Sub Main() '程序进口显示登录窗体
        Dim fLogin As New forlogin '定义窗体对象
          forlogin.Show vbModal             '显示登录窗体实例
      End Sub
  
 

窗体：

登录窗体：

      通用声明
      Dim miCount As Integer '记录登录次数
      Private Sub cmddetermine_Click()
         '用于连接数据库，进行查询使用。
         Dim txtSQL As String
         Dim mrc As ADODB.Recordset '连接数据库
         Dim Msgtext As String
         '初始化全局变量
          UserName = "" '储存全局用户
          UserPWD = "" '储存密码
          Userlevel = "" '储存等级
         '判断用户名是否为空
         If txtname.Text = "" Then
              MsgBox "请输入用户名！", vbOKCancel + vbExclamation, "警告"
              txtname.SetFocus '获取焦点
         Else
              txtSQL = "select * from user_Info where userID=' " & txtname.Text & "'" '根据条件查询
             Set mrc = ExecuteSQL(txtSQL, Msgtext) '执行txtsql
               '判断用户是否存在
               If mrc.EOF = True Then
                  MsgBox "用户不存在，请从新输入！", vbOKOnly + vbExclamation, "警告"
                  txtname.Text = "" '清空
                  txtname.SetFocus '获取焦点
               Else
               '账号是否已经登录
                Dim onworksql As String '存储SQL语句
                Dim onwormrc As ADODB.Recordset '数据集
                Dim onmsgtext As String '记录信息
                 onworksql = "select * from onwork_Info where userID='" & txtname.Text & "'" '获取正在上级表
                Set onwormrc = ExecuteSQL(onworksql, onmsgtext) '执行SQL语句
                '判断用户是否已经登录
                     If Trim(onwormrc.EOF = False) Then '如果已经登录
                          MsgBox "此账号已经登录，请从新输入！", vbOKOnly + vbExclamation, "警告"
                          txtname.Text = ""
                          txtname.SetFocus
                     Else '如果没有登录
                         '判断密码是否正确
                         If Trim(mrc.Fields(1)) = Trim(txtpwd.Text) Then
                             '跟全局变量赋值
                              UserName = Trim(txtname.Text)
                              UserPWD = Trim(txtpwd.Text)
                              Userlevel = Trim(mrc.Fields(2)) '等级赋值
                              mrc.Close '关闭数据集
                              Unload forlogin
                              formmain.Show
                         Else
                              MsgBox "输入密码不正确，请重新输入！", vbOKOnly + vbExclamation, "警告"
                              txtpwd.SetFocus
                              txtpwd.Text = ""
                         End If
                     End If
               End If
         End If
         '记载输入密码次数
          miCount = miCount + 1
         If miCount > 3 Then
              MsgBox "已经是最后一次机会了！", vbOKOnly + vbExclamation, "警告"
             End '退出登录
         End If
         Exit Sub '退出过程
      End Sub
  
 

主窗体：

调用：在窗体加载事件调用

      Private Sub MDIForm_Load()
         Call level '调用判断等级过程，实现判断不同用户级别。
      End Sub
  
 

权限判断：

      '权限判断和更新值班表与工作记录表
      Private Sub level()
         '等级判断
         If Trim(Userlevel = "管理员") Then
             '所有功能都可以使用
             Me.generaluser.Enabled = True
             Me.operator.Enabled = True
             Me.adminsitrator.Enabled = True
             Call onupdate '更新表
         ElseIf Trim(Userlevel = "操作员") Then
             '只有一般用户和操作员功能可用
              Me.generaluser.Enabled = True
              Me.operator.Enabled = True
              Me.adminsitrator.Enabled = False
              Call onupdate '更新表
         Else
             '只有一般用户可用
             Me.generaluser.Enabled = True
             Me.operator.Enabled = False
             Me.adminsitrator.Enabled = False
         End If
      End Sub
  
 

数据库更新：

      '更新正在上机表和上机记录表
      Private Sub onupdate()
         '更新值班表
         Dim onworksql As String
         Dim onworkmrc As ADODB.Recordset
         Dim onmsgtext As String
          onworksql = "select * from onwork_Info" '查询值班表
         Set onworkmrc = ExecuteSQL(onworksql, onmsgtext) '执行sql
          onworkmrc.AddNew '添加记录
          onworkmrc.Fields(0) = Trim(UserName) '用户id
          onworkmrc.Fields(1) = Trim(Userlevel) '用户等级
          onworkmrc.Fields(2) = Trim(Date) '登录日期
          onworkmrc.Fields(3) = Trim(Time) '登录时间
          onworkmrc.Fields(4) = Trim(ComputerName) '计算机名
          onworkmrc.Update '更新
          onworkmrc.Close '关闭
         '更新工作记录
         Dim worksql As String
         Dim workmrc As ADODB.Recordset
         Dim workmsgtext As String
          worksql = "select * from worklog_Info" '获取工作记录表
         Set workmrc = ExecuteSQL(worksql, workmsgtext) '执行sql
          workmrc.AddNew '添加记录
          workmrc.Fields(1) = Trim(UserName) '用户id
          workmrc.Fields(2) = Trim(Userlevel) '用户级别
          workmrc.Fields(3) = Trim(Date) '登录日期
          workmrc.Fields(4) = Trim(Time) '登录时间
          workmrc.Fields(7) = Trim(ComputerName) '计算机名
          workmrc.Fields(8) = Trim("True") '状态
          workmrc.Update '更新
          workmrc.Close '关闭数据集
      End Sub
  
 

文章来源: kangshihang.blog.csdn.net，作者：康世行，版权归原作者所有，如需转载，请联系作者。

原文链接：kangshihang.blog.csdn.net/article/details/100730767