抄写兰色幻想的《VBA应用技巧代码》的实例代码（稍有改动）

MyPC999

认真读一读

LAOMALIN

第5章OK

LAOMALIN

第6章 进销存综合实例
6-127用户登录
Private Sub CommandButton1_Click()
If ComboBox1.Text = "" Or TextBox1.Text = "" Then
     MsgBox "请填写齐全", 1 + 64, "系统登陆"
     TextBox1.SetFocus
Else
  
       If 取操作员密码(ComboBox1.Value) = TextBox1.Text Then
       AAA = ComboBox1.Value
       Unload Me
       MsgBox ComboBox1.Text & "你好!欢迎你进入本系统", 1 + 64, "欢迎词"
       Application.DisplayStatusBar = True
         Application.StatusBar = "今天是" & Format(Date, "YYYY年M月D日,") & "当前操作员:" & Me.ComboBox1.Value
       Unload Me
        Application.Visible = True
        Else
        MsgBox "登陆密码错误,请重新输入"
        End If
End If
End Sub
Private Sub CommandButton2_Click()
Unload Me
Application.Visible = True
ActiveWorkbook.Close SAVECHANGES:=False
End Sub
Private Sub UserForm_Initialize()

操作员 Me.ComboBox1

End Sub

Private Sub Userform_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = 1
End Sub

Sub 操作员(XXX As Object)
Dim RS1 As Recordset
    Dim DB1 As Database
    Dim I As Integer
  Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
  Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
    RS1.MoveLast
    RS1.MoveFirst
        For I = 1 To RS1.RecordCount
        XXX.AddItem RS1.Fields("操作员")
        RS1.MoveNext
        Next I
   RS1.Close
    DB1.Close
End Sub
Function 取操作员密码(XXX As String)
Dim RS1 As Recordset
Dim DB1 As Database
   
    Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
    Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
         RS1.FindFirst "操作员='" & XXX & "'"
         
    取操作员密码 = RS1.Fields("密码").Value
    RS1.Close
    Set RS1 = Nothing
    Set DB1 = Nothing
End Function

6-129用户管理
Public aaa
Function 取操作员密码(XXX As String)
Dim RS1 As Recordset
Dim DB1 As Database
   
    Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
    Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
         RS1.FindFirst "操作员='" & XXX & "'"
         
    取操作员密码 = RS1.Fields("密码").Value
    RS1.Close
    Set RS1 = Nothing
    Set DB1 = Nothing
End Function

Sub 操作员(XXX As Object)
Dim RS1 As Recordset
    Dim DB1 As Database
  
    Dim I As Integer
    Dim J As Integer
  Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
  Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
    RS1.MoveLast
    RS1.MoveFirst
   
        For I = 1 To RS1.RecordCount
        XXX.AddItem RS1.Fields("操作员")
        RS1.MoveNext
        Next I
   RS1.Close
    DB1.Close
   
Exit Sub
100
DB1.Close
End Sub

Private Sub CommandButton1_Click()
If ComboBox1.Text = "" Or TextBox1.Text = "" Then
     MsgBox "请填写齐全", 1 + 64, "系统提示"
     TextBox1.SetFocus
Else
   If 取操作员密码(ComboBox1.Text) = TextBox1.Text Then
      MsgBox "更换操作员成功", 1 + 64, "系统提示"
      Application.StatusBar = "今天是" & Format(Date, "YYYY年M月D日,") & "当前操作员:" & Me.ComboBox1.Value
      aaa = ComboBox1.Text
      Unload Me
  Else
    MsgBox "密码输入错误,更换操作员失败!", 1 + 64, "系统提示"
  End If
End If
End Sub

Private Sub CommandButton2_Click()
Unload Me
Application.Visible = True
End Sub

Private Sub UserForm_Initialize()
On Error Resume Next
操作员 Me.ComboBox1
End Sub

Private Sub ListBox1_Click()
Dim RS1 As Recordset
Dim DB1 As Database
   
    Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
    Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
         RS1.FindFirst "操作员='" & ListBox1.Text & "'"
         CheckBox1.Value = IIf(RS1.Fields("入库单制单").Value = 0, 0, 1)
         CheckBox2.Value = IIf(RS1.Fields("入库单删除").Value = 0, 0, 1)
         CheckBox3.Value = IIf(RS1.Fields("入库单审核").Value = 0, 0, 1)
         CheckBox4.Value = IIf(RS1.Fields("出库单删除").Value = 0, 0, 1)
         CheckBox5.Value = IIf(RS1.Fields("出库单制单").Value = 0, 0, 1)
         CheckBox6.Value = IIf(RS1.Fields("出库单审核").Value = 0, 0, 1)
         CheckBox7.Value = IIf(RS1.Fields("调拨单审核").Value = 0, 0, 1)
         CheckBox8.Value = IIf(RS1.Fields("调拨单删除").Value = 0, 0, 1)
         CheckBox9.Value = IIf(RS1.Fields("调拨单制单").Value = 0, 0, 1)
         CheckBox10.Value = IIf(RS1.Fields("入库查询").Value = 0, 0, 1)
         CheckBox11.Value = IIf(RS1.Fields("出库查询").Value = 0, 0, 1)
         CheckBox12.Value = IIf(RS1.Fields("库存查询").Value = 0, 0, 1)
         CheckBox13.Value = IIf(RS1.Fields("展厅销售表").Value = 0, 0, 1)
         CheckBox14.Value = IIf(RS1.Fields("往来余额表").Value = 0, 0, 1)
         CheckBox15.Value = IIf(RS1.Fields("提成表").Value = 0, 0, 1)
         CheckBox16.Value = IIf(RS1.Fields("成本结转表").Value = 0, 0, 1)
         CheckBox17.Value = IIf(RS1.Fields("赠送汇总表").Value = 0, 0, 1)
         CheckBox18.Value = 0
         CheckBox20.Value = IIf(RS1.Fields("留2").Value = 0, 0, 1)
         CheckBox21.Value = IIf(RS1.Fields("留3").Value = 0, 0, 1)
         CheckBox22.Value = IIf(RS1.Fields("权限设置").Value = 0, 0, 1)
         CheckBox23.Value = IIf(RS1.Fields("基础信息设置").Value = 0, 0, 1)
         CheckBox24.Value = IIf(RS1.Fields("数据库备份").Value = 0, 0, 1)
         RS1.Close
    Set RS1 = Nothing
    Set DB1 = Nothing
End Sub

Private Sub UserForm_Initialize()
'查询权限设置
For I = 1 To 24
Me.Controls("CheckBox" & I).Value = 0
Next I
操作员 ListBox1
End Sub
Sub 查询权限设置()
Dim RS1 As Recordset
Dim DB1 As Database
   
    Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
    Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
         RS1.FindFirst "操作员='" & aaa & "'"
         If RS1.Fields("权限设置").Value = 0 Then
        ' CommandButton1.Enabled = False
       '  CommandButton2.Enabled = False
        ' CommandButton3.Enabled = False
      Else
        ' CommandButton1.Enabled = True
       '  CommandButton2.Enabled = True
         CommandButton3.Enabled = True
         RS1.Close
         DB1.Close
         Set DB1 = Nothing
         Set RS1 = Nothing
         End If
End Sub

Private Sub CommandButton1_Click()
Dim BBB As String
BBB = 取操作员密码(ComboBox1.Text)

If TextBox1.Text = "" Or TextBox2.Text = "" Or TextBox3.Text = "" Then
MsgBox "更改信息不齐全!", 1 + 64, "系统提示"
Else
   If BBB = TextBox1.Text Then
      If TextBox3.Text = TextBox2.Text Then
      Dim RS1 As Recordset
      Dim DB1 As Database
   
      Set DB1 = OpenDatabase(ThisWorkbook.Path & "\" & "CangKu.MDB")
      Set RS1 = DB1.OpenRecordset(Name:="CaoZuoYuan", Type:=dbOpenDynaset)
         RS1.FindFirst "操作员='" & aaa & "'"
         RS1.Edit
         RS1.Fields("密码").Value = TextBox3.Value
         RS1.Update
      RS1.Close
      Set RS1 = Nothing
      Set DB1 = Nothing
      MsgBox "密码更换成功!,新设置的密码为:" & TextBox3.Value & ",请牢记密码!"
      Unload Me
      Else
      MsgBox "确认密码输入有误,请重新输入!", 1 + 64, "系统提示"
      TextBox3.SetFocus
      End If
    Else
    MsgBox "原密码输入错误,请重新输入!", 1 + 64, "系统提示"
    TextBox1.SetFocus
    End If
End If
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
操作员 Me.ComboBox1
End Sub

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
With ActiveWindow
        .DisplayHorizontalScrollBar = False
        .DisplayVerticalScrollBar = False
    End With
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Deactivate()
With ActiveWindow
        .DisplayHorizontalScrollBar = True
        .DisplayVerticalScrollBar = True
    End With
End Sub

LAOMALIN

第一部 《VBA技巧应用》(作者：赵志东)        14
第1章 EXCEL文件与文件夹操作        14
1.1返回当前EXCEL文件的路径        14
1.2返回指定文件夹中的文件列表        15
1.3判断文件夹中指定文件是否存在        15
Sub 判断AAA文件是否存在()        15
Sub 提取EXCEL文件名称()        16
1.4在文件夹之间复制和移动EXCEL文件        16
Sub 复制表1()        16
Sub 移动表2()        16
1.5判断指定文件夹是否存在        17
1.6列示所有子文件夹名称        17
1.7文件夹的复制和移动        18
Sub 复制A文件夹到C()        18
Sub 移动B文件夹到C()        18
1.8批量删除文件夹        19
1.9获取文件夹大小        19
1-19用U盘系列号做工作薄打开密码        20
1.10用程序打开指定文件夹        22
1.11用程序创建桌面快捷方式        23
1.12判断指定EXCEL文件是否打开        23
1.13EXCEL文件打开时播放音乐        24
1.14定时“自杀”的EXCEL文件        24
1.15限制EXCEL文件使用的次数        24
1.16批量创建EXCEL文件        25
1.17禁用宏则关闭EXCEL文件        26
1.18只能自已电脑上使用的EXCEL文件        26
第2章 EXCEL表格与数据处理        27
2.19判断A1:A7单元格数据类型        27
2.20单元格区域的端点选取        28
2.21返回单元格区域的合集和交集        28
2.22已选取的单元格区域范围和大小        29
2.23高亮显示当前行和列        29
2.24检查单元格中是否含有公式        30
2.25判断单元格是否处于隐藏状态        30
2.26批量删除空行        30
2.27控制重复录入        31
2.28自动填充公式        32
2.29每隔5行插入一个空行        32
2.30产生不重复随机整数        32
2.31重复内容的指定位置查找        33
2.32相同内容单元格的批量合并与拆分        35
2.33唯一值的提取        35
2.34查找合并单元格地址        36
2.35查找合并单元格地址        36
2.36判断工作簿中是否包含指定工作表        37
2.37删除工作簿中所有空白工作表        37
2.38禁止修改指定工作表名称        37
2.39禁止选定指定工作表之外的工作表        37
2.40判断工作表是否被保护        38
2.41禁止打印工作表内容        38
2.42批量隐藏除表名"AAA"之外的所有工作表        38
2.43批量添加和删除超级链接        39
2.44工作表数据清单批量合并        39
2.45工作表分别导出为EXCEL文件        40
本示例新建一个工作簿，提示用户输入文件名，然后保存该工作簿。        40
2.46单元格内动态显示时间        41
2.47自动导入图片到指定单元格        42
2.48双面打印程序        43
2.49金额大小写转换        44
2.50分离文本与数字        45
2.51考试随机出题        46
2.52工资表自动分页小计        46
2.5３会计科目代码自动转换        48
2.5４动画图表        48
第3章 EXCEL窗体与控件        49
3-55一次清空所有文本框数据        49
3-56设置文本框的密码样式        49
3-57文本框中只允许录入数字        49
3-58文本框输入内容必须包含指定字符A        50
3-59格式化文本框字符和数字        50
3-60用微调按钮控制文本框数字显示        50
3-61锁定文本框        50
3-62设置按钮自动响应ENTER和ESC键按下        51
3-63鼠标经过按钮时按钮高亮显示        51
3-64一个按钮执行两个不同程序        51
3-65为按钮批量创建快捷键        52
3-66两个列表框之间的内容转移        52
3-67利用数组向文本框添加内容        53
3-68向多列列表框动态添加数据        53
3-69获取多列组合框的第二列内容        54
3-70向组合框中导入不重复内容        54
3-71多个组合框筛选链接        54
3-72组合框的智能筛选        55
3-73用滚动条调节控件显示位置        55
3-74图形控件的图片加载与删除        56
第75例：LISTVIEW控件添加新记录        56
第76例：LISTVIEW控件添加图标        57
第77例：LISTVIEW控件对工作表实现数据筛选        58
第78例：LISTVIEW控件所有数据输出到工作表        59
第79例：LISTVIEW控件选取行数据输出到工作表        60
第80例：LISTVIEW控件红色字体合计行设置        61
第81例：LISTVIEW控件记录批量删除        62
第82例：TREEVIEW控件从工作表中读取数据        63
第83例：TREEVIEW控件选取目录的获取        63
第84例：TREEVIEW控件目录的动态添加        64
第85例：TREEVIEW控件节点的动态修改        65
第86例：TREEVIEW控件节点的动态删除        66
第4章 EXCEL与数据库连接        67
4-87向未打开的EXCEL文件中输入数据        67
4-88合并多个未打开的EXCEL文件中的数据        68
4-89修改未打开的EXCEL文件中的数据        68
4-90删除未打开的EXCEL文件中的数据        68
4-91查找并返回未打开的EXCEL文件中的数据        69
4-92汇总未打开的EXCEL文件中的数据        70
4-93筛选多个工作表中相同字段的唯一值        70
4-94筛选两个工作表中的重复数据        70
4-95筛选两个工作表中的不同数据        71
4-96筛选多个工作表中的数据        72
4-97模糊筛选工作表中的数据        72
4-98分类汇总所有工作表中的数据        73
4-99对两个工作表中相同字段的数据进行运算        73
4-100向ACCESS数据表中输入数据        73
4-101从ACCESS数据表中查询数据        74
4-102修改ACCESS数据表中的数据        75
4-103删除ACCESS数据表中的数据        76
4-104根据时间段从ACCESS数据表中筛选数据        76
4-105从ACCESS数据表中筛选前5名的数据        76
4-106从有密码保护的ACCESS数据中筛选数据        76
4-107从多个ACCESS数据表中筛选数据        76
4-108根据多条件筛选ACCESS数据表中的数据        76
4-109根据不定数量条件筛选ACCESS数据表中的数据        76
4-110从ACCESS数据表中模糊筛选数据        76
4-111对ACCESS数据表中的数据进行分类汇总        76
第5章 EXCEL程序界面设置        76
第112例：用进度条显示程序运行进度(进度条)        76
第113例：窗体流动图片        76
第114例：设置可转换的背景图        76
第115例：显示所有工具栏名称和英文名称        76
第116例：批量显示内置命令图标        76
第117例：修改图标和程序标题名称        76
第118例：动态调整窗口结构        76
第119例：屏蔽右键菜单        76
第120例：屏蔽菜单栏和工具栏命令        76
第121例：在右键菜单中设置自定义按钮        76
第123例：查找命令按钮是否存在        76
第124例：工具栏按纽添加自定义图标        76
第125例：自由订制程序菜单和工具栏        76
第126例：批量删除自定义工具栏和菜单栏        76
第6章 进销存综合实例        76
6-127用户登录        76
6-129用户管理        76

LAOMALIN

页码自己修改下，全部完毕

LAOMALIN

如果人气够，会有后续，能加分就更好了

LAOMALIN

来个此论坛的《VBA精粹》

pitygirl

支持，我仔细的全部抄袭了一遍，哈哈，觉得这种学习方式也蛮好的

ljx63426

楼主这么辛苦，应该加分。请楼主继续抄写。

ntcyj

支持楼主！