DLL封装的自定义菜单怎样调用宏 - 编程论坛

#2

multiple19022008-10-13 21:48

算了。

#3

Joforn2008-10-14 08:50

没听明白楼主你想问什么

#4

sdhtli2008-10-16 09:13

附件上传了请各位老师看看

#5

Joforn2008-10-16 11:40

[bo][un]Joforn[/un][/bo]回复[bo][un]sdhtli[/un] 在 2008-10-13 20:43 的发言：[/bo]

程序代码：

Private JXMBAR As Object
Private WithEvents Caishan As Sub Class_Initialize()
    Dim WJT As Object

    On Error Resume Next
    Set WJT = GetObject(, "Excel.Application")

    Dim JXMBAR As If WJT Is Nothing Then
      MsgBox "获取Application对象出错！"
    Else
      For Each JXMBAR In JXMBAR.Name = "望江婷的工具" Then ("望江婷的工具").Delete
      Next

      (Name:="望江婷的工具").Visible = True
      ("望江婷的工具").Position = msoBarTop

      Set Caishan = ("望江婷的工具").Controls.Add(Type:=msoControlButton)
      With Caishan
        .BeginGroup = True   '分隔线
        .Caption = "删除数据(&D)"
        .FaceId = 9404
        .Style = msoButtonIconAndCaptionBelow
        .ToolTipText = "删除当前工作表的数据"
     End With
    End If
End Sub

Private Sub Class_Terminate()
  On Error Resume Next
  JXMBAR.Delete
End Sub

Private Sub Caishan_Click(ByVal Ctrl As , CancelDefault As Boolean)
  Dim xlapp As Object, xlbok As Object, xlsht1 As Object

  On Error Resume Next

  Set xlapp = GetObject(, "Excel.Application")  '取得Excel实例[/color]
  Set xlbok = xlapp.ActiveWorkbook              '取得Excel实例下活动工作簿[/color]
  If MsgBox("确实要清除现有的数据，重新使用吗？", vbInformation + vbYesNo, "警告") = vbYes Then xlbok.Sheets("收支").Range("A3：E65536").Formula = ""
End Sub

[[it] 本帖最后由 Joforn 于 2008-10-16 11:42 编辑 [/it]]

#6

Joforn2008-10-16 11:50

程序代码：

'对了，把你的Excel中的程序也要修改一下。改成下面的就行了。
Private QQQ As Object

Private Sub Workbook_BeforeClose(Cancel As Boolean) '代码注册
  Set QQQ = Nothing
  Shell "Regsvr32 /u /s " & Chr(34) & ThisWorkbook.Path & "\caidan.dll" & VBA.Chr(34), vbHide
End Sub

Private Sub Workbook_Open() '代码引用
  Shell "Regsvr32 /s " & Chr(34) & ThisWorkbook.Path & "\caidan.dll" & VBA.Chr(34), vbHide
  Set QQQ = New yyy
End Sub

Private Sub Workbook_Deactivate()
  On Error Resume Next
  ("望江婷的工具").Delete
End Sub

[bo]以上代码经过测试,VB6+Office2003[/bo]

#7

sdhtli2008-10-16 13:35

谢谢Joforn版主，版主就是版主，你太棒了，高超！就是这个效果，但是我还是不明白，你是怎么在VB中引用的下面的宏，现在自定义菜单就一个，如果再增加一个菜单在执行另一个宏又怎么引用呢？我太菜，能不能再教教我呢？

#8

Joforn2008-10-16 13:38

Private WithEvents Caishan As '定义一个按钮，Name为Caishan
Private WithEvents Command1 As '定义一个按钮，Name为Command1

#9

sdhtli2008-10-16 13:41

谢谢版主，我去你的博客了，你还是位帅哥呢

#10

Joforn2008-10-16 13:47

你要做几个按钮，就定义几个，然后再一一生成按钮对象并赋值。
最后在类中的按钮事件中写相应的处理代码就行了。
其实你只要注意下面的两条代码就行了。

Private WithEvents Caishan As '有了这一条，我们在写代码时就可以像使用普通控件一个为这个按钮写事件处理过程(在代码编辑状态下的下拉列表就可以看到你定义的按钮名)
Set Caishan = ("望江婷的工具").Controls.Add(Type:=msoControlButton) '定义Caishan按钮为新Add的按钮对象

Private Sub Caishan_Click(ByVal Ctrl As , CancelDefault As Boolean)
'选择代码编辑器的下拉列表就可以自动生成这个过程，你只要在这里写相应的处理过程就OK了。
End Sub

#11

dasadada2014-06-07 15:46

做个记号

#12

dasadada2014-06-07 15:51

Private Sub Workbook_BeforeClose(Cancel As Boolean)
("我的工具栏").Delete
End Sub

Private Sub Workbook_Open()
ActiveSheet.Shapes("Picture 1").Copy
(Name:="我的工具栏").Visible = True
("我的工具栏").Controls.Add Type:=msoControlButton, ID:=2950, Before:=1
("我的工具栏").Controls(1).OnAction = "jj"
("我的工具栏").Controls(1).PasteFace
("我的工具栏").Position = msoBarTop

End Sub

#13

dasadada2014-06-07 15:57

Sub 自定义工具栏()

    Dim i%, r%, j%   '循环变量,最大行'
    Dim icoPath As String    '图标路径'
    Dim btn As CommandBarButton    '按钮
    Dim bt As String, gjl$    '标题,工具栏'
    Dim arr, brr, crr, drr
    icoPath = ThisWorkbook.path & "\tool\tb\"    '图片路径=这个工作薄路径+\tool\ico\'

    arr = ThisWorkbook.Sheets("清单").UsedRange
    '--------------------------------------------------
    Dim Toolbar As CommandBar, myVal$   '工具栏'临时变量
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")    '创建字典对象
    Set regex1 = CreateObject("VBSCRIPT.REGEXP")    'RegEx为建立正则表达式
    With regex1
        .Global = True    '设置全局可用
        .Pattern = ".+"
    End With
    '--------------------------------------------------
    On Error Resume Next
    Application.ScreenUpdating = False
    ("MySoSo").Delete    '删除mysoso工具栏'
    Set Toolbar = ("MySoSo", msoBarTop)    '创建一个名为mysoso的工具栏,位置放在最上面'

    '--------------------------------------------------
    With Toolbar
        .Protection = msoBarNoResize    '防止用户访问“添加或删除按钮”菜单
        .Visible = True    '显示工具栏'
        .Position = msoBarTop    '设置命令栏的位置为顶部'
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)    '新建一个按钮'
            .Caption = "★自己定制★"    '按钮名称'
            .OnAction = "自定义菜单"    '按钮执行的命令'
            .FaceId = 609    '3198    '按钮图标'
            .BeginGroup = True    '显示分割线'
            .Style = msoButtonIconAndCaptionBelow    '样式等于图片+文本,文本在下面图标在上面'
            .TooltipText = "把自己常用的工具通过自定义放到工具栏中"    '鼠标停放时显示的文本'
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "常用文件"    '按钮名称'
            .OnAction = "常用的文件"    '按钮执行的命令'
            .FaceId = 2105    '按钮图标'
            .BeginGroup = True    '显示分割线'
            .Style = msoButtonIconAndCaptionBelow    '样式等于图片+文本,文本在下面图标在上面'
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "常用路径"    '按钮名称'
            .OnAction = "常用的路径"    '按钮执行的命令'
            .FaceId = 1660    '按钮图标'
            '.BeginGroup = True    '显示分割线'
            .Style = msoButtonIconAndCaptionBelow    '样式等于图片+文本,文本在下面图标在上面'
        End With
        '--------------------------------------------------
        If GetSetting("PUPNAME", "APPNAME", "自定义工具栏") <> "" Then    '如果注册表中有自定义工具栏项'
            gjl = GetSetting("PUPNAME", "APPNAME", "自定义工具栏")    '获取注册表中自定义工具栏的值'
            Set c = regex1.Execute(gjl)
            For j = 0 To c.Count - 1
                d(c.Item(j).Value) = 0
            Next j
            '--------------------------------------------------
        Else
            brr = Array("科室定制", "智能文本", "智能加边框", "自动筛选", "相同值标色", "删除重复行", "数据查询", "颜色筛选")
            For j = 0 To UBound(brr)
                d(brr(j)) = 0
            Next j
            SaveSetting "PUPNAME", "APPNAME", "自定义工具栏", Join(brr, vbLf)
        End If
        '--------------------------------------------------
        N = UBound(arr)    '获取功能表格最大行'
        For j = 2 To N
            If d.exists(arr(j, 3)) Then   '如果单元格中的值能在gjl中找到
                bt = arr(j, 3)
                '--------------------------------------------------
                Set btn = .Controls.Add(msoControlButton, , , , True)    '在mysoso工具栏上创建一个按钮'
                With btn
                    .Caption = bt    '按钮名称'
                    .OnAction = bt    '按钮执行的命令'
                    .TooltipText = "【" & bt & "】" & arr(j, 4)  '鼠标停放时显示的文本'
                    .BeginGroup = True    '显示分割线'
                    .Style = msoButtonIconAndCaptionBelow    '样式等于图片+文本,文本在下面图标在上面'
                    .Picture = LoadPicture(icoPath & bt & ".jpg")    '获取路径下的图片作为图标'
                End With
                '--------------------------------------------------
            End If
        Next j
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "SoSo工具"    '按钮名称'
            .OnAction = "显示界面"    '按钮执行的命令'
            .FaceId = 266    '按钮图标'
            .BeginGroup = True    '显示分割线'
            .Style = msoButtonIconAndCaptionBelow    '样式等于图片+文本,文本在下面图标在上面'
        End With
        '--------------------------------------------------
    End With
    Application.ScreenUpdating = True
    Set Toolbar = Nothing
End Sub

#14

dasadada2014-06-07 15:59

Sub 右键菜单()
    With ("Cell")
        .Reset
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton, before:=1)
            .Caption = "SoSo工具(&V)"
            .FaceId = 266
            .OnAction = "显示界面"
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton, before:=2)
            .Caption = "智能加边框(&Z)"
            .OnAction = "智能加边框"
            .TooltipText = "无需选定单元格即把所用处加上边框"
            .FaceId = 800
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton, before:=3)
            .Caption = "自动筛选(&Q)"
            .OnAction = "自动筛选"
            .TooltipText = "在当前列筛选当前单元格"
            .FaceId = 458
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton, before:=4)
            .Caption = "多条件筛选"
            .OnAction = "多条件筛选"
            .TooltipText = "在当前列筛选当前单元格"
            .FaceId = 628
            '  .BeginGroup = True    '添加分组线
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton, before:=5)
            .Caption = "多表格计算"
            .OnAction = "多表格计算"
            .TooltipText = "多个表格的相同单元格进行计算"
            .FaceId = 1548
            .BeginGroup = True    '添加分组线
        End With

        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "筛选单元格颜色(ctrl+Q取消筛选)"
            .BeginGroup = True    '添加分组线
            .OnAction = "筛选单元格颜色"
            .TooltipText = "在当前列筛选和当前单元格相同颜色的单元格,再次点击取消筛选"
            .FaceId = 3077
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "筛选字体颜色(ctrl+Q取消筛选)"

            .OnAction = "筛选字体颜色"
            .TooltipText = "在当前列筛选和当前单元格相同字体颜色的单元格,再次点击取消筛选"
            .FaceId = 2611
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlButton)
            .Caption = "按指定内容筛选"
            .OnAction = "按指定内容筛选"
            .TooltipText = "在当前列筛选和包含指定内容的的单元格。"
            .FaceId = 499
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlPopup)
            .Caption = "选择格式相似的单元格"
            .BeginGroup = True    '添加分组线
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "填充颜色相同"
                ' .BeginGroup = True    '添加分组线
                .OnAction = "选取填充颜色相同"
                .FaceId = 3077
            End With
            '--------------------------------------------------
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "字体颜色相同"
                ' .BeginGroup = True    '添加分组线
                .OnAction = "选取字体颜色相同"
                .FaceId = 2611
            End With
            '--------------------------------------------------
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "单元格数字格式相同"
                '  .BeginGroup = True    '添加分组线
                .OnAction = "选取单元格数字格式相同"
                .FaceId = 2773
            End With
            '--------------------------------------------------
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "单元格内容相同"
                '  .BeginGroup = True    '添加分组线
                .OnAction = "选择内容相同的单元格"
                .FaceId = 720
            End With
            '--------------------------------------------------
            With .Controls.Add(Type:=msoControlButton)
                .Caption = "更多选择..."
                .BeginGroup = True    '添加分组线
                .OnAction = "按条件选取单元格"
                .FaceId = 2761
            End With
        End With
        '--------------------------------------------------
        With .Controls.Add(Type:=msoControlPopup)
            .Caption = "美化表格(&G)"
            ' .OnAction = "边框样式"
            .BeginGroup = True    '添加分组线
            .TooltipText = "当前选区设置一种边框样式"
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "美化表格"
                .OnAction = "美化表格"
                .FaceId = 635
            End With
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "隔行标色"
                .OnAction = "隔行标色"
                .FaceId = 692
            End With
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "单元格3D效果"
                .OnAction = "单元格3D效果"
                .FaceId = 282
            End With
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "隐藏网格线"
                .OnAction = "隐藏网格线"
                .FaceId = 485
            End With
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "工作表其他设置"
                .OnAction = "工作表快捷设置"
                .FaceId = 362
            End With
            '--------------------------------------------------
            With .Controls.Add(msoControlButton)
                .Caption = "录入当前日期用时间（Ctrl+Shift+Z）"
                .OnAction = "录入当前日期用时间"
                .BeginGroup = True    '添加分组线
                .FaceId = 265
            End With
            With .Controls.Add(msoControlButton)
                .Caption = "时间格式设置"
                .OnAction = "时间格式设置"
                .FaceId = 209
            End With
            '--------------------------------------------------
        End With

    End With
End Sub

#15

dasadada2014-06-07 16:01

Dim oWD As Object
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
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. >" & _
                "<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.
   ' Inserts text at the beginning
   ' of the active document.
   MyRange.InsertBefore (MyText)
End Sub

#16

dasadada2014-06-07 16:07

Private JXMBAR As Object
Private WithEvents Caishan As

Private Sub Class_Initialize()
    Dim WJT As Object

    On Error Resume Next
    Set WJT = GetObject(, "Excel.Application")

    Dim JXMBAR As
    If WJT Is Nothing Then
      MsgBox "获取Application对象出错！"
    Else
      For Each JXMBAR In
        If JXMBAR.Name = "望江婷的工具" Then ("望江婷的工具").Delete
      Next

      (Name:="望江婷的工具").Visible = True
      ("望江婷的工具").Position = msoBarTop

      Set Caishan = ("望江婷的工具").Controls.Add(Type:=msoControlButton)
      With Caishan
        .BeginGroup = True   '分隔线
        .Caption = "删除数据(&D)"
        .FaceId = 9404
        .Style = msoButtonIconAndCaptionBelow
        .ToolTipText = "删除当前工作表的数据"
     End With
    End If
End Sub

Private Sub Class_Terminate()
  On Error Resume Next
  JXMBAR.Delete
End Sub

Private Sub Caishan_Click(ByVal Ctrl As , CancelDefault As Boolean)
  Dim xlapp As Object, xlbok As Object, xlsht1 As Object

  On Error Resume Next

  Set xlapp = GetObject(, "Excel.Application")  '取得Excel实例[/color]
  Set xlbok = xlapp.ActiveWorkbook              '取得Excel实例下活动工作簿[/color]
  If MsgBox("确实要清除现有的数据，重新使用吗？", vbInformation + vbYesNo, "警告") = vbYes Then xlbok.Sheets("收支").Range("A3：E65536").Formula = ""
End Sub

#17

fddfaf2014-06-07 16:20

不错！！！

#18

vc3212014-06-29 15:22

做个记号！！！

#19

adffdda2016-05-17 23:04

不错，学习了

#20

adffdda2016-05-17 23:05

不错，学习了

#21

adffdda2016-05-17 23:05

不错，学习了

#22

adffdda2016-05-17 23:05

不错，学习了