|
基本上解决了。 我发现，与EXCEL不同，自定义菜单对WORD的每个DOCUMENT不一定是相同的配置。同一个菜单在不同的DOCUMENT中似乎是不同的实例，是否显示或者显示的位置对于每个DOCUMENT是不一致的。因此，在激活一个DOCUMENT时应该检查菜单的载入情况。根据上述发现，改动了一下，见下： '模块代码 Dim moPageSelect As ClsPageSelect Sub AutoExec()
Set moPageSelect = New ClsPageSelect
Set moPageSelect.wdApp = Application
End Sub
'ClsPageSelect代码 Option Explicit Private Const PsToolName As String = "Page_Select Tool"
Public WithEvents wdApp As Word.Application
Attribute wdApp.VB_VarHelpID = -1
Private WithEvents ObjComb As Office.CommandBarComboBox
Attribute ObjComb.VB_VarHelpID = -1
Dim SelPageBar As CommandBar
Private WithEvents cmdToStart As CommandBarButton
Attribute cmdToStart.VB_VarHelpID = -1
Private WithEvents cmdNext As CommandBarButton
Attribute cmdNext.VB_VarHelpID = -1
Private WithEvents cmdPreview As CommandBarButton
Attribute cmdPreview.VB_VarHelpID = -1
Private WithEvents cmdToEnd As CommandBarButton
Attribute cmdToEnd.VB_VarHelpID = -1
Private WithEvents cmdAbout As CommandBarButton
Attribute cmdAbout.VB_VarHelpID = -1
Private WithEvents cmdClose As CommandBarButton
Attribute cmdClose.VB_VarHelpID = -1 Private Sub Class_Initialize()
Call checkBar
End Sub Private Sub checkBar()
On Error Resume Next
Dim BarExists As Boolean
Dim I As Integer
I = Application.CommandBars(PsToolName).Index
If Err.Number = 0 Then BarExists = True If BarExists Then
Set SelPageBar = Application.CommandBars(PsToolName)
Set cmdToStart = SelPageBar.Controls(1)
Set cmdPreview = SelPageBar.Controls(2)
Set ObjComb = SelPageBar.Controls(3)
Set cmdNext = SelPageBar.Controls(4)
Set cmdToEnd = SelPageBar.Controls(5)
Set cmdAbout = SelPageBar.Controls(6)
Set cmdClose = SelPageBar.Controls(7)
SelPageBar.Visible = True
Else
Call AddPsBar
End If End Sub
Private Sub cmdAbout_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdAbout事件
MsgBox "Product of Button" & Chr(13) & Chr(13) _
& "欢迎使用快速选择指定页工具!" & Chr(13) _
& "请多多指正!" & Chr(13) & Chr(13) _
& "作者:Button" & Chr(13) _
& "Version:Demo" & Chr(13) _
& "发布日期:2005-6", vbOKOnly, "Free Tools for Excel—Page Select"
End Sub Private Sub cmdClose_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdClose事件
On Error Resume Next
CommandBars("Page_Select").Delete
End Sub Private Sub cmdNext_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdNext事件
Application.Browser.Next
End Sub Private Sub cmdPreview_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdPreview事件
Application.Browser.Previous
End Sub Private Sub cmdToEnd_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdToEnd事件
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Name:=GetPageNumber
End Sub Private Sub cmdToStart_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean) 'cmdToStart事件
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Name:="1"
End Sub Private Sub ObjComb_Change(ByVal Ctrl As Office.CommandBarComboBox)
Dim stComboText As String
If Ctrl.Text = "" Then Exit Sub
stComboText = Left(Ctrl.Text, Len(Ctrl.Text) - 2)
stComboText = Right(stComboText, Len(stComboText) - 2)
Call SkipPageGo(stComboText, "CombpBoxText")
End Sub Private Sub AddPsBar() '添加菜单
Set SelPageBar = Application.CommandBars.Add(Name:=PsToolName, Position:=msoBarTop, Temporary:=True) '
Set cmdToStart = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=1)
With cmdToStart
.Tag = "第一页"
.FaceId = 154
.TooltipText = .Tag
.BeginGroup = True
End With
Set cmdPreview = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=2)
With cmdPreview
.Tag = "上一页"
.FaceId = 155
.TooltipText = .Tag
End With
Set ObjComb = SelPageBar.Controls.Add(Type:=msoControlComboBox, ID:=1, Before:=3)
With ObjComb
.BeginGroup = True
.Width = 70
.Style = msoComboLabel
ShowPages
End With
Set cmdNext = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=4)
With cmdNext
.Tag = "下一页"
.FaceId = 156
.TooltipText = .Tag
.BeginGroup = True
End With
Set cmdToEnd = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=5)
With cmdToEnd
.Tag = "最后一页"
.FaceId = 157
.TooltipText = .Tag
End With
Set cmdAbout = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=6)
With cmdAbout
.Tag = "关于"
.TooltipText = .Tag
.FaceId = 984
.BeginGroup = True
End With
Set cmdClose = SelPageBar.Controls.Add(Type:=msoControlButton, Before:=7)
With cmdClose
.Tag = "关闭"
.TooltipText = .Tag
.FaceId = 840
.BeginGroup = True
End With
SelPageBar.Visible = True
SelPageBar.Protection = msoBarNoCustomize
End Sub
Private Sub ShowPages() '在COMBOX显示页码
Application.ScreenUpdating = False
On Error Resume Next
Dim PageItem As Integer
With ObjComb
If .ListCount > 0 Then .Clear
For PageItem = 1 To GetPageNumber
.AddItem "第 " & PageItem & " 页", PageItem
Next PageItem
.DropDownLines = 10
If PageItem <= 11 Then
.DropDownWidth = 80
Else
.DropDownWidth = 64
End If
.ListIndex = GetActivePage
End With
Application.ScreenUpdating = True End Sub
Private Sub ShowPages1() '在COMBOX显示页码
On Error Resume Next
ObjComb.ListIndex = GetActivePage
End Sub Private Function GetPageNumber() As Integer '获得文档的总页码
GetPageNumber = Selection.Information(wdNumberOfPagesInDocument)
End Function Private Function GetActivePage() As Integer '获得当前页的页码
GetActivePage = Selection.Information(wdActiveEndPageNumber)
End Function
Private Sub SkipGo() '页码跳转
Dim GoPage As String
GoPage = SelPageCtl.Text
Call SkipPageGo(GoPage, "EditText")
End Sub
Private Sub SkipPageGo(SkipPage As String, mType As String) '页码跳转到
On Error Resume Next
Select Case mType
Case "ComboBoxText"
SkipPage = SkipPage
Case "EditText" If (Not IsNumeric(Val(SkipPage)) Or IsNull(SkipPage)) Then
MsgBox "输入错误,非数字页码或输入为空", vbOKOnly, "Page_Select Tool"
Exit Sub
Else
SkipPage = CStr(Int(SkipPage))
End If
End Select
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=SkipPage
End Sub
Private Sub wdApp_DocumentBeforeClose(ByVal Doc As Document, Cancel As Boolean) End Sub Private Sub wdApp_DocumentChange()
ShowPages
End Sub
Private Sub wdApp_DocumentOpen(ByVal Doc As Document)
Call checkBar
End Sub Private Sub wdApp_NewDocument(ByVal Doc As Document)
Call checkBar
End Sub
Private Sub wdApp_WindowActivate(ByVal Doc As Document, ByVal Wn As Window)
Call checkBar End Sub
Private Sub wdApp_WindowSelectionChange(ByVal Sel As Selection)
ShowPages End Sub Private Sub wdApp_Quit()
On Error Resume Next
Set ObjComb = Nothing
Set wdApp = Nothing
CommandBars("Page_Select").Delete End Sub Private Sub Class_Terminate()
On Error Resume Next
Set ObjComb = Nothing
Set wdApp = Nothing
CommandBars("Page_Select").Delete
End Sub
| 
楼主: button
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2005-2-13 00:07
