[第5期] WORD工具栏/命令列表[已总结]

konggs

Option Explicit

Sub 工具栏命令列表()

Dim X As Byte

Dim i As CommandBar, n As CommandBarControl, j As Paragraph, myrange As Range

Dim A%, B%, s%

Debug.Print Timer

Application.ScreenUpdating = False '关闭屏幕更新

页眉页脚

制表位

Options.PictureWrapType = wdWrapMergeInline '图片设为嵌入型

For Each i In Application.CommandBars '在命令栏中循环

On Error Resume Next '忽略错误

A = A + 1 '命令栏计数器

Set myrange = ActiveDocument.Paragraphs.Last.Range

myrange.Paragraphs.LeftIndent = CentimetersToPoints(0) '则左缩进为0

myrange.Font.Bold = True '而且加粗

myrange.InsertAfter A & "." & i.Name & vbCrLf

For Each n In i.Controls '在命令栏i中的控件集合中循环

B = B + 1 '一级控件计数器

myrange.InsertAfter A & "." & B & vbTab & n.Caption & vbTab & "ID:＝" & n.ID & vbTab

Set myrange = ActiveDocument.Paragraphs.Last.Range

myrange.Paragraphs.LeftIndent = CentimetersToPoints(1) '则左缩进为1

myrange.Font.Bold = False '不加粗

s = n.ID

face (s)

ActiveDocument.Words.Last.Paste '在最后一个位置粘贴

' myrange.Paste

myrange.InsertAfter Chr(13) '插入一个回车

On Error Resume Next '忽略错误 '忽略错误

Next

B = 0 '复零

Next

Application.ScreenUpdating = True '恢复屏幕更新

Debug.Print Timer

Application.CommandBars("Standard").Controls(1).FaceId = 2520 '恢复第一个的“新建”默认图标

End Sub

Sub 页眉页脚()

Dim myrange As Range

Dim range1 As Range

With ActiveDocument.Sections(1)

With .Headers(wdHeaderFooterPrimary).Range '设置页眉

.Text = "Word工具栏/命令列表" '页面上的文字

.Font.Name = "华文细黑" '文字的格式

.Font.Size = "16"

.ParagraphFormat.Alignment = wdAlignParagraphCenter '居中对齐

End With

Set myrange = .Footers(wdHeaderFooterPrimary).Range '设置页眉

NormalTemplate.AutoTextEntries("第 X 页 共 Y 页").Insert Where:=myrange '插入自动图文集中的域代码

myrange.ParagraphFormat.Alignment = wdAlignParagraphRight '页脚右对齐

End With

End Sub

Sub 制表位()

With ActiveDocument.Paragraphs(1).TabStops

.Add Position:=CentimetersToPoints(2.5) '2.5厘米处第一个制表位

.Add Position:=CentimetersToPoints(11) '11厘米处第一个制表位

.Add Position:=CentimetersToPoints(14) '14厘米处第一个制表位

End With

End Sub

Sub face(s As Integer)

With Application.CommandBars("Standard").Controls(1)

.FaceId = s '利用第一个图标来复制、粘贴

.CopyFace

End With

End Sub

没用selection的改进，也没有在段落中循环。速度稍快一点点。

lg_cai

Sub list() Dim bbar As CommandBarControl, cbar As CommandBar Application.ScreenUpdating = False Documents.Add With ActiveWindow.ActivePane.View .Type = wdPageView .SeekView = wdSeekCurrentPageHeader End With With Selection .ParagraphFormat.Alignment = wdAlignParagraphCenter .Font.Bold = wdToggle .Font.Size = 16 .Text = "Word工具栏/命令列表" ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter .ParagraphFormat.Alignment = wdAlignParagraphRight .TypeText Text:="第 " .Fields.Add Range:=.Range, Type:=wdFieldPage .TypeText Text:=" 页 共 " .Fields.Add Range:=.Range, Type:=wdFieldNumPages .TypeText Text:=" 页" End With ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument ActiveDocument.Paragraphs.TabStops.Add Position:=CentimetersToPoints(2.5) ActiveDocument.Paragraphs.TabStops.Add Position:=CentimetersToPoints(11) ActiveDocument.Paragraphs.TabStops.Add Position:=CentimetersToPoints(14) With ActiveDocument.Paragraphs For Each cbar In CommandBars .Last.Range.InsertAfter cbar.Index & "." & cbar.Name .Last.Range.Bold = True .Last.LeftIndent = 0 .Add .Last.Range.Bold = False .Last.LeftIndent = CentimetersToPoints(1) For Each bbar In cbar.Controls .Last.Range.InsertAfter cbar.Index & "." & bbar.Index & vbTab & bbar.Caption & vbTab & bbar.ID & vbTab If bbar.Type = 1 Then bbar.CopyFace ActiveDocument.Range(Start:=.Last.Range.End - 1, End:=.Last.Range.End - 1).Paste End If .Add Next bbar Next cbar End With Application.ScreenUpdating = True End Sub

'*******************************************************************

1. 代码运行正常，满足要求。

2. 对于RANGE对象的应用,已经非常不错了,如果在页眉页脚中如果使用RANGE对象和自动图文集,这个代码更好.

3. 没有考虑到图片插入/粘贴时的WORD选项设置.

[此贴子已经被守柔于2005-11-21 6:37:39编辑过]

konggs

再发一下终极版，这次多了一个判断条件，以避免在一级控件中不需要的多次设置。 经测试，比老大的代码的运行速度长一点(5秒)。

Option Explicit Sub 工具栏命令列表() Dim X As Byte Dim i As CommandBar, n As CommandBarControl, j As Paragraph, myrange As Range Dim A%, B%, s% Debug.Print Timer Application.ScreenUpdating = False '关闭屏幕更新 页眉页脚 制表位 Options.PictureWrapType = wdWrapMergeInline '图片设为嵌入型 For Each i In Application.CommandBars '在命令栏中循环 On Error Resume Next '忽略错误 A = A + 1 '命令栏计数器 Set myrange = ActiveDocument.Paragraphs.Last.Range myrange.Paragraphs.LeftIndent = CentimetersToPoints(0) '则左缩进为0 myrange.Font.Bold = True '而且加粗 myrange.InsertAfter A & "." & i.Name & vbCrLf For Each n In i.Controls '在命令栏i中的控件集合中循环 B = B + 1 '一级控件计数器 myrange.InsertAfter A & "." & B & vbTab & n.Caption & vbTab & "ID:＝" & n.ID & vbTab If B = 1 Then '每一次进入一个新的控件则设置为 Set myrange = ActiveDocument.Paragraphs.Last.Range myrange.Paragraphs.LeftIndent = CentimetersToPoints(1) '则左缩进为1 myrange.Font.Bold = False '不加粗 End If s = n.ID face (s) ActiveDocument.Words.Last.Paste '在最后一个位置粘贴 ' myrange.Paste myrange.InsertAfter Chr(13) '插入一个回车 On Error Resume Next '忽略错误 '忽略错误 Next B = 0 '复零 Next Application.ScreenUpdating = True '恢复屏幕更新 Debug.Print Timer Application.CommandBars("Standard").Controls(1).FaceId = 2520 '恢复第一个的“新建”默认图标 End Sub Sub 页眉页脚() Dim myrange As Range Dim range1 As Range With ActiveDocument.Sections(1) With .Headers(wdHeaderFooterPrimary).Range '设置页眉 .Text = "Word工具栏/命令列表" '页面上的文字 .Font.Name = "华文细黑" '文字的格式 .Font.Size = "16" .ParagraphFormat.Alignment = wdAlignParagraphCenter '居中对齐 End With Set myrange = .Footers(wdHeaderFooterPrimary).Range '设置页眉 NormalTemplate.AutoTextEntries("第 X 页 共 Y 页").Insert Where:=myrange '插入自动图文集中的域代码 myrange.ParagraphFormat.Alignment = wdAlignParagraphRight '页脚右对齐 End With End Sub Sub 制表位() With ActiveDocument.Paragraphs(1).TabStops .Add Position:=CentimetersToPoints(2.5) '2.5厘米处第一个制表位 .Add Position:=CentimetersToPoints(11) '11厘米处第一个制表位 .Add Position:=CentimetersToPoints(14) '14厘米处第一个制表位 End With End Sub Sub face(s As Integer)

With Application.CommandBars("Standard").Controls(1) .FaceId = s '利用第一个图标来复制、粘贴 .CopyFace End With End Sub

'**********************************************

1. 代码运行正常，满足要求。

2. 考虑到图片插入/粘贴时的WORD选项设置却没有为用户进行恢复

3. FACEID类型设置不当,没有必要和理由"借鸡生蛋"啊?

4. RANGE对象运用得不错.

[此贴子已经被守柔于2005-11-21 6:43:00编辑过]

rongjun

我的答案：

Private Sub CommandButton1_Click() Dim bars As CommandBar, x As Integer, y As Integer, ycount As Integer On Error Resume Next Application.ScreenUpdating = False ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader With Selection .Font.Bold = True .Font.Size = 16 .TypeText Text:="Word工具栏/命令列表" .ParagraphFormat.Alignment = wdAlignParagraphCenter ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter NormalTemplate.AutoTextEntries("第 X 页 共 Y 页").Insert Where:=.Range, RichText:=True .ParagraphFormat.Alignment = wdAlignParagraphRight ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument .HomeKey Unit:=wdStory .MoveRight Unit:=wdCharacter, Count:=1 For Each bars In ThisDocument.CommandBars x = x + 1 .TypeParagraph .ParagraphFormat.LeftIndent = CentimetersToPoints(0) .Font.Bold = True .ParagraphFormat.Alignment = wdAlignParagraphJustify .TypeText (x & "." & bars.Name) .Font.Bold = False ycount = CommandBars(bars.Name).Controls.Count For y = 1 To ycount .TypeParagraph .ParagraphFormat.LeftIndent = CentimetersToPoints(1) .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(2.5) .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(11) .ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(14) .TypeText (x & "." & y & vbTab & CommandBars(bars.Name).Controls(y).Caption _ & vbTab & "ID:=" & CommandBars(bars.Name).Controls(y).ID & vbTab) Err.Clear CommandBars(bars.Name).Controls(y).CopyFace If Err.Number = 0 Then .Paste Next Next .HomeKey Unit:=wdStory End With Application.ScreenUpdating = True End Sub

'***************************************************************

1. 代码运行正常，满足要求。

2. 没有考虑到图片插入/粘贴时的WORD选项设置

3. 整个过程语句结构紧凑流畅,看上去比较舒服.

4. 如果使用RANGE对象代替SELECTION对象,会更好一些.

5. 错误处理在本题中可以使用其它方法来判断这样更合理一些.

[此贴子已经被守柔于2005-11-21 6:46:06编辑过]