在 Microsoft SQL Server 2000 桌面引擎 (MSDE 2000) 是 SQL Server 2000 相容資料存放區伺服器隨附於 Microsoft Office XP 開發人員轉散發的權限。Office XP 開發 o 人 h 員 ? 工 u 具 ? 封裝精靈 」 有包括 SQL Server 2000 桌面引擎，當封裝 Microsoft Access 專案中的選項 (*.adp) 解決方案。方案是一位使用者的電腦上安裝，SQL Server 2000 桌面引擎安裝搭配方案。不過，未啟動 SQL Server 2000 桌面引擎，而且資料庫並未連接到 SQL Server 2000 桌面引擎。
注意： Microsoft SQL Server 2000 桌面引擎的前一版名為 [Microsoft 資料引擎 (MSDE)。
Microsoft 僅，為了說明提供程式設計範例，不提供任何明示或默示的保證。這包括，但不限於適售性或適合某特定用途之默示擔保責任。本文假設您已熟悉使用我們所示範的程式設計語言以及建立和偵錯程序所使用的工具。Microsoft 技術支援工程師可以協助解釋特定程序的功能，但它們不會修改這些範例以提供附加功能或建構程序，以符合您特定需求。
步驟來修改現有的專案部署的應用程式
下列步驟假設您已經有一個正常運作的專案已準備好要部署的應用程式。步驟會帶您逐步完成如何將額外的程式碼加入至您的 VBA 專案、 如何進行必要的調整，以您的啟動表單以及如何建立為現有的 Microsoft Access 專案的部署套件 (*.adp)，包括 Microsoft SQL Server 2000 桌面引擎。
開啟您想要部署的 Access 專案，然後建立新的模組。
因為您將會包含程式碼會使用 SQLDMO 程式碼和指令碼，您必須確定必要的參考存在。
按一下 [工具] 功能表的 Visual Basic 編輯器，引用項目。
在 [參考] 對話方塊中如果按一下以選取下列它們尚未選取：
Microsoft SQLDMO 物件程式庫
Microsoft 指令碼執行階段
按一下 [確定] 以關閉 [參考] 對話方塊。
複製下列程式碼至新的模組：
Option Compare Database
Option Explicit
Dim adp_UseIntegratedSecurity As Boolean
Public Function fStartUp(strDBName As String, strMDFName As String, _
Optional strUN As String, Optional strPW As String)
'------------------------------------------------------------
'The code in this project connects the MDF file
'to a local MSDE, then establishes the connection between
'the Access Project and MSDE.
'------------------------------------------------------------
Dim strSQLInstances As String
Dim strServername As String
Dim intInst As Integer
Dim strMachineName As String
Dim spaceLocation As Long
'If no username is supplied, and you cannot
'use integrated security, the function requires that you provide a valid SQL Server user account and password.
If Not fCheckForCompatibleOS Then
strMachineName = "(local)"
If strUN = "" Then
MsgBox "Provide a valid SQL Server user account and password to log on to SQL Server because the current operating system does not support integrated security."
Exit Function
End If
adp_UseIntegratedSecurity = False
Else
strMachineName = ComputerName
If strUN = "" Then
adp_UseIntegratedSecurity = True
Else
adp_UseIntegratedSecurity = False
End If
End If
'Find the available instances of SQL 2000 on the computer.
intInst = GetValidSQLInstances(strSQLInstances)
If intInst < 1 Then
Dim strErrorMsg As String
strErrorMsg = "This application requires SQL Server 2000 " & _
"to be installed on the local computer."
MsgBox strErrorMsg, vbCritical, "SQL Server 2000 not installed!"
Exit Function
End If
'At this point, it has been determined that there is at
'least one valid SQL Server 2000 instance on the computer.
'The code below picks the default or first instance if more than
'one is available. You may want to add code to prompt the user for
'a choice when there is more than one instance on the computer.
If InStr(1, strSQLInstances, "MSSQLSERVER") Then
strServername = strMachineName
Else
spaceLocation = InStr(1, strSQLInstances, " ")
If spaceLocation = 0 Then
strServername = strMachineName & "\" & strSQLInstances
Else
strServername = strMachineName & "\" & Mid(strSQLInstances, 1, spaceLocation)
End If
End If
'Call fstartMSDE to connect to SQL Server
fStartMSDE strServername, strUN, strPW
'Call sCopyMDF to move the data file to the data folder
'of SQL Server, and then attach it to the server.
fCopyMDF strServername, strUN, strPW, strDBName, strMDFName
'Connect the ADP to the new database
fChangeADPConnection strServername, strDBName, strUN, strPW
End Function
Public Function fStartMSDE(strServername As String, _
Optional strUN As String, Optional strPW As String)
'------------------------------------------------------------
'This subroutine will turn on MSDE. If the server has been
'started, the error trap will exit the function leaving the
'server running.
'
'Note that it will not put the SQL Service Manager on
'the start bar.
'
'Input:
' strServername The server to be started
' strUN The user used to start server
' strPW The password of user
'
'Output:
' Resolution of start
'
'References:
' SQLDMO
'------------------------------------------------------------
Dim osvr As SQLDMO.SQLServer
Set osvr = CreateObject("SQLDMO.SQLServer")
On Error GoTo StartError 'Error Trap
osvr.LoginTimeout = 60
osvr.LoginSecure = adp_UseIntegratedSecurity
osvr.Start True, strServername, strUN, strPW
ExitSub:
Set osvr = Nothing
Exit Function
StartError:
If Err.Number = -2147023840 Then
'This error is thrown when the server is already running,
'and Server.Start is executed on Windows NT, 2000, or XP.
osvr.Connect strServername, strUN, strPW 'Connect to Server
Else 'Unknown Error
MsgBox Err.Number & ": " & Err.Description
End If
Resume ExitSub
End Function
Public Function fCopyMDF(strServername As String, _
strUN As String, strPW As String, _
strDBName As String, _
sMDFName As String)
'------------------------------------------------------------
'This Function determines whether the database is already on
'the MSDE Server. If the database does not exist, this
'function copies the MDF file from the same location as the
'ADP to MSDE's Data directory and then attaches the database.
'
'Input:
' strServername The server to be started
' strUN The user used to start server
' strPW The password of user
' strDBName The Name of the SQL Database
' sMDFName The Name of the MSDE Database to be copied
'
'Output:
' Resolution of copy
'
'References:
' SQLDMO
' Scripting Runtime
'------------------------------------------------------------
Dim FSO As Scripting.FileSystemObject
Dim osvr As SQLDMO.SQLServer
Dim strMessage As String
Dim db As Variant
Dim fDataBaseFlag As Boolean
Dim dbCount As Integer
On Error GoTo sCopyMDFTrap
'The drive names used in FSO.Copyfile and
'oSvr.AttachDBWithSingleFile must match the
'locations for Program Files and MSDE on the
'computer of the end user.
fCopyMDF = ""
fDataBaseFlag = False
Set FSO = CreateObject("Scripting.FileSystemObject")
Set osvr = CreateObject("SQLDMO.SQLServer")
osvr.LoginSecure = adp_UseIntegratedSecurity
osvr.Connect strServername, strUN, strPW
dbCount = osvr.Databases.Count
'Look for database existence on Local MSDE Server
'by looping through all database names on the local
'MSDE Server.
For Each db In osvr.Databases
If db.Name = strDBName Then 'The database exists
fDataBaseFlag = True
Exit For 'Get out of loop
End If
Next
If Not fDataBaseFlag Then 'There is no database
'matching sDBName
'Copy File to data folder.
FSO.CopyFile Application.CurrentProject.Path _
& "\" & sMDFName, _
osvr.Databases("master").PrimaryFilePath & _
sMDFName, True
'Attach to database.
strMessage = osvr.AttachDBWithSingleFile(strDBName, _
osvr.Databases("master").PrimaryFilePath _
& sMDFName)
End If
ExitCopyMDF:
osvr.Disconnect
Set osvr = Nothing
Exit Function
sCopyMDFTrap:
If Err.Number = -2147216399 Then 'DMO must be initialized
Resume Next
Else
MsgBox Err.Description
End If
Resume ExitCopyMDF
Exit Function
End Function
Function MakeADPConnectionless()
'------------------------------------------------------------
'This code removes the connection properties from the
'Access Project for troubleshooting purposes.
'The ADP will open in a disconnected state until new connection
'properties are supplied.
'------------------------------------------------------------
Application.CurrentProject.OpenConnection ""
End Function
Function fChangeADPConnection(strServername, strDBName As String, Optional strUN As String, _
Optional strPW As String) As Boolean
'------------------------------------------------------------
'This Function resets the connection for an ADP by using the
'input parameters to create a new connection string. If no username
'is supplied, it tries to connect by using integrated security.
'
'Input:
' strServerName The server to be started
' strDBName The Name of the MSDE Database
' strUN The user used to start server
' strPW The password of user
'------------------------------------------------------------
Dim strConnect As String
On Error GoTo EH:
strConnect = "Provider=SQLOLEDB.1" & _
";Data Source=" & strServername & _
";Initial Catalog=" & strDBName
If adp_UseIntegratedSecurity Then
strConnect = strConnect & ";integrated security=SSPI"
Else
strConnect = strConnect & ";user id=" & strUN
strConnect = strConnect & ";password=" & strPW
End If
Application.CurrentProject.OpenConnection strConnect
fChangeADPConnection = True
Exit Function
EH:
MsgBox Err.Number & ": " & Err.Description, vbCritical, "Connection Error"
fChangeADPConnection = False
End Function
將此模組儲存為 modCopyConnect。
建立第二個模組，然後將下列程式碼複製到第二個模組：
Option Compare Database
Option Explicit
'This module provides functions that work together to
'find existing computers running SQL Servers, and also the computer name.
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Private Declare Function OSRegOpenKey Lib "advapi32" Alias _
"RegOpenKeyA" (ByVal hKey As Long, ByVal lpszSubKey As String, _
phkResult As Long) As Long
Private Declare Function OSRegQueryValueEx Lib "advapi32" _
Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpszValueName As String, ByVal dwReserved As Long, _
lpdwType As Long, lpbData As Any, cbData As Long) As Long
Private Declare Function GetComputerName _
Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, _
nSize As Long) As Long
Private Declare Function OSRegCloseKey Lib "advapi32" _
Alias "RegCloseKey" (ByVal hKey As Long) As Long
Private Const MAX_COMPUTERNAME_LENGTH As Long = 15&
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Private Const ERROR_SUCCESS = 0&
Private Const VER_PLATFORM_WIN32s = 0 'Win32s on Windows 3.1
Private Const VER_PLATFORM_WIN32_WINDOWS = 1 'Windows 95/98/ME.
Private Const VER_PLATFORM_WIN32_NT = 2 'Windows NT/2000/XP
Private Const REG_SZ = 1
Private Const REG_BINARY = 3
Private Const REG_DWORD = 4
Private Const REG_MULTI_SZ = 7
Public Function GetValidSQLInstances(ByRef strSQLInstances _
As String) As Integer
'-----------------------------------------------------------
' This returns number of valid SQL instances and a space
' delimited string that lists the instances.
'-----------------------------------------------------------
Dim hKey As Long, i As Integer
Dim strVersionInfo As String
strSQLInstances = ""
GetValidSQLInstances = 0
If RegOpenKey(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\Microsoft SQL Server", hKey) Then
RegQueryStringValue hKey, "InstalledInstances", strSQLInstances
RegCloseKey hKey
StrConv strSQLInstances, vbUpperCase
If InStr(1, strSQLInstances, "MSSQLSERVER") Then
If RegOpenKey(HKEY_LOCAL_MACHINE, _
"Software\Microsoft\MSSQLServer\MSSQLServer\CurrentVersion", _
hKey) Then
RegQueryStringValue hKey, "CurrentVersion", strVersionInfo
RegCloseKey hKey
If Mid(strVersionInfo, 1, 1) <> 8 Then
Replace strSQLInstances, "MSSQLSERVER", ""
End If
End If
End If
Trim strSQLInstances
If Len(strSQLInstances) > 0 Then
GetValidSQLInstances = GetValidSQLInstances + 1
Else
Exit Function
End If
For i = 1 To Len(strSQLInstances)
If Mid$(strSQLInstances, i, 1) = " " Then
GetValidSQLInstances = GetValidSQLInstances + 1
End If
Next i
End If
End Function
Public Function RegOpenKey(ByVal hKey As Long, _
ByVal lpszSubKey As String, phkResult As Long) As Boolean
'-----------------------------------------------------------
' FUNCTION: RegOpenKey
' Opens an existing key in the system registry.
' Returns: True, if the key opened successfully. False
' otherwise.
' Upon success, phkResult is set to the handle of the key.
'-----------------------------------------------------------
Dim lResult As Long
Dim strHkey As String
strHkey = strGetHKEYString(hKey)
lResult = OSRegOpenKey(hKey, lpszSubKey, phkResult)
If lResult = ERROR_SUCCESS Then
RegOpenKey = True
End If
End Function
Public Function RegCloseKey(ByVal hKey As Long) As Boolean
Dim lResult As Long
'-----------------------------------------------------------
' FUNCTION: RegCloseKey
' Closes an open registry key.
' Returns: True on success, else False.
'-----------------------------------------------------------
lResult = OSRegCloseKey(hKey)
RegCloseKey = (lResult = ERROR_SUCCESS)
End Function
Private Function strGetHKEYString(ByVal hKey As Long) As String
'-----------------------------------------------------------
'Given an HKEY, return the text string representing that key.
'-----------------------------------------------------------
Dim strKey As String
Dim intIdx As Integer
strKey = strGetPredefinedHKEYString(hKey)
If Len(strKey) > 0 Then
strGetHKEYString = strKey
Exit Function
End If
End Function
Private Function strGetPredefinedHKEYString(ByVal _
hKey As Long) As String
'-----------------------------------------------------------
'Given a predefined HKEY, return the text string representing
'that key, or else return vbNullString.
'-----------------------------------------------------------
Select Case hKey
Case HKEY_CLASSES_ROOT
strGetPredefinedHKEYString = "HKEY_CLASSES_ROOT"
Case HKEY_CURRENT_USER
strGetPredefinedHKEYString = "HKEY_CURRENT_USER"
Case HKEY_LOCAL_MACHINE
strGetPredefinedHKEYString = "HKEY_LOCAL_MACHINE"
Case HKEY_USERS
strGetPredefinedHKEYString = "HKEY_USERS"
End Select
End Function
Public Function RegQueryStringValue(ByVal hKey As Long, _
ByVal strValueName As String, strData As String) As Boolean
'-----------------------------------------------------------
' Retrieves the string data for a named
' (strValueName = name) or unnamed (Len(strValueName) = 0)
' value in a registry key. If the named value
' exists, but its data is not a string, this function
' fails.
'
' Returns: True on success, else False.
' On success, strData is set to the string data value.
'-----------------------------------------------------------
Dim lResult As Long
Dim lValueType As Long
Dim strBuf As String
Dim lDataBufSize As Long
lResult = OSRegQueryValueEx(hKey, strValueName, 0&, _
lValueType, _
ByVal 0&, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_SZ Then
strBuf = space$(lDataBufSize)
lResult = OSRegQueryValueEx(hKey, strValueName, 0&, _
0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
RegQueryStringValue = True
strData = StringFromBuffer(strBuf)
End If
ElseIf lValueType = REG_MULTI_SZ Then
strBuf = space$(lDataBufSize)
lResult = OSRegQueryValueEx(hKey, strValueName, 0&, _
0&, _
ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
RegQueryStringValue = True
strData = ReplaceNullsWithSpaces(strBuf)
End If
End If
End If
End Function
Public Function StringFromBuffer(Buffer As String) As String
Dim nPos As Long
nPos = InStr(Buffer, vbNullChar)
If nPos > 0 Then
StringFromBuffer = Left$(Buffer, nPos - 1)
Else
StringFromBuffer = Buffer
End If
End Function
Public Function ReplaceNullsWithSpaces(str As String) As String
'-----------------------------------------------------------
' Replace all null characters with spaces.
'-----------------------------------------------------------
Dim i As Integer
If Len(str) > 0 Then
For i = 1 To Len(str)
If Mid$(str, i, 1) = vbNullChar Then
Mid$(str, i, 1) = " "
End If
Next i
ReplaceNullsWithSpaces = Left$(str, Len(str) - 2)
Else
ReplaceNullsWithSpaces = str
End If
End Function
Public Function ComputerName() As String
'-----------------------------------------------------------
' Returns the local computer name.
'-----------------------------------------------------------
Dim nLen As Long
Dim strComputerName As String
nLen = MAX_COMPUTERNAME_LENGTH
strComputerName = String$(nLen, 0)
GetComputerName strComputerName, nLen
strComputerName = Left$(strComputerName, nLen)
ComputerName = strComputerName
End Function
Public Function fCheckForCompatibleOS() As Boolean
'-----------------------------------------------------------
' Checks to see if the OS can use integrated security.
'-----------------------------------------------------------
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = space$(128)
retvalue = GetVersionExA(osinfo)
If osinfo.dwPlatformId >= VER_PLATFORM_WIN32_NT Then
fCheckForCompatibleOS = True
Else
fCheckForCompatibleOS = False
End If
End Function
將第二個模組儲存為 GetSQLInstances。
在 [設計] 檢視中開啟現有的啟動表單，或如果您沒有啟動表單建立新的啟動表單。
將命令加入至啟動表單呼叫 fStartUp 函式的 OnOpen 事件屬性。
您必須指定您想要在 SQL Server 上建立的資料庫名稱和現有的 SQL Server 資料檔案名稱。 您也可以指定所需的 SQL Server 登入名稱及密碼做為選擇性的第三個和第四個引數如果您不使用整合式的安全性。 比方說如果想建立使用資料檔，稱為 NorthwindSQL.mdf 稱為北風資料庫函式顯示如下：
=fStartUp("Northwind","NorthwindSQL.mdf","","")
附註 此附註情況牽涉到 SQL Server 安全性。如果沒有提供登入名稱稍早提到的函式呼叫中本文的程式碼會嘗試使用整合式的安全性，如果基礎作業系統可以支援它 (Microsoft Windows NT 4.0、 Microsoft Windows 2000 和 Microsoft Windows XP)。如果基礎作業系統是 Microsoft Windows 98 或 Microsoft Windows 千禧版 (Me)，您必須提供有效的 SQL Server 使用者帳戶及密碼。 無論作業系統] 系統如果您指定至少一個的登入名稱程式碼嘗試連線藉由使用 SQL 安全性具有所提供的登入名稱及密碼。如果您沒有 SQL Server 資料檔案的複本必須製作與部署套件包含該資料檔案的複本。
重要：本文是以 Microsoft 機器翻譯軟體翻譯而成，而非使用人工翻譯而成。Microsoft 同時提供使用者人工翻譯及機器翻譯兩個版本的文章，讓使用者可以依其使用語言使用知識庫中的所有文章。但是，機器翻譯的文章可能不盡完美。這些文章中也可能出現拼字、語意或文法上的錯誤，就像外國人在使用本國語言時可能發生的錯誤。Microsoft 不為內容的翻譯錯誤或客戶對該內容的使用所產生的任何錯誤或損害負責。Microsoft也同時將不斷地就機器翻譯軟體進行更新。
回此頁最上方
