NorthwindCS启动解读及高级应用示例

阿罗

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服务器没有安装在这台电脑上，那   " & vbNewLine & _

            "么""数据库路径""指的是服务器电脑路径，例 " & vbNewLine & _

            "如路径是C:\，意即服务器的C盘，而不是这   " & vbNewLine & _

            "台电脑的C盘。" & vbNewLine & _

            "必须按此方式指定路径而不能用网络位置代替。"

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()

'只是检查数据库名称，并不进行任何实际操作

If Not CurrentProject.IsConnected Then

    If MsgBox("数据连接不存在，请重新选择连接", vbOKCancel + vbExclamation, "没有连接") = vbOK Then

        DoCmd.RunCommand acCmdConnection

        Call addLog("检查数据库名称", "到数据库的连接不存在，重新选择连接。")

    End If

Else

    If CheckDBName(Me.txtDBName) Then

        MsgBox "数据库名称检查通过，可以创建", vbInformation + vbOKOnly, ""

        Call addLog("检查数据库名称", "名称检查通过")

    Else

        MsgBox "服务器上有相同名称的数据库", vbExclamation + vbOKOnly, ""

        Call addLog("检查数据库名称", "数据库中有同名数据库")

    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("数据连接不存在，请重新选择连接", vbOKCancel + vbExclamation, "没有连接") = vbOK Then

        DoCmd.RunCommand acCmdConnection

        Call addLog("安装数据库", "到数据库的连接不存在，需要重新选择连接。")

    End If

Else

    If Not CheckDBName(Me.txtDBName) Then

        If MsgBox("服务器上有相同名称的数据库，继续吗？" & vbNewLine & vbNewLine & _

            "如果继续，该数据库内容将被覆盖", vbExclamation + vbYesNo + vbDefaultButton2, "提示") = vbNo Then

            Call addLog("安装数据库", "数据库中有同名数据库，用户取消安装")

            Exit Sub

        Else

            If dropDB(Me.txtDBName) Then

                Call addLog("安装数据库", "服务器中原同名数据库已脱开" & Me.txtDBName)

            End If

        End If

    End If

    If installDB(defaultDBInstMethod, Me.txtFilePath) Then

        MsgBox "数据库已成功安装。现在您可以退出，" & vbNewLine & "本程序可以拷贝给网内用户使用", vbOKOnly + vbInformation, ""

        Call addLog("安装数据库", Me.txtDBName & "安装成功")

        ChangeDB (txtDBName)

        '通过是否有UserID这个属性来判定是传统登录还是Windows登录

        '呵呵，如果有个用户名是“没有定义”那就惨了。

        '不要用currentProject.Connection.Properties ("User Id")，虽然实际使用是区别不大，但在测试的时候，从

        '一个登录模式切换到另一个，这个properties集合里面的东西不一定会消失。

        legacyLogin = (parseConnStr(CurrentProject.BaseConnectionString, "User Id") <> "没有定义")

        If legacyLogin Then

            startFormName = legacyLoginStartupForm

        Else

            startFormName = integratedLoginStartupForm

        End If

        CurrentProject.Properties("StartupForm") = startFormName

        Me.Command52.SetFocus

        btnDBInst.Enabled = False

    Else

        MsgBox "数据库安装失败", vbCritical + vbOKOnly, "出错"

        Call addLog("安装数据库", 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, "出错"

        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

'这个演示，对于本机的MSDE很有用

'如果是远程，则本机路径根本无用，因此必须要先将备份拷贝到服务器上去

'演示程序的特点就是可以将数据库备份文件还原为任意名称和任意位置

'这是Access中缺少的功能

'如果仅用于本地情形，则可对本程序稍做改动，并不需要提示用户将备份文件拷贝到远程服务器中

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服务器的集成安全性登陆，如果用户密码登陆，则用oServer.connect servername, userid,passwd这个格式，去掉oServer.loginSecure这行。

'详细情况可查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读出

'    程序输出结果类似于：

'    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

'比较理想的，当然是再加入备份的验证，此地省略了

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修改而来

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一行去掉，因为我们要按照自己的意愿确定数据库名称，否则是要犯大错误滴

    '如果项目涉及到两个以上数据库，那么本演示是不适用的

    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修改而来

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

阿罗

阿罗希望，通过本文，能使初学者对ADP的连接方面有个比较全面的认识，能够自如地运用到自己的编程实践当中去，写出更好更方便的应用来。[em05]

阿罗

ADP中可以用代码实现更广泛的数据连接，方法是使用MDAC的连接设置功能，需要添加Microsoft OLE DB Service Component 1.0 Type Library

阿罗

添加该引用后，工程中就可以用MSDASC对象库来编程了。一个例子

public function PromptConnection() As Boolean

Dim oLink As Object

Set oLink = new MSDASC.DataLinks

oLink.PromptNew

set OLink=nothing

end function

运行情况如下：（注意早先版本的对象不是DataLinks，似乎是udl什么的，具体可以在代码窗口用F2查看引用库的对象和用法。）

[此贴子已经被作者于2005-1-28 18:15:31编辑过]

李寻欢

顶,阿罗辛苦了.

zhuyiwen

真的不错, 辛苦了,阿罗!这是看到的关于ADP方面解剖和应用最全面的文章!可以评为本年最佳文章![em25]

阿罗

多谢两位兄弟的支持和鼓励!

西西弗斯

高手阿罗，文章有条理，思路清晰，结构严谨。谢谢。能把它做在一个文档里供大家下载学习呢？

zhengjialon

不错的文章!!