利用Visual Basic 5.0中的ActiveX DLL移植Excel工作表中的Access數據，本技術將避免應用程序修改后所需要的發布工作。

你可曾想過移植Excel工作表中的數據，但是對那些用戶來說卻不會感覺到工作的復雜？你是否想開發具有報告列表的用戶接口，從而使你能夠插入Excel工作簿？另外，你是否能夠以這樣一種方式開發用戶接口，即當該接口發生變化時，用戶的機器能夠自動更新到最新版本？本文將向你展示怎樣建立：

Visual Basic 5.0中的簡單ActiveX DLL，從而使用戶從Northwind數據庫中獲得一系列表單。只要選擇表單，就可以移植包含Access數據的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 FilesMicrosoft OfficeOfficeSamplesNorthwind.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:TempExcelDLL.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:TempExcelDll.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