VB 版 (精华区)

发信人: cdd (平上), 信区: VB
标  题: 创建ActiveX接口以移植Excel工作表(增加列表4的代码)
发信站: 哈工大紫丁香 (2000年06月06日14:02:53 星期二), 站内信件


　　列表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 _
　　　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
　　保存该项目。当你运行该应用程序时，它将按照以下步骤进行：
　　　1．检查是否存在其他公用的DLL的新版本，如果发现存在，则拷贝
　　　　 并注册新文件，注意该方法仅仅是比较文件的日期,　存在其他
　　　　 的方法检查用于API调用的DLL版本。
　　　2．打开Excel，并打开DLLTest.xls。
　　　3．关闭
　　为了测试该方法，拷贝你在C:\Temp目录下创建的ExcelDLL.dll文件，
然后拷贝你机器上的其他的旧 DLL到项目所在的文件夹，并将之命名为:
ExcelDll.dll，目录C:\Temp下的文件应当拷贝到项目所在的目录并注册，
选择表单进行观察。
　　现在，你已经具备创建功能强大的应用程序的基础，该程序将利用
ActiveX DLL作为用户的接口。从此开始，你可以增加各种各样的SQL以获
得容量、安全性以及你的项目所需要的其他特性。为了获得更多的灵活性，
可以将这些DLL转变为ActiveX控件，这个过程也是相当简单的。


--
问：生活为什么如此美好？
答：因为有了BBS.

※ 来源:·哈工大紫丁香 bbs.hit.edu.cn·[FROM: che.hit.edu.cn]