VBA常用技巧代码解析

ylrshcn · 发表于 2009-3-22 10:12

袁斑竹,不介意我把这里的技巧整理成一本书发到论坛上吧!!!!!!!!!!!!

dennypeng · 发表于 2009-3-22 14:30

have a look

zyq401 · 发表于 2009-3-22 16:35

第7部分菜单和工具栏
技巧88 禁用工作表右键菜单

请教楼主：
我测试了这个后，excel工作表右键菜单不能用了。必须再次打开你的附件中工作簿点击启用才能。如何解决？

yuanzhuping · 发表于 2009-3-22 19:26

原帖由 zyq401 于 2009-3-22 16:35 发表
第7部分菜单和工具栏
技巧88 禁用工作表右键菜单

请教楼主：
我测试了这个后，excel工作表右键菜单不能用了。必须再次打开你的附件中工作簿点击启用才能。如何解决？

不会呀，在工作簿事件中有恢复的。

Private Sub Workbook_Deactivate()
Call EnaBar
End Sub

复制代码

禁用后就是没恢复只要关闭示例工作簿后也能启用的。

yuanzhuping · 发表于 2009-3-22 19:28

原帖由 ylrshcn 于 2009-3-22 10:12 发表
袁斑竹,不介意我把这里的技巧整理成一本书发到论坛上吧!!!!!!!!!!!!

如果是发到EH论坛当然不介意，我也想整理完成后请人制作成电子书供大家下载。

yuanzhuping · 发表于 2009-3-22 22:29

技巧93 在工具栏上添加下拉列表框
如果需要在工具栏中添加类似“字体”这样的下拉列表控制框控件，那么可以使用下面的代码。

#001 Sub AddDropdown()
#002 Dim myDropdown As Object
#003 Dim myCap As Variant
#004 Dim i As Integer
#005 myCap = Array("基础应用", "VBA程序开发", "函数与公式")
#006 Call DeleteButton
#007 Set myDropdown = Application.CommandBars("Formatting").Controls _
#008 .Add(Type:=msoControlDropdown, Before:=1)
#009 With myDropdown
#010 .Caption = "请选择版块"
#011 .OnAction = "myOnA"
#012 .Style = msoComboNormal
#013 For i = 0 To UBound(myCap)
#014 .AddItem myCap(i)
#015 Next
#016 .ListIndex = 1
#017 End With
#018 End Sub
#019 Sub DeleteButton()
#020 With Application.CommandBars("Formatting").Controls(1)
#021 If .Caption = "请选择版块" Then .Delete
#022 End With
#023 End Sub
#024 Sub myOnA()
#025 Dim myList As Byte
#026 myList = Application.CommandBars("Formatting") _
#027 .Controls(1).ListIndex
#028 ActiveWorkbook.FollowHyperlink _
#029 Address:="http://club.excelhome.net/forum-" & myList & "-1.html", NewWindow:=True
#030 End Sub

复制代码

代码解析：
   AddDropdown过程使用Add方法在工具栏中添加下拉列表控制框控件。
   第5行代码使用Array函数创建一个数组用于保存下拉列表控制框控件加载列表项所需的元素。
      第6行代码先运行第19行到第23行的DeleteButton过程删除可能存在的下拉列表控制框控件，以免重复添加。DeleteButton过程判断工具栏中第一个控件的Caption属性是否为“请选择版块”，如果是则删除该下拉列表控制框控件。
   第7、8行代码使用Add方法在工具栏中添加下拉列表控制框控件。应用于 CommandBarControls 对象的Add方法请参阅技巧79 。示例中将其参数Type设置为msoControlDropdown，添加的就是下拉列表控制框控件。
   第10行代码设置下拉列表控制框控件的Caption属性，应用于 CommandBarControls 对象的Caption属性返回或设置指定命令栏控件的题注文字，也可作为默认的“屏幕提示”显示。
   第11行代码设置改变下拉列表控制框控件的内容时要运行的过程为第24行到第30行代码的myOnA过程。myOnA过程根据下拉列表控制框控件的ListIndex属性值打开Excel Home论坛中相应的版块。
   第12行代码设置下拉列表控制框控件的样式。Style属性返回或设置命令栏控件的显示方式，该属性值可设置为表格所列MsoComboStyle常量之一。

   第13行到第15行代码使用AddItem方法将数组中的元素添加到下拉列表控制框控件的列表项中。
   第16行代码将下拉列表控制框控件的ListIndex属性设置为1，使其显示第一条列表项。
   运行AddDropdown过程，工具栏如图所示。

yuanzhuping · 发表于 2009-3-23 08:07

技巧94 屏蔽工作表的复制功能
有时我们并不希望用户对工作表中的数据进行复制粘贴操作，此时可以把所有的复制功能都屏蔽，如下面的代码所示。

#001 Dim CmdCtrls As CommandBarControls
#002 Dim Cmd As CommandBarControl
#003 Sub ProCopy()
#004 Set CmdCtrls = Application.CommandBars.FindControls(ID:=19)
#005 For Each Cmd In CmdCtrls
#006 Cmd.Enabled = False
#007 Next
#008 Application.CellDragAndDrop = False
#009 Application.OnKey ("^c"), ""
#010 End Sub
#011 Sub StaCopy()
#012 Set CmdCtrls = Application.CommandBars.FindControls(ID:=19)
#013 For Each Cmd In CmdCtrls
#014 Cmd.Enabled = True
#015 Next
#016 Application.CellDragAndDrop = True
#017 Application.OnKey ("^c")
#018 End Sub

复制代码

代码解析：
   第1、2行代码在模块顶部声明两个模块级的变量。
   第3行到第10行代码ProCopy过程，屏蔽工作表中所有的复制功能。其中第4行到第7行代码使用FindControls方法将所有与“复制”相关的命令栏控件赋给变量CmdCtrls后将其Enabled设置为False。关于FindControls方法请参阅技巧80 。
   第8行代码屏蔽单元格拖放功能，关于应用于Application对象的CellDragAndDrop属性请参阅技巧10 。
   第9行代码屏蔽<Ctrl+C>组合键功能，关于应用于Application 对象的OnKey方法请参阅技巧68 。
   第11行到第18行代码StaCopy过程，恢复所有的复制功能。

zyq401 · 发表于 2009-3-23 09:13

原帖由 yuanzhuping 于 2009-3-22 19:26 发表

不会呀，在工作簿事件中有恢复的。Private Sub Workbook_Deactivate()
Call EnaBar
End Sub禁用后就是没恢复只要关闭示例工作簿后也能启用的。

不知道什么原因，就是不能恢复，只有重新打开下载的示例工作表点击启用才行。我试了无数次了。我是2003与2007共存。

ykx042907 · 发表于 2009-3-23 10:22

yuan版主：您好！您真是太辛苦了。请教一个问题：若将技巧27 自动建立工作表目录的工作表名称从E6：J6向下排放，怎么写代码呀？谢谢！

yuanzhuping · 发表于 2009-3-23 11:29

原帖由 ykx042907 于 2009-3-23 10:22 发表
yuan版主：您好！您真是太辛苦了。请教一个问题：若将技巧27 自动建立工作表目录的工作表名称从E6：J6向下排放，怎么写代码呀？谢谢！

Private Sub Worksheet_Activate()
Dim sh As Worksheet
Dim a As Integer
Dim R As Integer
Dim rng As Range
R = Abs(Int(-(Worksheets.Count - 1) / 6)) + 5
a = 1
Set rng = Sheet1.Range("E6:J" & R)
rng.ClearContents
For Each sh In Worksheets
If sh.CodeName <> "Sheet1" Then
rng(a) = sh.Name
a = a + 1
End If
Next
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

VBA常用技巧代码解析

<<精华技巧,技巧精华>>

第7部分菜单和工具栏

第7部分菜单和工具栏

自动建立工作表目录相关问题

VBA常用技巧代码解析

<<精华技巧,技巧精华>>

第7部分 菜单和工具栏

第7部分 菜单和工具栏

自动建立工作表目录相关问题

第7部分菜单和工具栏

第7部分菜单和工具栏