VB6开发Excel任务窗格的例子(附制作过程与源代码) [复制链接]本帖最后由 xtanuihazfh 于 2011-9-3 18:44 编辑
哈哈,论坛好些人说用VB6不能创建任务窗格,但是我还是做出来了
请大家下载附件帮忙测试一下,点击安装即可(这个过程会把工程.ocx复制到windows\system32目录下
WIN7用户要先把工程.ocx复制到windows\system32目录下,然后以管理员权限启动CMD输入 REGSVR32.EXE 文件路径\MyAddin.dll
VB6创建Excel自定义任务窗格.rar (0 Bytes, 下载次数: 503)
--------------------2011年9月2日上传制作过程,请大家先照着做一下,源码稍后再传--------------------------------------------------------------------
由于本帖是面向对于VBA,VB编程有一些基础的人,所以可能文字描述不多(借口,其实是懒得打字,大家凑和着看代码就行),基本上就是把代码COPY过来了,
另外这个只是测试用的代码,某些地方可能不太严谨,大家弃其糟粕,取其精华即可,哈哈
--------------------2011年9月3日上传所有的东西,包含word版说明与源代码--------------------------------------------------------------------
用VB6为Excel创建自定义任务窗格
此前发过一篇用VSTO创建Excel任务窗格的例子与源码在
http://club.excelhome.net/thread-729365-1-1.html然而很多朋友如果可以的话,更愿意用VB6做,因为开发环境,兼容性等各方面的问题
在Excel的帮助中有这么一句话:
可以用任何支持 COM 并允许创建动态链接库 (DLL) 文件的语言创建自定义任务窗格。例如，Microsoft Visual Basic® 6.0、Microsoft Visual Basic .NET、Microsoft Visual C++®、Microsoft Visual C++ .NET 和 Microsoft Visual C#®。但是，Microsoft Visual Basic for Applications (VBA) 不支持创建自定义任务窗格。
但是相关的代码是C#的,尽管说可以用VB6.0创建OFFICE的自定义任务窗格,但是在网上这样的例子却是少之又少,所以在此介绍一下用VB6创建Excel自定义任务窗格的方法,由于本人用的是office 2007,所以顺带介绍了自定义功能区的东西
由于此帖子是主要演示如何创建任务窗格，所以只设置显示所有工作表与多工作簿查找功能
在创建任务窗格之前我们要先创建一个自定义控件,作为自定义窗格里面的唯一对象
一、创建自定义控件
1. 打开VB、6.0，在新建工程对话框中选择ActiveX控件
将工程名称修改为ExcelCTPTest
选择UserControl,在属性窗口中将其名称修改为TestControl
此时我们可以在控件上画上我们需要在任务窗格中使用到的控件，如果是仅为测试的话，放上一个按钮与一个文本框即可
在此处，我添加一个Tveeview控件，一个Image控件，一个Text控件，一个ListView控件，一个ImageList控件，作成如下布局，当然具体布局方式看个人习惯与爱好
然后呢，为控件设置适当的属性
TreeView1
属性名称
属性
LineStyle
1-tvwRootLines
ImageList
Imagelist1
Indentation
300
再往imagelist控件里面放入两张用于显示在treeview节点的图片
其它属性根据自己需要选择
2. 选择工程菜单中的引用命令，添加对Excel对象的引用
双击控件，输入以下代码
普通浏览复制代码
Option Explicit
Private ExcelApp As Excel.Application
Dim yy As Single
'处理控件大小与位置*******************************************************
Private Sub Image1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then yy = Y
End Sub
Private Sub Image1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim yyy As Single
If Button = 1 Then
yyy = Y - yy
If yy - Y > TreeView1.Height Or yy > (ListView1.Height) Then Exit Sub
TreeView1.Height = TreeView1.Height + yyy
Image1.Top = Image1.Top + yyy
Text1.Top = Text1.Top + yyy
ListView1.Top = ListView1.Top + yyy
ListView1.Height = ListView1.Height - yyy
End If
End Sub
Private Sub UserControl_Resize()
Dim iWidth As Long, iHeight As Long
iWidth = UserControl.ScaleWidth - 1
iHeight = UserControl.ScaleHeight / 2
On Error Resume Next
TreeView1.Move 0, 0, iWidth, iHeight - Image1.Height - Text1.Height
Image1.Width = iWidth
Image1.Top = TreeView1.Height
Text1.Width = iWidth
Text1.Top = Image1.Top + Image1.Height
ListView1.Move 0, Text1.Top + Text1.Height, iWidth, iHeight
End Sub
'内部控件事件*******************************************************
Private Sub UserControl_Initialize()
With ListView1
.View = lvwReport
.GridLines = True
.FullRowSelect = True
.HotTracking = True
.ColumnHeaders.Add , , "工作簿", 800, 0
.ColumnHeaders.Add , , "工作表", 800, 0
.ColumnHeaders.Add , , "单元格", 800, 0
.ColumnHeaders.Add , , "值", 800, 0
.ColumnHeaders.Add , , "公式", 1000, 0
End With
End Sub
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
If Node.Parent Is Nothing Then
ExcelApp.Workbooks(Node.Key).Activate
Else
With ExcelApp.Workbooks(Node.Parent.Key)
.Activate
.Worksheets(Node.Text).Select
End With
End If
End Sub
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
If Text1.Text = "" Then Exit Sub
If KeyCode = 13 Then
FindAllWorkBook Text1.Text
End If
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
With ExcelApp.Workbooks(Item.Text)
.Activate
.Worksheets(Item.ListSubItems(1)).Active
.Worksheets(Item.ListSubItems(1)).Range (Item.ListSubItems(2))
End With
End Sub
'控件的属性*******************************************************
'属性名称: Application
'属性用途: 获取与返回正在使用控件的Excel应用程序对象
Public Property Let Application(NewExcelApp As Excel.Application)
Set ExcelApp = NewExcelApp
End Property
Public Property Get Application() As Excel.Application
Set Application = ExcelApp
End Property
'控件的方法*******************************************************
'填充树型控件
Public Sub FillTvw()
Dim WB As Workbook, WS As Worksheet
If ExcelApp Is Nothing Then Exit Sub
With TreeView1.Nodes
.Clear
For Each WB In ExcelApp.Workbooks
.Add(, , WB.Name, WB.Name, 1).Expanded = True
For Each WS In WB.Sheets
.Add WB.Name, tvwChild, WB.Name & "_" & WS.Name, WS.Name, 2
Next
Next
End With
End Sub
'搜索所有工作簿
Public Sub FindAllWorkBook(FindStr As String)
Dim WB As Workbook, WS As Worksheet
Dim Item As ListItem, FindRng As Range, FirstAddress As String, RngFormula As String
If ExcelApp Is Nothing Then Exit Sub
With ListView1.ListItems
.Clear
For Each WB In ExcelApp.Workbooks
For Each WS In WB.Sheets
Set FindRng = WS.Cells.Find(FindStr)
If Not FindRng Is Nothing Then
FirstAddress = FindRng.Address
Do
Set Item = .Add
Item.Text = WB.Name
Item.SubItems(1) = WS.Name
Item.SubItems(2) = FindRng.Address
Item.SubItems(3) = FindRng.Value
RngFormula = FindRng.Formula
If Left(RngFormula, 1) <> "=" Then RngFormula = ""
Item.SubItems(4) = RngFormula
Set FindRng = WS.Cells.FindNext(FindRng)
Loop While Not FindRng Is Nothing And FindRng.Address <> FirstAddress
End If
Next
Next
End With
End Sub
3.选择文件菜单上的生成命令，生成我们需要的控件
可自行选择目录
² 二、根据我们上面做好的控件创建任务窗格
1. 关闭保存我们之前的控件工程，重新启动VB，选择外接程序
移除其中的窗体与设计器中的代码
设置设计器中的属性，如下图所示
关闭设置器窗口
2. 在创建任务窗格之前，我们先在Excel功能区创建一个选项卡及按钮来控件显示隐藏任务窗格
选择此菜单项，找到VB6资源管理器，如图设置
然后外接程序管理器窗口，如果你已经有资源编辑器那么则不需此项设置
在项目工程资源管理器窗口中右键添加资源文件，选择保存位置与名称，创建一个新的资源文件
然后选择添加自符串表格，在标识号为101的字符串表中复制进去以下用于自定义功能区的xml代码
普通浏览复制代码
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon>
<tabs>
<tab id="TaskPaneTab" label="任务窗格">
<group id="Group1" label="VB6自定义任务窗格">
<toggleButton id="Button" label="显示任务窗格" size="large" imageMso="FileServerTransferDatabase"/>
</group >
</tab>
</tabs>
</ribbon>
</customUI>
3. 保存资源文件，关闭资源管理器，回到加载项设计器的代码窗口，添加以下代码到模块顶部
Implements IRibbonExtensibility
在左侧通用组合框中选择 IRibbonExtensibility，即可生成以下函数过程
Private Function IRibbonExtensibility_GetCustomUI(ByVal RibbonID As String) As String
IRibbonExtensibility_GetCustomUI = LoadResString(101) ‘用于从资源文件中载入自定义功能区的xml代码
End Function
现在按下F5，打开Excel，是否已经有了新的功能区选项卡了呢
选择工程菜单下的引用命令，引用Excel对象以及我们之前创建的控件
接下来我们添加模块全部的代码
普通浏览复制代码
Implements IDTExtensibility2
Implements ICustomTaskPaneConsumer
Implements IRibbonExtensibility
Private Sub ICustomTaskPaneConsumer_CTPFactoryAvailable(ByVal CTPFactoryInst As Office.ICTPFactory)
‘注意此处的ExcelCTPTest为我们之前创建的控件的工程名称TestControl为控件名称
Set MyCustomTaskPane = CTPFactoryInst.CreateCTP("ExcelCTPTest.TestControl", "测试自定义任务窗格")
MyCustomTaskPane.DockPosition = msoCTPDockPositionLeft
Set MyTestControl = MyCustomTaskPane.ContentControl
MyTestControl.Application = MyExcel
MyCustomTaskPane.Visible = True
End Sub
Private Sub IDTExtensibility2_OnAddInsUpdate(custom() As Variant)
'占位
End Sub
Private Sub IDTExtensibility2_OnBeginShutdown(custom() As Variant)
'占位
End Sub
Private Sub IDTExtensibility2_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
Set MyExcel = Application
Set MyExcelApp = New ExcelApp
MyExcelApp.Attech Application
End Sub
Private Sub IDTExtensibility2_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
Set MyExcel = Nothing
Set MyExcelApp = Nothing
End Sub
Private Sub IDTExtensibility2_OnStartupComplete(custom() As Variant)
'占位
End Sub
Sub ShowTaskPane(control As IRibbonControl, pressed As Boolean)
MyCustomTaskPane.Visible = pressed
End Sub
Private Function IRibbonExtensibility_GetCustomUI(ByVal RibbonID As String) As String
IRibbonExtensibility_GetCustomUI = LoadResString(101)
End Function
4. 添加一个标准模块，加入以下全局变量的声明
Public MyExcel As Excel.Application
Public MyCustomTaskPane As CustomTaskPane
Public MyExcelApp As ExcelApp
Public MyTestControl As TestControl
复制代码
添加一个类模块，修改其名称为ExcelApp，添加以下代码
普通浏览复制代码
Private WithEvents XlApp As Excel.Application
Public Sub Attech(Application As Excel.Application)
Set XlApp = Application
End Sub
Private Sub XlApp_NewWorkbook(ByVal Wb As Excel.Workbook)
MyTestControl.FillTvw
End Sub
Private Sub XlApp_WorkbookActivate(ByVal Wb As Excel.Workbook)
MyTestControl.FillTvw
End Sub
Private Sub XlApp_WorkbookDeactivate(ByVal Wb As Excel.Workbook)
MyTestControl.FillTvw
End Sub
Private Sub XlApp_WorkbookOpen(ByVal Wb As Excel.Workbook)
MyTestControl.FillTvw
End Sub
现在按下F5调试工程，测试代码是否我们所设想的那样运行，
完成后的图片
