Visual Basic 5.0中的簡(jiǎn)單ActiveX DLL，從而使用戶從Northwind數(shù)據(jù)庫(kù)中獲得一系列表單。只要選擇表單，就可以移植包含Access數(shù)據(jù)的Excel工作表。
Excel工作表，該表包含菜單項(xiàng)的定制代碼，從而初始化ActiveX DLL。可執(zhí)行程序，該程序可以發(fā)送上述工作簿，并可檢查公用資源中ActiveX DLL的新版本，如果發(fā)現(xiàn)存在新版本，則拷貝并注冊(cè)該DLL到用戶的機(jī)器。
該方法的優(yōu)點(diǎn)
我因?yàn)橐韵聨讉€(gè)原因而喜歡該方法。一旦ActiveX DLL編譯成功，它可以被任何ActiveX的兼容宿主程序調(diào)用，這意味著你能夠在Microsoft Word、Internet Explorer或者大量的應(yīng)用程序中使用它們。
不同于 Excel中的VBA編碼，那些DLL一旦編譯成功就再也不能為用戶所修改，如果你想做一些與Excel相似的工作，就必須創(chuàng)建并發(fā)布相應(yīng)的附加項(xiàng)。正如前面討論的那樣，只要進(jìn)行簡(jiǎn)單的Visual Basic編程，用戶機(jī)器上的DLL就能夠輕易地被替換。這意味著一旦故障被發(fā)現(xiàn)，或者新版本開發(fā)成功，用戶就可以直接升級(jí)，而再也不必經(jīng)受安裝整個(gè)應(yīng)用程序的痛苦。
該方法的不足
最大的不足是需要在兼容宿主程序上調(diào)用該ActiveX DLL，如果你要移植Excel工作表或Word文檔，那將不成問題。如果你要在自己編制的可執(zhí)行程序或不可視的兼容宿主程序上調(diào)用該DLL，那么控制將變得比較困難，換句話說，此時(shí)采用標(biāo)準(zhǔn)的可執(zhí)行程序作為接口是不適合的，最好的方法是為另一個(gè)應(yīng)用程序提供接口。
設(shè)計(jì)DLL
為了創(chuàng)建接口，打開Visual Basic并創(chuàng)建一個(gè)標(biāo)準(zhǔn)的可執(zhí)行項(xiàng)目，并將他存儲(chǔ)在你所選定的ExcelDLL文件夾中。為了加入Excel引用，點(diǎn)擊Project>References和Microsoft Excel 8.0 Object Library。雙擊Project Explorer中的缺省Form，并將之重新命名為frmMain，設(shè)定Form的標(biāo)題為Open Northwind Tables，并且增加具有下列屬性的控件：
為了創(chuàng)建Access數(shù)據(jù)庫(kù)和Excel電子表格之間的接口，增加列表1的代碼到Form中。
列表1：設(shè)計(jì)DLL,增加這些代碼到Form中以創(chuàng)建接口。
注釋：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
增加標(biāo)準(zhǔn)的模塊到項(xiàng)目中，并將下列代碼加入到該模塊中：
Sub Main()
End Sub
關(guān)閉該模塊。
如果你從未創(chuàng)建過類模塊，那么你就要認(rèn)真對(duì)待，clsExcelWork是一個(gè)簡(jiǎn)單的類，工作一點(diǎn)兒也不困難。增加一個(gè)新的模塊到項(xiàng)目中，并將之命名為clsExcelWork，同時(shí)在聲明段中加入該類（列表2）。
列表2：clsExcelWork-增加新的類模塊到項(xiàng)目中，然后在聲明段中加入新類的代碼。
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
創(chuàng)建下述方法：
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
設(shè)計(jì)工作簿
在你能夠測(cè)試這些代碼之前，你必須創(chuàng)建Excel工作簿，為了達(dá)到這個(gè)目的，打開Excel，并且將缺省的book1存儲(chǔ)到自己的路徑\DLLTest.xsl下，該路徑是你以上創(chuàng)建的VB項(xiàng)目所在的路徑。
在工作簿中，打開VBA編輯器并在Excel菜單中選擇View>Toolbars>Visual Basic，在visual Basic工具條中點(diǎn)擊編輯按鈕。增加新模塊到編輯器中，并輸入下述代碼（列表3）。
列表3：設(shè)計(jì)工作簿-增加新模塊和下述代碼。
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，此時(shí)不要試圖運(yùn)行該代碼，因?yàn)镈LL還沒有創(chuàng)建且沒有設(shè)置適當(dāng)?shù)囊谩?
創(chuàng)建并引用ActiveX DLL
為了創(chuàng)建ActiveX DLL，關(guān)閉Excel應(yīng)用程序，返回到Visual Basic項(xiàng)目，并執(zhí)行以下步驟：
從菜單中點(diǎn)擊Project>Properties。
在Project Properties對(duì)話框中，選擇ActiveX DLL作為項(xiàng)目的屬性，并點(diǎn)擊OK。在Project Name文本框中，輸入ExcelDLL。點(diǎn)擊Component標(biāo)簽并選中Project Compatibility。在底部的文本框中，輸入ExcelDLL.dll，以此確保新的DLL與以前的版本兼容。
在Project Explorer中，點(diǎn)擊名為clsExcelWork的類，并設(shè)置實(shí)例屬性為5-MultiUse。
點(diǎn)擊File菜單，并選擇Make ExcelDLL.dll，為了簡(jiǎn)單起見，確認(rèn)你將DLL保存在項(xiàng)目和工作表所在的文件夾中。
重新打開Excel工作簿，并打開VBA編輯器。
點(diǎn)擊Tools>Reference。
在對(duì)話框中，點(diǎn)擊Browse，并在ExcelDLL.dll創(chuàng)建時(shí)所在的文件夾中找到該文件，雙擊文件名。
保存工作簿。
關(guān)閉VBA編輯器和工作簿。
當(dāng)你重新打開工作簿，你可以點(diǎn)擊名為Northwind DLL的菜單，并選擇Run Northwind DLL，這樣將打開DLL接口，選擇某個(gè)表格名，并點(diǎn)擊Open Table按鈕。如果所有的事情都處理得正確，DLL將移植你所選中的工作表中的數(shù)據(jù)。
設(shè)計(jì)啟動(dòng)程序
需要冷靜思考的是，用戶是否需要打開特定的Excel工作表以訪問該接口？如果你需要改變用戶的接口時(shí)將會(huì)發(fā)生什么？你是否需要重新編制安裝文件，是否需要與每一個(gè)用戶取得聯(lián)系，并使他們重新安裝相應(yīng)的應(yīng)用程序，把ActiveX DLL自動(dòng)地拷貝和注冊(cè)到用戶的機(jī)器上是否是一種好的方法？
可執(zhí)行程序能夠檢查DLL而且在需要的時(shí)候更新并注冊(cè)DLL，接著繼續(xù)發(fā)送Execl并打開你所創(chuàng)建的工作簿，幸運(yùn)的是，這是一種相當(dāng)直接的過程。開始創(chuàng)建一個(gè)新個(gè)Visual basic項(xiàng)目并將之命名為RunExcelDLL,并刪除缺省的Form，再增加一個(gè)新模塊到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：編制啟動(dòng)程序--在模塊中添加下列代碼。
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
‘a(chǎn)ttempt to register the ActiveX DLL has already been
‘a(chǎn)ttempted. 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
