创建ActiveX接口移植Excel工作表

　　Visual Basic 5.0中的简单ActiveX DLL，从而使用户从Northwind数据库中获得一系列表单。只要选择表单，就可以移植包含Access数据的office/9.shtml'' target=''_blank'' class=''article''>Excel工作表。

　　Excel工作表，该表包含菜单项的定制代码，从而初始化ActiveX DLL。可执行程序，该程序可以发送上述工作簿，并可检查公用资源中ActiveX DLL的新版本，如果发现存在新版本，则拷贝并注册该DLL到用户的机器。

　　该方法的优点

　　我因为以下几个原因而喜欢该方法。一旦ActiveX DLL编译成功，它可以被任何ActiveX的兼容宿主程序调用，这意味着你能够在Microsoft Word、Internet Explorer或者大量的应用程序中使用它们。

　　不同于 Excel中的VBA编码，那些DLL一旦编译成功就再也不能为用户所修改，如果你想做一些与Excel相似的工作，就必须创建并发布相应的附加项。正如前面讨论的那样，只要进行简单的Visual Basic编程，用户机器上的DLL就能够轻易地被替换。这意味着一旦故障被发现，或者新版本开发成功，用户就可以直接升级，而再也不必经受安装整个应用程序的痛苦。

　　该方法的不足

　　最大的不足是需要在兼容宿主程序上调用该ActiveX DLL，如果你要移植Excel工作表或Word文档，那将不成问题。如果你要在自己编制的可执行程序或不可视的兼容宿主程序上调用该DLL，那么控制将变得比较困难，换句话说，此时采用标准的可执行程序作为接口是不适合的，最好的方法是为另一个应用程序提供接口。

　　设计DLL

　　为了创建接口，打开Visual Basic并创建一个标准的可执行项目，并将他存储在你所选定的ExcelDLL文件夹中。为了加入Excel引用，点击Project>References和Microsoft Excel 8.0 Object Library。双击Project Explorer中的缺省Form，并将之重新命名为frmMain，设定Form的标题为Open Northwind Tables，并且增加具有下列属性的控件：

　　为了创建Access数据库和Excel电子表格之间的接口，增加列表1的代码到Form中。

　　列表1：设计DLL,增加这些代码到Form中以创建接口。

注释：Declare the new class
Dim mcls_clsExcelWork As New clsExcelWork

Private Sub cmdOpenTable_Click()
注释：call the CreateWorksheet method of the clsExcelWork
注释：class.
mcls_clsExcelWork.CreateWorksheet
End Sub

Private Sub Form_Load()
注释：call the LoadListboxWithTables method. mcsl_clsExcelWork.LoadListboxWithTables
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set mcls_clsExcelWork = Nothing
End Sub

Private Sub lstTables_DblClick()
Mcls_clsExcelWork.CreateWorksheet
End Sub

　　增加标准的模块到项目中，并将下列代码加入到该模块中：

Sub Main()
End Sub

关闭该模块。

　　如果你从未创建过类模块，那么你就要认真对待，clsExcelWork是一个简单的类，工作一点儿也不困难。增加一个新的模块到项目中，并将之命名为clsExcelWork，同时在声明段中加入该类（列表2）。

　　列表2：clsExcelWork-增加新的类模块到项目中，然后在声明段中加入新类的代码。

Option Explicit
Private xlsheetname As Excel.Worksheet

Private xlobj As Excel.Workbook
Private ExcelWasNotRunning As Boolean

Private Declare Function FindWindow Lib "user32" Alias _
　　　　"FindWindowA" (ByVal lpClassName As String, ByVal _
　　　　 lpWindowName As Long) As Long

Private Declare Function SendMessage Lib "user32" Alias _
　　　　"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
　　　　 ByVal wParam As Long, ByVal lParam As Long) As Long
创建下述方法：

Public Sub RunDLL()
注释：called from the ActiveX container .
注释：this is the only public method .
frmMain.Show
End Sub

Friend Sub LoadListboxWithTables()
注释：Loads the listbox on the form with the name of 注释：five tables from the Northwind database.
With frmMain.lstTables
.AddItem "Categories"
.AddItem "Customers"
.AddItem "Employees"
.AddItem "Products"
.AddItem "Suppliers"
End With
End Sub

Private Sub GetExcel()
Dim ws

Set xlobj = GetObject(App.Path & "\DLLTest.xls")
xlobj.Windows("DLLTest.xls").Visible = True

If Err.Number <> 0 Then
ExcelWasNotRunning = True
End If
注释：clear Err object in case error occurred.
Err.Clear

注释：Check for Microsoft Excel . If Microsoft Excel is running ,
注释：enter it into the running Object table.

DetectExcel

注释：Clear the old worksheets in the workbook .
xlobj.Application.DisplayAlerts = False

For Each ws In xlobj.Worksheets
If ws.Name <> "Sheet1" Then
ws.Delete
End If
Next

xlobj.Application.DisplayAlerts = True
End Sub

Private Sub DetectExcel()
Const WM_USER = 1024
Dim hwnd As Long
注释：If Excel is running , this API call return its handle .
hwnd = FindWindow("XLMAIN", 0)
注释：0 means Excel isn’t running .
If hwnd = 0 Then
Exit Sub
Else 注释：Excel is running so use the SendMessage API function to
注释：enter it in the Running Object Table .
SendMessge hwnd, WM_USER + 18, 0, 0
End If
End Sub

Friend Sub CreateWorksheet()
Dim strJetConnString As String
Dim strJetSQL As String
Dim strJetDB As String
注释：Prepare Excel worksheet for the Querytable .
GetExcel
xlobj.Worksheets.Add
xlsheetname = xlobj.ActiveSheet.Name
xlobj.Windows("DLLTest.xls").Activate
注释：Modify strJetDB to point to your installation of Northwind.mdb.
strJetDB = "c:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb"

注释：Create a connection string.
strJetConnString = "ODBC;" & "DBQ=" & strJetDB & ";" & _
"Driver={Microsoft Access Driver (*.mdb)};"

注释：Create the SQL string
strJetSQL = "SELECT * FROM " & frmMain.lstTables.Text
注释：Create the QueryTable and populate the worksheet .
With xlobj.Worksheets(xlsheetname).QueryTables.Add(Connection:=strJetConnString, _
Destination:=xlobj.Worksheets(xlsheetname) _
.Range("A1"), Sql:=strJetSQL)
.Refresh (False)
End With
End Sub
　 设计工作簿

　　在你能够测试这些代码之前，你必须创建Excel工作簿，为了达到这个目的，打开Excel，并且将缺省的book1存储到自己的路径\DLLTest.xsl下，该路径是你以上创建的VB项目所在的路径。

　　在工作簿中，打开VBA编辑器并在Excel菜单中选择View>Toolbars>Visual Basic，在visual Basic工具条中点击编辑按钮。增加新模块到编辑器中，并输入下述代码（列表3）。

　　列表3：设计工作簿-增加新模块和下述代码。

Sub RunExcelDLL()
　 注释：Creates an instance of the new DLL and calls the main method .
　 Dim x As New ExcelDLL.clsExcelWork
　　 x.RunDLL
　 End Sub

Sub AddExcelDLLMenu()
注释：Adds a new menu item so the DLL can be started.
On Error Resume Next
Set myMenubar = CommandBars.ActiveMenuBar

With myMenubar
With .Controls("Northwind DLL")
.Delete
End With
End With

Set newMenu = myMenubar.Controls.Add _
(Type := msoControlPopup, Temporary :=True)
newMenu.Caption = "Northwind DLL"
Set ctr11 = newMenu.Controls.Add(Type := msoControlButton, _
Id:=1)
With ctrl1
.Caption = "Run Northwind DLL"
.Style = msoButtonCaption
.OnAction = "RunExcelDLL"
End With
End sub

双击Microsoft Excel Objects中的ThisWorkbook，并输入以下代码：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error resume Next
Set x = Nothing
End sub

Private Sub Workbook_Open()
AddExcelDLLMenu
End Sub

　　最后，保存Excel Workbook，此时不要试图运行该代码，因为DLL还没有创建且没有设置适当的引用。

　　创建并引用ActiveX DLL

　　为了创建ActiveX DLL，关闭Excel应用程序，返回到Visual Basic项目，并执行以下步骤：

　　从菜单中点击Project>Properties。

　　在Project Properties对话框中，选择ActiveX DLL作为项目的属性，并点击OK。在Project Name文本框中，输入ExcelDLL。点击Component标签并选中Project Compatibility。在底部的文本框中，输入ExcelDLL.dll，以此确保新的DLL与以前的版本兼容。

　　在Project Explorer中，点击名为clsExcelWork的类，并设置实例属性为5-MultiUse。

　　点击File菜单，并选择Make ExcelDLL.dll，为了简单起见，确认你将DLL保存在项目和工作表所在的文件夹中。

　　重新打开Excel工作簿，并打开VBA编辑器。

　　点击Tools>Reference。

　　在对话框中，点击Browse，并在ExcelDLL.dll创建时所在的文件夹中找到该文件，双击文件名。

　　保存工作簿。

　　关闭VBA编辑器和工作簿。

　　当你重新打开工作簿，你可以点击名为Northwind DLL的菜单，并选择Run Northwind DLL，这样将打开DLL接口，选择某个表格名，并点击Open Table按钮。如果所有的事情都处理得正确，DLL将移植你所选中的工作表中的数据。
　　 设计启动程序

　　需要冷静思考的是，用户是否需要打开特定的Excel工作表以访问该接口？如果你需要改变用户的接口时将会发生什么？你是否需要重新编制安装文件，是否需要与每一个用户取得联系，并使他们重新安装相应的应用程序，把ActiveX DLL自动地拷贝和注册到用户的机器上是否是一种好的方法？

　　可执行程序能够检查DLL而且在需要的时候更新并注册DLL，接着继续发送Execl并打开你所创建的工作簿，幸运的是，这是一种相当直接的过程。开始创建一个新个Visual basic项目并将之命名为RunExcelDLL,并删除缺省的Form，再增加一个新模块到basMain。增加下列代码到模块的声明段：

Option Explicit

Private ExcelWasNotRunning As Boolean
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String , ByVal _
lpWindowName As Long ) As long Private Declare Function RegMyServerObject Lib _
"ExcelDll.dll" Alias "DllRegisterServer" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long , ByVal _
LpszOp As String , ByVal lpszFile As String , ByVal _
LpszParams As String , ByVal lpszFile As String , ByVal _
FsShowCmd As Long ) As Long

增加列表4的代码到模块中。

列表4：编制启动程序--在模块中添加下列代码。

Private Function RegisterDLL() As Boolean
On Error GoTo Err_DLL_Not_Registered
Dim RegMyDLLAttempted As Boolean

‘Attempt to register the DLL.
RegMyServerObject
RegisterDLL = True
Exit Function

Err_DLL_Not_Registered:
‘Check to see if error 429 occurs .
If err.Number = 429 Then

‘RegMyDLLAttempted is used to determine whether an
‘attempt to register the ActiveX DLL has already been
‘attempted. This helps to avoid getting stuck in a loop if
‘the ActiveX DLL cannot be registered for some reason .

RegMyDLLAttempeted = True
MsgBox " The new version of ExcelDll could not be _
Registered on your system! This application will now _
terminate. ", vbCritical, "Fatal Error"
Else
MsgBox "The new version of ExcelDLL could not be _
Registered on your system. This may occur if the DLL _
is loaded into memory. This application will now _
terminate . It is recommended that you restart your _
computer and retry this operation.", vbCritical, _ "Fatal Error".
End If

RegisterDLL = False
End Function

Sub Main()
Dim x
If UpdateDLL = True Then
DoShellExecute (App.Path & "\DLLTest.xls")
‘ frmODBCLogon.Show vbModal
Else
MsgBox "The application could not be started !", _
VbCritical , "Error"
End If
End
End Sub

Sub DoShellExecute(strAppPAth As String)
On Error GoTO CodeError
Dim res
Dim obj As Object
res = ShellExecute(0, "Open", strAppPath, _
VbNullString, CurDir$, 1)
If res<32 Then
MsgBox "Unable to open DllTest application"
End If

CodeExit
Exit Sub
CodeError:
Megbox "The following error occurred in the procedure " & _
StrCodeName & Chr(13) & err.Number & " " & _
Err.Description, vbOKOnly, "Error Occurred"
GoTo CodeExit
End Sub

Function UpdateDLL() As Boolean
On Error GoTO err
Dim regfile
If CDate(FileDateTime(App.Path & "\Excel.dll")) <_
CDate(FileDateTime("C:\Temp\ExcelDLL.dll")) Then
If DetectExcel = True Then
MsgBox "Your version of ExcelDll needs to be updated, _
but Microsoft Excel is running. Please close Excel and _
restart this application so all files can be _
Replaced", vbOK, "Close Excel"
End
End If
If MsgBox("your version of ExcelDll is out of date, _
If you click on OK it will be replaced with the newest _
Version. Otherwise the application will terminate", _
VbOKCancel, "Replace Version?") = vbCancel Then
End
End If

If Dir(App.Path & "\ExcelDll.dll") > "" _
Then Kill App.Path & "\ExcelDll.dll"

FileCopy "c:\Temp\ExcelDll.dll", _
App.Path & "\ExcelDll.dll "

If RegisterDLL = True Then
UpdateDLL = True
Exit Function
Else
UpdateDLL = False
Exit Function
End If

Else
UpdateDLL = True
End If
Exit Function

err:
MegBox "The error " & err.Number & "" & _
err.Description & "occurred"
UpdateDLL =False
End Function

Private Function DetectExcel() As Boolean
‘ Procedure detects a running Excel and registers it.
Const WM_USER = 1024
Dim hwnd As Long
注释：If Excel is running, this API call returns its handle.
hwnd = FindWindow("XLMAIN", 0)

If hwnd = 0 Then ‘0 means Excel not running.
DetectExcel = False
Else
DetectExcel = True
End If
End Function