NorthwindCS啟動(dòng)解讀及高級(jí)應(yīng)用示例

阿羅

setup窗體全部代碼（一）

<DIV class=quote>

Option Compare Database

Option Explicit

Dim startFormName  As String

Dim localSrv, legacyLogin, installOK As Boolean

Private Sub remoteAlert(moreMsg As String)

Dim remoteAlert As String

remoteAlert = "如果SQL服務(wù)器沒(méi)有安裝在這臺(tái)電腦上，那   " & vbNewLine & _

            "么""數(shù)據(jù)庫(kù)路徑""指的是服務(wù)器電腦路徑，例 " & vbNewLine & _

            "如路徑是C:\，意即服務(wù)器的C盤(pán)，而不是這   " & vbNewLine & _

            "臺(tái)電腦的C盤(pán)。" & vbNewLine & _

            "必須按此方式指定路徑而不能用網(wǎng)絡(luò)位置代替。"

MsgBox remoteAlert & vbNewLine & vbNewLine & moreMsg, vbInformation + vbOKOnly, "重要提示"

End Sub

Private Sub addLog(action As String, message As String)

txtInfo = txtInfo & ">" & action & " (" & CStr(Now) & ") " & message & vbNewLine

End Sub

Private Sub btnCheckDBName_Click()

'只是檢查數(shù)據(jù)庫(kù)名稱(chēng)，并不進(jìn)行任何實(shí)際操作

If Not CurrentProject.IsConnected Then

    If MsgBox("數(shù)據(jù)連接不存在，請(qǐng)重新選擇連接", vbOKCancel + vbExclamation, "沒(méi)有連接") = vbOK Then

        DoCmd.RunCommand acCmdConnection

        Call addLog("檢查數(shù)據(jù)庫(kù)名稱(chēng)", "到數(shù)據(jù)庫(kù)的連接不存在，重新選擇連接。")

    End If

Else

    If CheckDBName(Me.txtDBName) Then

        MsgBox "數(shù)據(jù)庫(kù)名稱(chēng)檢查通過(guò)，可以創(chuàng)建", vbInformation + vbOKOnly, ""

        Call addLog("檢查數(shù)據(jù)庫(kù)名稱(chēng)", "名稱(chēng)檢查通過(guò)")

    Else

        MsgBox "服務(wù)器上有相同名稱(chēng)的數(shù)據(jù)庫(kù)", vbExclamation + vbOKOnly, ""

        Call addLog("檢查數(shù)據(jù)庫(kù)名稱(chēng)", "數(shù)據(jù)庫(kù)中有同名數(shù)據(jù)庫(kù)")

    End If

End If

End Sub

Private Sub btnConn_Click()

    DoCmd.RunCommand acCmdConnection

End Sub

Private Sub btnDBInst_Click()

On Error GoTo DBInst_err

If Not CurrentProject.IsConnected Then

    If MsgBox("數(shù)據(jù)連接不存在，請(qǐng)重新選擇連接", vbOKCancel + vbExclamation, "沒(méi)有連接") = vbOK Then

        DoCmd.RunCommand acCmdConnection

        Call addLog("安裝數(shù)據(jù)庫(kù)", "到數(shù)據(jù)庫(kù)的連接不存在，需要重新選擇連接。")

    End If

Else

    If Not CheckDBName(Me.txtDBName) Then

        If MsgBox("服務(wù)器上有相同名稱(chēng)的數(shù)據(jù)庫(kù)，繼續(xù)嗎？" & vbNewLine & vbNewLine & _

            "如果繼續(xù)，該數(shù)據(jù)庫(kù)內(nèi)容將被覆蓋", vbExclamation + vbYesNo + vbDefaultButton2, "提示") = vbNo Then

            Call addLog("安裝數(shù)據(jù)庫(kù)", "數(shù)據(jù)庫(kù)中有同名數(shù)據(jù)庫(kù)，用戶(hù)取消安裝")

            Exit Sub

        Else

            If dropDB(Me.txtDBName) Then

                Call addLog("安裝數(shù)據(jù)庫(kù)", "服務(wù)器中原同名數(shù)據(jù)庫(kù)已脫開(kāi)" & Me.txtDBName)

            End If

        End If

    End If

    If installDB(defaultDBInstMethod, Me.txtFilePath) Then

        MsgBox "數(shù)據(jù)庫(kù)已成功安裝。現(xiàn)在您可以退出，" & vbNewLine & "本程序可以拷貝給網(wǎng)內(nèi)用戶(hù)使用", vbOKOnly + vbInformation, ""

        Call addLog("安裝數(shù)據(jù)庫(kù)", Me.txtDBName & "安裝成功")

        ChangeDB (txtDBName)

        '通過(guò)是否有UserID這個(gè)屬性來(lái)判定是傳統(tǒng)登錄還是Windows登錄

        '呵呵，如果有個(gè)用戶(hù)名是“沒(méi)有定義”那就慘了。

        '不要用currentProject.Connection.Properties ("User Id")，雖然實(shí)際使用是區(qū)別不大，但在測(cè)試的時(shí)候，從

        '一個(gè)登錄模式切換到另一個(gè)，這個(gè)properties集合里面的東西不一定會(huì)消失。

        legacyLogin = (parseConnStr(CurrentProject.BaseConnectionString, "User Id") <> "沒(méi)有定義")

        If legacyLogin Then

            startFormName = legacyLoginStartupForm

        Else

            startFormName = integratedLoginStartupForm

        End If

        CurrentProject.Properties("StartupForm") = startFormName

        Me.Command52.SetFocus

        btnDBInst.Enabled = False

    Else

        MsgBox "數(shù)據(jù)庫(kù)安裝失敗", vbCritical + vbOKOnly, "出錯(cuò)"

        Call addLog("安裝數(shù)據(jù)庫(kù)", Me.txtDBName & "安裝失敗")

    End If

End If

Exit Sub

DBInst_err:

    Const conPropertyNotFound = 2473

    If Err = conPropertyNotFound Then

        CurrentProject.Properties.Add "StartupForm", startFormName

        Resume Next

    Else

        MsgBox Err.Number & Err.Description, vbCritical + vbOKOnly, "出錯(cuò)"

        CurrentProject.Properties("StartupForm") = setup

阿羅

setup窗體全部代碼 （二）

<DIV class=quote>

Private Function installDBbackup(DBFile As String, DBName As String, DBPhysicalName As String, DBLogName As String, DBPhysicalPath As String) As Boolean

'這個(gè)演示，對(duì)于本機(jī)的MSDE很有用

'如果是遠(yuǎn)程，則本機(jī)路徑根本無(wú)用，因此必須要先將備份拷貝到服務(wù)器上去

'演示程序的特點(diǎn)就是可以將數(shù)據(jù)庫(kù)備份文件還原為任意名稱(chēng)和任意位置

'這是Access中缺少的功能

'如果僅用于本地情形，則可對(duì)本程序稍做改動(dòng)，并不需要提示用戶(hù)將備份文件拷貝到遠(yuǎn)程服務(wù)器中

On Error GoTo err_handler

Dim oRestore As SQLDMO.Restore2, oServer As SQLDMO.SQLServer

Dim logicalName1, logicalName2 As String

Set oRestore = New SQLDMO.Restore2

Set oServer = New SQLDMO.SQLServer

oServer.Name = CurrentProject.Connection.Properties("Data Source")

'為了偷懶，下面用sql服務(wù)器的集成安全性登陸，如果用戶(hù)密碼登陸，則用oServer.connect servername, userid,passwd這個(gè)格式，去掉oServer.loginSecure這行。

'詳細(xì)情況可查sql-dmo文檔

oServer.LoginSecure = True

oServer.Connect

'這里，先分析路徑的有效性

With oRestore

    .action = SQLDMORestore_Database

    .Database = DBName

    .Files = "[" & DBFile & "]" '定界符是必須的

    .FileNumber = 1

    .ReplaceDatabase = True

'    下列程序演示了如何取得讀入的備份文件屬性

'    Dim i As Integer

'    For i = 1 To .ReadFileList(oServer).Rows

'        Debug.Print .ReadFileList(oServer).GetColumnString(i, 1)

'    Next i     '仿此也可將所有column讀出

'    程序輸出結(jié)果類(lèi)似于：

'    testDB

'    testDB_log

    logicalName1 = .ReadFileList(oServer).GetColumnString(1, 1)

    logicalName2 = .ReadFileList(oServer).GetColumnString(2, 1)

    .RelocateFiles = "[" & logicalName1 & "],[" & DBPhysicalPath & "\" & DBPhysicalName & "],[" & logicalName2 & "],[" & DBPhysicalPath & "\" & DBLogName & "]"

    .SQLRestore oServer

End With

installDBbackup = True

'比較理想的，當(dāng)然是再加入備份的驗(yàn)證，此地省略了

finally:

Set oRestore = Nothing

Set oServer = Nothing

Exit Function

err_handler:

    MsgBox Err.Description, vbCritical + vbOKOnly, ""

    installDBbackup = False

    Resume finally

End Function

Private Function installDBScript(DBFile As String, DBName As String) As Boolean

'從Microsof Access NorthwindCS修改而來(lái)

On Error GoTo err_handler

    Dim cn As New ADODB.Connection, cm As New ADODB.Command

    Dim infileopen As Boolean

    Dim incmd$, batch$, Q$

   

    installDBScript = False

   

    Q$ = """"  'quoted id char

   

    'Open up a new connection direct to SQL Server

    cn.ConnectionString = CurrentProject.BaseConnectionString

    cn.Open

   

    cm.ActiveConnection = cn

    cm.CommandType = adCmdText

   

    cm.CommandText = "use " + Q$ + DBName + Q$

    cm.Execute

   

    Open DBFile For Input As #1

    infileopen = True

    '將use一行去掉，因?yàn)槲覀円�按照自己的意愿確定數(shù)據(jù)庫(kù)名稱(chēng)，否則是要犯大錯(cuò)誤滴

    '如果項(xiàng)目涉及到兩個(gè)以上數(shù)據(jù)庫(kù)，那么本演示是不適用的

    Do While Not EOF(1)

        Line Input #1, incmd$

        If (Left(incmd$, 3) <> "use") Then

            If (Left(incmd$, 2) <> "go") Then

                batch$ = batch$ + " " + incmd$

            Else

                If batch$ <> "" Then

                    cm.CommandText = batch$

                    cm.Execute

                    batch$ = ""

                End If

            End If

        End If

    Loop

      

    Close #1

    installDBScript = True

    cn.Close

Exit Function

err_handler:

    MsgBox Err.Description, vbCritical + vbOKOnly, ""

    If infileopen Then

        Close #1

    End If

    installDBScript = False

    cn.Close

End Function

Function CreateDB(NewDBName As String, DBPhysicalName As String, DBLogName As String, DBPhysicalPath As String) As Boolean

'從Microsof Access NorthwindCS修改而來(lái)

On Error GoTo CreateDB_Err

    Dim cn As New ADODB.Connection, cm As New ADODB.Command

    'Open up a new connection direct to SQL Server (not through MSDataShape)

    cn.ConnectionString = CurrentProject.BaseConnectionString

    cn.Open

      

    cm.Active

阿羅

阿羅希望，通過(guò)本文，能使初學(xué)者對(duì)ADP的連接方面有個(gè)比較全面的認(rèn)識(shí)，能夠自如地運(yùn)用到自己的編程實(shí)踐當(dāng)中去，寫(xiě)出更好更方便的應(yīng)用來(lái)。[em05]

阿羅

ADP中可以用代碼實(shí)現(xiàn)更廣泛的數(shù)據(jù)連接，方法是使用MDAC的連接設(shè)置功能，需要添加Microsoft OLE DB Service Component 1.0 Type Library

阿羅

添加該引用后，工程中就可以用MSDASC對(duì)象庫(kù)來(lái)編程了。一個(gè)例子

public function PromptConnection() As Boolean

Dim oLink As Object

Set oLink = new MSDASC.DataLinks

oLink.PromptNew

set OLink=nothing

end function

運(yùn)行情況如下：（注意早先版本的對(duì)象不是DataLinks，似乎是udl什么的，具體可以在代碼窗口用F2查看引用庫(kù)的對(duì)象和用法。）

[此貼子已經(jīng)被作者于2005-1-28 18:15:31編輯過(guò)]

李尋歡

頂,阿羅辛苦了.

zhuyiwen

真的不錯(cuò), 辛苦了,阿羅!這是看到的關(guān)于ADP方面解剖和應(yīng)用最全面的文章!可以評(píng)為本年最佳文章![em25]

阿羅

多謝兩位兄弟的支持和鼓勵(lì)!

西西弗斯

高手阿羅，文章有條理，思路清晰，結(jié)構(gòu)嚴(yán)謹(jǐn)。謝謝。能把它做在一個(gè)文檔里供大家下載學(xué)習(xí)呢？

zhengjialon

不錯(cuò)的文章!!