[原创] 如何用VB6的COM外接程序定制word2007功能区[4-24更新代码]

Option Explicit
Dim oWD As Object
Implements IRibbonExtensibility2 '添加对 IRibbonExtensibility 接口的引用

'启动
Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
Set oWD = Application
MsgBox "我的com加载项已经成功加载！"
End Sub

'实现IRibbonExtensibility接口的唯一成员 GetCustomUI，此过程调用 GetRibbonXML 方法，正如其名称所示，
'该方法将自定义 XML 返回到 GetCustomUI 方法，后者然后将自定义 XML 添加到功能区用户界面以便在加载外接程序时实现它。
Public Function IRibbonExtensibility_GetCustomUI(ByVal RibbonID As String) As String
      IRibbonExtensibility_GetCustomUI = GetRibbonXML()
End Function

'添加 XML 自定义标记代码
Public Function GetRibbonXML() As String
   Dim sRibbonXML As String

    sRibbonXML = "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"" >" & _
                "<ribbon>" & _
                "<tabs>" & _
                "<tab id=""CustomTab"" label=""sanjie"">" & _
                "<group id=""SampleGroup"" label=""Sample Group"">" & _
                "<button id=""Button"" label=""Insert Name"" size=""large"" imageMso=""HappyFace"" onAction=""InsertCompanyName"" />" & _
                "</group >" & _
                "</tab>" & _
                "</tabs>" & _
                "</ribbon>" & _
                "</customUI>"
   
   GetRibbonXML = sRibbonXML
   
   End Function

'控件回调的过程
Public Sub InsertCompanyName(ByVal control As IRibbonControl)
   ' Inserts the specified text at the beginning of a range.
   Dim MyText As String
   Dim MyRange As Object
   Set MyRange = oWD.ActiveDocument.Range
   MyText = "http://www.excelhome.net"
   ' Inserts text at the beginning
   ' of the active document.
   MyRange.InsertBefore (MyText)
End Sub

Option Explicit

Private oWD As Word.Application
Private WithEvents objButton1 As Office.CommandBarButton
Private WithEvents objButton2 As Office.CommandBarButton
Private WithEvents objButton3 As Office.CommandBarButton

Implements IRibbonExtensibility '添加对 IRibbonExtensibility 接口的引用

'========================================================================
  ''启动时执行的任务
'========================================================================

Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
Set oWD = Application
Select Case oWD.Version
      Case "12.0"
        MsgBox "你正使用的版本是Office 12"
      Case "11.0"
        MsgBox "你正使用的版本是Office 11"
        Call CreateMenu
      Case Else
        MsgBox oWD.Version
        Call CreateMenu
End Select
        
End Sub


'========================================================================
  '移除时执行的任务
'========================================================================
Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
  Call DeleteMenu
  Set objButton1 = Nothing
  Set objButton2 = Nothing
  Set objButton3 = Nothing
  Set oWD = Nothing
End Sub


'========================================================================
  ''实现IRibbonExtensibility接口的唯一成员 GetCustomUI，此过程调用 GetRibbonXML 方法，正如其名称所示，
'该方法将自定义 XML 返回到 GetCustomUI 方法，后者然后将自定义 XML 添加到功能区用户界面以便在加载外接程序时实现它。
'========================================================================
Public Function IRibbonExtensibility_GetCustomUI(ByVal RibbonID As String) As String
      IRibbonExtensibility_GetCustomUI = GetRibbonXML()
End Function


'========================================================================
  '添加 XML 自定义标记代码
'========================================================================

Public Function GetRibbonXML() As String
   Dim sRibbonXML As String

    sRibbonXML = "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"" >" & _
                "<ribbon>" & _
                "<tabs>" & _
                "<tab id=""CustomTab"" label=""sanjie"">" & _
                "<group id=""SampleGroup"" label=""Sample Group"">" & _
                "<button id=""Button"" label=""Insert Name"" size=""large"" imageMso=""HappyFace"" onAction=""InsertCompanyName"" />" & _
                "</group >" & _
                "</tab>" & _
                "</tabs>" & _
                "</ribbon>" & _
                "</customUI>"
   
   GetRibbonXML = sRibbonXML
   
End Function


'========================================================================
  ''控件回调的过程
'========================================================================

Public Sub InsertCompanyName(ByVal control As IRibbonControl)
   ' Inserts the specified text at the beginning of a range.
   Dim MyText As String
   Dim MyRange As Object
   Set MyRange = oWD.ActiveDocument.Range
   MyText = "http://www.excelhome.net"
   ' Inserts text at the beginning
   ' of the active document.
   MyRange.InsertBefore (MyText)
End Sub


'========================================================================
  '创建2003菜单
'========================================================================

Private Sub CreateMenu()

    Dim NewMenu As Office.CommandBarPopup
   
    Call DeleteMenu
        
    Set NewMenu = oWD.CommandBars("Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)

    With NewMenu
        .Caption = "sanjie"
       Set objButton1 = .Controls.Add(Type:=msoControlButton)
           With objButton1
              .Caption = "输入信息"
              .FaceId = 23
              .Tag = "Button1"
           End With
   
       Set objButton2 = .Controls.Add(Type:=msoControlButton)
          With objButton2
              .Caption = "显示当前Word版本"
              .FaceId = 116
              .Tag = "Button2"
          End With
   
      Set objButton3 = .Controls.Add(Type:=msoControlButton)
         With objButton3
              .Caption = "关于..."
             .BeginGroup = True
             .FaceId = 984
             .Tag = "Button3"
         End With
    End With
End Sub

'========================================================================
  '删除菜单2003
'========================================================================

Private Sub DeleteMenu()
    On Error Resume Next
    'CommandBars(1).Reset
    oWD.CommandBars("Menu Bar").Controls("sanjie").Delete
End Sub

'========================================================================
  '按钮1的动作
'========================================================================

Private Sub objButton1_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
   Dim MyText As String
   Dim MyRange As Object
   Set MyRange = oWD.ActiveDocument.Range
   MyText = "http://www.excelhome.net"
   MyRange.InsertBefore (MyText)
End Sub

'========================================================================
  '按钮2的动作
'========================================================================
Private Sub objButton2_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
   MsgBox oWD.Version
End Sub

'========================================================================
  '按钮3的动作
'========================================================================

Private Sub objButton3_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
   MsgBox "三戒制作！", vbInformation, Title:="ok"
End Sub

原帖由 wjhere 于 2009-4-23 18:45 发表
谢谢分享，请教三戒兄，IRibbonExtensibility接口的问题，我第一次接触，不知有什么作用，是为了实现在word2007中功能区的定制，还是别的功能？能否详细说明？
在2003中测试 ，不知三戒兄注意到没有，您的加载项存在 ...