Nej. lige som i NorthwindCS. det som følger med Access, vis databasen ikke findes på sql serveren så lavest den udefra NorthwindCS.sql som ligger i samme dir som Access database filen
Option Compare Database Option Explicit Public Enum LocalNwind lnNoServer = 0 lnServerNoDB = 1 lnIsNorthwind = 2 End Enum Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Const NwindAccess = "NorthwindCS" 'the database installed by Access script Public Const NwindSQL = "Northwind" 'the sample database shipping with SQL 7.0; set to blank if you don't want to use this Public Const StartupFormName = "Startup" 'this form Public Const SelectPrompt1 = "Please select a computer with Microsoft Data Engine (MSDE) or Microsoft SQL Server installed and running from the following dialog, and choose any database on the server." Public Const SelectPrompt2 = "If you wish to install MSDE or SQL Server on this machine first, press Cancel here, install MSDE or SQL Server, then reopen this project. " Public Const SelectTitle = "Select a SQL Server" Public Const InstallPrompt1 = "Connected to SQL Server on : " Public Const InstallPrompt2 = "Would you like to install the sample database?" Public Const InstallPrompt3 = " This may take a few minutes." Public Const InstallTitle = "Install Database" Public Const CreateSuccessful = "Created database on SQL Server" Public Const CreateTitle = "Installation successful" Public Const CannotFindFile1 = "Cannot find the file :" Public Const CannotFindFile2 = "Please reinstall the sample project." Public Const CannotFindTitle = "File not found" Public Const UnconnectedPrompt = "Set Project to unconnected?" Public Const fUnconnectedPrompt = False
' Functions in this module are used in the Startup form.
Function OpenStartup() As Boolean ' Displays Startup form ' Used in OnOpen property of Startup form. On Error GoTo OpenStartup_Err Dim Response, Msg, Title, Style
' Set the value of HideStartupForm check box using the value of ' StartupForm property of database (as set in Display Form box ' in Startup dialog box).
If InStr(1, CurrentProject.Properties("StartupForm"), StartupFormName) > 0 Then ' StartupForm property is set to Startup, so clear HideStartupForm ' check box. Forms(StartupFormName).HideStartupForm = False Else ' StartupForm property is not set to Startup, so check HideStartupForm ' checkbox. Forms(StartupFormName).HideStartupForm = True End If
'Hide custom menu bar until we're done with the Startup form code, or user sees double DoCmd.ShowToolbar "NorthwindCustomMenuBar", acToolbarNo
'Check if we're already connected If CurrentProject.IsConnected Then 'need code to set project to unconnected. Response = vbNo Msg = UnconnectedPrompt Style = vbYesNo + vbQuestion + vbDefaultButton1 Title = "" If (fUnconnectedPrompt) Then Response = MsgBox(Msg, Style, Title) End If If Response = vbYes Then 'write blank string for testing CurrentProject.OpenConnection "Provider=" Else 'check if we are connected to the expected db CheckConnectedServer End If
Else 'attempt to autostart server If (StartSQLServer) Then CheckConnectedServer Else Msg = SelectPrompt1 + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13) + SelectPrompt2 Style = vbOKCancel + vbInformation Title = SelectTitle Response = MsgBox(Msg, Style, Title) If Response <> vbCancel Then DoCmd.RunCommand acCmdConnection If CurrentProject.IsConnected Then CheckConnectedServer End If End If End If
OpenStartup_Exit: 'If we're not connected, hide the HideStartupForm checkbox and label so that the user 'won't disable the startup code from running next time If Not (CurrentProject.IsConnected) Then Forms(StartupFormName).HideStartupForm.Visible = False Forms(StartupFormName).HideStartupFormLabel.Visible = False End If
'Now display custom menu bar. The Startup property will make it replace standard one. DoCmd.ShowToolbar "NorthwindCustomMenuBar", acToolbarYes
Exit Function
OpenStartup_Err: Const conPropertyNotFound = 3270 If Err = conPropertyNotFound Then Forms(StartupFormName).HideStartupForm = True Resume OpenStartup_Exit End If MsgBox Err.Description GoTo OpenStartup_Exit
End Function
Function CreateDB() As Boolean On Error GoTo CreateDB_Err Dim cn As New ADODB.Connection, cm As New ADODB.Command Dim devno As Integer, devpath As String
'Open up a new connection direct to SQL Server (not through MSDataShape) cn.ConnectionString = CurrentProject.BaseConnectionString cn.Open
If Left(cn.Properties("DBMS Version"), 3) = "07." Then cm.CommandText = "create database " + NwindAccess cm.Execute Else If GetDevInfo(cm, devno, devpath) Then cm.CommandText = "DISK INIT NAME = '" + NwindAccess + _ "',PHYSNAME = '" + devpath + NwindAccess + _ ".dat', VDEVNO = " + CStr(devno) + ", Size = 2560" cm.Execute cm.CommandText = "CREATE DATABASE " + NwindAccess + " ON " + NwindAccess + " = 5" cm.Execute End If End If cm.CommandText = "exec sp_dboption '" + NwindAccess + "','trunc. log on chkpt.','true'" cm.Execute cm.CommandText = "exec sp_dboption '" + NwindAccess + "','trunc. log on chkpt.','true'" cm.Execute
CreateDB = True cn.Close Exit Function
CreateDB_Err: MsgBox Err.Description CreateDB = False cn.Close End Function Function RunScript(DBName As String, InFile As String) As Boolean On Error GoTo RunScript_Err Dim cn As New ADODB.Connection, cm As New ADODB.Command Dim infileopen As Boolean Dim incmd$, batch$, Q$
Q$ = """" 'quoted id char
'Open up a new connection direct to SQL Server cn.ConnectionString = CurrentProject.BaseConnectionString cn.Open
Do While Not EOF(1) Line Input #1, incmd$ If (Left(incmd$, 2) <> "go") Then batch$ = batch$ + " " + incmd$ Else If batch$ <> "" Then cm.CommandText = batch$ cm.Execute batch$ = "" End If End If Loop
Close #1 RunScript = True cn.Close Exit Function
RunScript_Err: MsgBox Err.Description If infileopen Then Close #1 End If RunScript = False cn.Close End Function Function HideStartupForm() On Error GoTo HideStartupForm_Err ' Uses the value of HideStartupForm check box to determine the setting for ' StartupForm property of database. (The setting is displayed in Display Form ' box in Startup dialog box). ' Used in OnClick event of HideStartupForm checkbox of Startup form. If Forms(StartupFormName).HideStartupForm Then ' HideStartupForm check box is checked, so set StartupForm property to (none). CurrentProject.Properties("StartupForm") = "(none)" Else ' HideStartupForm check box is cleared, so set StartupForm property to Startup. CurrentProject.Properties("StartupForm") = StartupFormName End If
Exit Function
HideStartupForm_Err: Const conPropertyNotFound = 2473 If Err = conPropertyNotFound Then CurrentProject.Properties.Add "StartupForm", StartupFormName Resume Next End If End Function Function CloseForm() ' Closes Startup form. ' Used in OnClick property of OK command button on Startup form. DoCmd.Close
End Function
Function CheckConnectedServer() 'looks for Northwind or NorthwindCS on selected server On Error GoTo CheckConnectedServer_Err Dim cn As ADODB.Connection Dim ServerStr As String, DBStr As String, ConnectStr As String Dim Response, Msg, Title, Style
Set cn = CurrentProject.Connection DBStr = cn.Properties("Initial Catalog")
If (DBStr = NwindAccess) Or (DBStr = NwindSQL) Then 'we're done ElseIf CheckForNorthwind(cn) Then 'we're done Else 'No northwind database on this server, ask if they want to install one ServerStr = cn.Properties("Data Source") If (DBInstallPrompt(ServerStr)) Then Msg = CreateSuccessful Style = vbOK + vbInformation Title = CreateTitle MsgBox Msg, Style, Title ChangeDB (NwindAccess) Else 'set project back to unconnected CurrentProject.OpenConnection "Provider=" End If End If
Exit Function
CheckConnectedServer_Err: MsgBox Err.Description
End Function
Function DBInstallPrompt(Server As String) As Boolean On Error GoTo DBInstallPrompt_Err Dim Response, Msg, Title, Style Dim servername As String, Script As String DBInstallPrompt = False
If (Server = "(local)") Then servername = "this machine" Else servername = Server 'Check for script file before offering to install Script = CurrentProject.Path + "\" + NwindAccess + ".sql" If Dir(Script) = "" Then Msg = CannotFindFile1 + Script + Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13) + CannotFindFile2 Style = vbOKOnly + vbExclamation Title = CannotFindTitle Response = MsgBox(Msg, Style, Title) Exit Function Else Msg = InstallPrompt1 + CurrentProject.Connection.Properties("Data Source") + _ Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13) + InstallPrompt2 + _ Chr$(10) + Chr$(13) + Chr$(10) + Chr$(13) + InstallPrompt3 Style = vbYesNo + vbQuestion + vbDefaultButton1 Title = InstallTitle Response = MsgBox(Msg, Style, Title) If Response = vbNo Then DBInstallPrompt = False Exit Function End If End If
Screen.MousePointer = 11 If CreateDB() Then If RunScript(NwindAccess, Script) Then DBInstallPrompt = True End If End If Screen.MousePointer = 0
Exit Function
DBInstallPrompt_Err: MsgBox Err.Description DBInstallPrompt = False Exit Function
End Function
Public Function GetDevInfo(cm As ADODB.Command, FreeDevNo As Integer, MasterPath As String) As Boolean On Error GoTo GetDevInfo_Err Dim rs As New ADODB.Recordset Const startdev As Integer = 10 Dim I As Integer rs.CursorLocation = adUseClient rs.CursorType = adOpenStatic ' need to set ansi_defaults off for next stmt, then reset for normal OLE DB operation cm.CommandText = "SET ANSI_DEFAULTS OFF exec sp_helpdevice SET ANSI_DEFAULTS ON SET CURSOR_CLOSE_ON_COMMIT OFF SET IMPLICIT_TRANSACTIONS OFF" rs.Open cm rs.Sort = "device_number" 'look for lowest devno above start point that is not in use I = startdev Do Until rs.EOF rs.MoveNext If rs.Fields("device_number") = I Then I = I + 1 If rs.Fields("device_number") > I Then Exit Do Loop If rs.EOF Then MsgBox "Couldn't get free device number" GetDevInfo = False Exit Function End If FreeDevNo = I
rs.Filter = "device_name = 'master'" I = InStr(1, rs.Fields("physical_name"), "master.dat") If (I = 0) Then MsgBox "Couldn't find master device path." GetDevInfo = False Exit Function End If
MasterPath = Left(rs.Fields("physical_name"), I - 1)
GetDevInfo = True rs.Close Exit Function
GetDevInfo_Err: MsgBox Err.Description GetDevInfo = False Exit Function
End Function
Public Function CheckForNorthwind(cn As ADODB.Connection) As Boolean On Error GoTo CheckForNorthwind_Err
Dim rs As New ADODB.Recordset Set rs = cn.Execute("select 1 from master..sysdatabases where name='" + NwindAccess + "'") If rs.EOF Then rs.Close If NwindSQL <> "" Then 'see if the SQL 7.0 sample database is there Set rs = cn.Execute("select 1 from master..sysdatabases where name='" + NwindSQL + "'") If rs.EOF Then ' neither version of northwind found CheckForNorthwind = False Else 'found sql 7 version of northwind ChangeDB (NwindSQL) CheckForNorthwind = True End If rs.Close Else 'no Access version of northwind, and not looking for SQL 7 version CheckForNorthwind = False End If Else 'found the Access version of the database rs.Close ChangeDB (NwindAccess) CheckForNorthwind = True End If
Exit Function
CheckForNorthwind_Err: MsgBox Err.Description CheckForNorthwind = False End Function Public Function StartSQLServer() As Boolean On Error GoTo StartSQLServer_Err StartSQLServer = False
Dim srv As Object Dim t As Integer, et As Integer Dim fNewADP As Boolean, DataSource As String, ConnectStr As String
Dim WaitForStarting As Integer, WaitForRunning As Integer, WaitAfterRunning As Integer WaitForStarting = 10 'wait 10 seconds after requesting server start to get status=starting WaitForRunning = 20 'wait 20 seconds after getting status=starting to get status=running WaitAfterRunning = 5 'wait 5 seconds after status=running before attempting to connect Dim StatusMsg As String StatusMsg = "Attempting to start server "
ConnectStr = CurrentProject.BaseConnectionString If ConnectStr = "" Then fNewADP = True DataSource = "(local)" Else fNewADP = False Dim cn As New ADODB.Connection cn.ConnectionString = ConnectStr DataSource = cn.Properties("Data Source")
End If
Set srv = CreateObject("SQLDMO.SQLServer") srv.Name = DataSource
If srv.Status = 1 Then 'SQLDMOSvc_Running 'if server already running don't try to start GoTo ServerRunning ElseIf srv.Status <> 3 Then 'SQLDMOSvc_Stopped 'if server isn't in a stopped state don't try to start Debug.Print "SQL Server in unexpected state : " + CStr(srv.Status) GoTo StartSQLServer_Exit End If
et = WaitForStarting + WaitForRunning + WaitAfterRunning SysCmd acSysCmdInitMeter, StatusMsg, et et = 0
srv.Start False 'first loop until server is starting t = 0 Do Until srv.Status = 4 'SQLDMOSvc_Starting If (t = WaitForStarting) Then Debug.Print "timed out waiting for status=starting" GoTo StartSQLServer_Exit End If Sleep (1000) t = t + 1 et = et + 1 SysCmd acSysCmdUpdateMeter, et Loop 'now loop until running or stopped t = 0 Do Until srv.Status = 1 'SQLDMOSvc_Running If (t = WaitForRunning Or srv.Status = 3) Then Debug.Print "timed out waiting for status=running" GoTo StartSQLServer_Exit End If Sleep (1000) t = t + 1 et = et + 1 SysCmd acSysCmdUpdateMeter, et Loop
'Now wait a few seconds before attempting to connect t = 0 Do Until t = WaitAfterRunning Sleep (1000) t = t + 1 et = et + 1 SysCmd acSysCmdUpdateMeter, et Loop
ServerRunning: If fNewADP Then 'get the local server's network name srv.Connect "(local)", "sa", "" ConnectStr = "Provider=SQLOLEDB;Data Source=" + srv.NetName + _ ";User ID=sa;Password=;Persist Security Info=TRUE;Initial Catalog=master" End If
CurrentProject.OpenConnection ConnectStr
SysCmd acSysCmdClearStatus StartSQLServer = True Exit Function
StartSQLServer_Err: 'Don't show the user errors in attempts to start server Debug.Print "Error " + CStr(Err.Number) + " : " + Err.Description
StartSQLServer_Exit: SysCmd acSysCmdClearStatus
End Function
Public Sub ChangeDB(NewDBName As String) Dim ConnectStr As String Dim InitCat As String, StartPos As Integer, EndPos As Integer
NorthwindCS.sql more than likely contains INSERT INTO ...... statements after creating the tables. You cant get SQL Server to do that BUT you can get it to EXPORT the to ACCESS if thats what you want to do!
faroe>have you tried? If your using SQL 2000 you can find a template for creating a stored procedure needed to detach and attach your database. In SQL Query analyzer go to the Edit Menu and find Insert template. Then find the template for detaching and attaching the dB. In the Edit menu you will also see Replace Template Parameters. This helps you fill out the required parameters.
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
Ny bruger
Nybegynder
Opret
Preview
