frmnewweb.frm

OA编程 源代码

    End If
    
    rdoEngine.rdoRegisterDataSource "bkbtinfo", _
        "Microsoft Access Driver (*.mdb)", True, _
        "DBQ=" & Trim(App.Path) & "\bkbtinfo.mdb"
    
    Set gclsDatabase = New DataAccess
    Call gclsDatabase.CreateRDODatabaseConnection
    
    '路径=====================================
    
    dbpath = Trim(txtFilePath)

    LabSysInfo.Visible = True
    LabSysInfo.Refresh
    Screen.MousePointer = 11
    Set gclsDatabase = New DataAccess
    Call gclsDatabase.CreateRDODatabaseConnection

    connstr = "Driver={SQL SERVER};SERVER=(local);UID=" & Trim(txtUID) & ";PWD=" & Trim(txtPWD) & ";DATABASE=master"
    MyConn.Open connstr
    
    
    '检查版本=============================
    If Opt65.Value = True Then
        SqlVer = "SQL65"
    ElseIf Opt7.Value = True Then
        SqlVer = "SQL7"
    End If
    
'    Sqlstr = "select @@version"
'    rs.Open Sqlstr, MyConn
'    If InStr(1, rs(0), "Microsoft SQL Server  7.00") <> 0 Then
'        SqlVer = "SQL7"
'    ElseIf InStr(1, rs(0), "Microsoft SQL Server  6.5") <> 0 Then
'       SqlVer = "SQL65"
'       If MyConn.Version > 2.1 Then
'          MsgBox "在当前的数据访问对象版本下，你只能使用SQL7.0以上来建立应用 !", 64, "提示"
'          Exit Sub
'       End If
'    End If
    '=====================================
    LabSysInfo = "正在建立新的数据库"
    LabSysInfo.Refresh
    
    If SqlVer = "SQL65" Then
        Sqlstr = "select  max(convert(tinyint, substring(convert(binary(4), d.low),  v.low, 1))) "
        Sqlstr = Sqlstr & " from sysdevices d, master.dbo.spt_values v "
        Sqlstr = Sqlstr & " where  v.type = 'E'  and v.number = 3 "
        Set rs = MyConn.Execute(Sqlstr)
        
        tempNum = rs(0) + 1
        rs.Close
        MyConn.BeginTrans
        
        Sqlstr = "DISK INIT NAME='" & dbName & "DEV',PHYSNAME='" & dbpath & UCase(dbName) & "DEV.DAT',VDEVNO=" & tempNum & ",SIZE=25600 "
        MyConn.Execute Sqlstr, 64
    
        Sqlstr = "DISK INIT NAME='" & dbName & "LOG',PHYSNAME='" & dbpath & UCase(dbName) & "LOG.DAT',VDEVNO=" & tempNum + 1 & ",SIZE=10240 "
        MyConn.Execute Sqlstr, 64
        
        Sqlstr = "CREATE DATABASE " & dbName & "  ON " & dbName & "DEV=50  LOG ON " & dbName & "LOG=20 "
        MyConn.Execute Sqlstr, 64
        MyConn.CommitTrans
    Else
        Set fs = CreateObject("Scripting.FileSystemObject")
        If fs.FileExists(App.Path & "\" & dbName & "Dev.mdf") = True Then
            MsgBox "存在源数据库文件'" & App.Path & "\" & dbName & "Dev.mdf", "48", "系统提示"
            Exit Sub
        End If
        If fs.FileExists(App.Path & "\" & dbName & "Log.ldf") = True Then
            MsgBox "存在源数据文件'" & App.Path & "\" & dbName & "Log.ldf", "48", "系统提示"
            Exit Sub
        End If
        
        Set fs = Nothing
        Sqlstr = " CREATE DATABASE " & dbName & " ON "
        Sqlstr = Sqlstr & "  ( NAME = '" & dbName & "Dat',  FILENAME = '" & App.Path & "\" & dbName & "Dat.mdf',  Size = 50)"
        Sqlstr = Sqlstr & "  LOG ON ( NAME = '" & dbName & "Log',  FILENAME = '" & App.Path & "\" & dbName & "Log.ldf', "
        Sqlstr = Sqlstr & "  SIZE = 20MB )"
        MyConn.Execute Sqlstr, 64
    End If
    
    '判断bkbt919是否已存在
    Sqlstr = "select name from syslogins where name='bkbt919'"
    Set rs = MyConn.Execute(Sqlstr)
    exitUser = 0
    Do Until rs.EOF
        exitUser = 1
        rs.MoveNext
    Loop
    rs.Close
    MyConn.Close

    rdoEngine.rdoRegisterDataSource "bkbtinfo", _
        "Microsoft Access Driver (*.mdb)", True, _
        "DBQ=" & Trim(App.Path) & "\bkbtinfo.mdb"
    
    Set gclsDatabase = New DataAccess
    Call gclsDatabase.CreateRDODatabaseConnection
    
    '============================
    SQL = "SELECT * FROM 数据表创建 ORDER BY 序号"
    Set Rst = gclsDatabase.RDOSelect(SQL)
    If Rst.RowCount > 0 Then
        connstr = "Driver={SQL SERVER};SERVER=(LOCAL);UID=" & Trim(txtUID) & ";PWD=" & Trim(txtPWD) & ";DATABASE=" & dbName
        MyConn.Open connstr
        
        CreateTableStr = "sp_dboption " & dbName & ",'trunc. log on chkpt.',true"
        MyConn.Execute CreateTableStr, 64
        
        If exitUser = 0 Then
            Sqlstr = "sp_addlogin 'bkbt919', '919bkbt', '" & dbName & "'"
            MyConn.Execute Sqlstr, 64
            '建立loginID , Password, DefaultDatabase
        End If
        
        'sqlstr = "sp_a"
        Sqlstr = "sp_addalias 'bkbt919', 'dbo'"
        MyConn.Execute Sqlstr, 64
        '在当前数据库中建立别名?
        
        LabSysInfo = "正在建立新的数据库表"
        LabSysInfo.Refresh
        
        Do While Not Rst.EOF
            CreateTableStr = Trim(Rst!语句)
            MyConn.Execute CreateTableStr, 64
            Rst.MoveNext
        Loop
        Rst.Close
        MyConn.Close
    Else
        MsgBox "安装盘出现错误！", 48, "请与开发商联系"
        Exit Sub
    End If
    
    SQL = "SELECT * FROM 数据表拷贝 ORDER BY 序号"
    Set Rst = gclsDatabase.RDOSelect(SQL)
    If Rst.RowCount > 0 Then
        connstr = "Driver={SQL SERVER};SERVER=(LOCAL);UID=" & Trim(txtUID) & ";PWD=" & Trim(txtPWD) & ";DATABASE=" & dbName
        MyConn.Open connstr
        
        LabSysInfo = "正在向新的数据库表" & Chr(13) & Chr(10) & "中拷贝初始数据"
        LabSysInfo.Refresh
        
        Do While Not Rst.EOF
            CreateTableStr = Replace(Trim(Rst!语句), "^", "'")
            CreateTableStr = Replace(CreateTableStr, "|", ",")
            
            MyConn.Execute CreateTableStr, 64
            Rst.MoveNext
        Loop
        Rst.Close
        
        '判断光驱中的盘是否为安装盘=1表示不是安装盘，=2表示没有光驱
er1:
        If CheckSouPath = 1 Then
            i = MsgBox("在" & CdPath & "里找不到奔腾2000网络办公管理系统的安装盘！如要继续安装系统，请将系统的安装盘插入指定光驱；按取消退出安装过程。", vbOKCancel, "系统提示")
            If i = vbCancel Then

                MyConn.Close
                Set mycon = Nothing
                connstr = "Driver={SQL SERVER};SERVER=(local);UID=" & Trim(txtUID) & ";PWD=" & Trim(txtPWD) & ";DATABASE=master"
                MyConn.Open connstr
                
                Sqlstr = "drop database " & dbName
                MyConn.Execute Sqlstr, 64
                
                If SqlVer = "SQL65" Then
                    'dbname  "DEV
                    Sqlstr = "sp_dropdevice " & dbName & "DEV"
                    MyConn.Execute Sqlstr, 64
                    
                    Sqlstr = "sp_dropdevice " & dbName & "LOG"
                    MyConn.Execute Sqlstr, 64
                End If
                Set fs = CreateObject("Scripting.FileSystemObject")
                tempPath = Mid(Trim(txtFilePath), 1, Len(Trim(txtFilePath)) - 1)
    
                fs.Deletefolder tempPath, True
                Set fs = Nothing
                End
            Else
                GoTo er1
            End If
        ElseIf CheckSouPath = 2 Then
            MsgBox "奔腾2000网络办公管理系统必须在有光驱的服务器上安装！", 48, "系统提示"
            End
        End If

        '复制系统文件
        LabSysInfo = "正在安装系统文件，请稍等！"
        LabSysInfo.Refresh
        
        If CopyFile = 1 Then
            MsgBox "系统安装未成功，请与开发商联系！", 48, "系统提示"
            End
        End If
        
        LabSysInfo = "正在设置WEB信息，请稍等！"
        LabSysInfo.Refresh
        
        '设置IIS
        If SetIIS = False Then
            MsgBox "系统安装未成功，请与开发商联系！", 48, "系统提示"
            End
        End If

        '插入主页路径、域名、服务器名
        SName = GetPrimaryDCName("", "")
        MySql = "insert into mainpagepath values('" & AimPath & "\','" & txtDomain & "','" & SName & "')"
        MyConn.Execute MySql, 64

        MyConn.Close
        
        SQL = "select max(WebId) from WebSet"
        Set Rst = gclsDatabase.RDOSelect(SQL)
        If IsNull(Rst(0)) Then
            SQL = "insert into WebSet values(1,'" & Trim(txtWebName) & "','" & Trim(dbName) & "')"
            
        Else
            i = Rst(0) + 1
            SQL = "insert into WebSet values(" & i & ",'" & Trim(txtWebName) & "','" & Trim(dbName) & "')"
            
        End If
        Rst.Close
        i = gclsDatabase.RDOInsert(SQL)
        
        '写注册表服务器名，数据库
        SaveSetting "bkbtinfo", "919", "servername", SName
        SaveSetting "bkbtinfo", "919", "dbname", dbName

    Else
        Rst.Close
        
        gclsDatabase.CloseRDODatabaseConnection
        Set gclsDatabase = Nothing
        
        MsgBox "安装盘出现错误！", 48, "请与开发商联系"
        Exit Sub
        
    End If
    
    Screen.MousePointer = 0
    
    Set MyConn = Nothing
    gclsDatabase.CloseRDODatabaseConnection
    Set gclsDatabase = Nothing

    Unload Me
    Register.Show
    
End Sub

Private Sub cmdPath_Click()
    AimPath = "c:"
    frmPath.Show 1
End Sub




Private Sub txtDB_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub


Private Sub txtDomain_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub txtPWD_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub txtUID_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub

Private Sub txtWebName_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub