register.frm

OA编程 源代码

        MyConn.Open connstr
        
        CreateTableStr = "sp_dboption bkbtinfo,'trunc. log on chkpt.',true"
        MyConn.Execute CreateTableStr, 64
        
        LabSysInfo = "正在建立新的数据库表"
        LabSysInfo.Refresh
        
        Do While Not rst.EOF
            CreateTableStr = Trim(rst!语句)
            MyConn.Execute CreateTableStr, 64
            rst.MoveNext
        Loop
        
        MyConn.Close
    Else
        rst.Close
        
        gclsDatabase.CloseRDODatabaseConnection
        Set gclsDatabase = Nothing
    
        If Len(Trim(PathName)) <> 0 Then
            Return_Var = SetCurrentDirectory(PathName)
        End If
        
        End
    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=bkbtinfo"
        MyConn.Open connstr
        
        LabSysInfo = "正在向新的数据库表" & Chr(13) & Chr(10) & "中拷贝初始数据"
        LabSysInfo.Refresh
        
        Do While Not rst.EOF
            CreateTableStr = Replace(Trim(rst!语句), "^", "'")
            MyConn.Execute CreateTableStr, 64
            rst.MoveNext
        Loop
        
        '复制系统文件
        LabSysInfo = "正在安装系统文件，请稍等！"
        LabSysInfo.Refresh
        
        If CopyFile = 1 Then
            MsgBox "系统安装未成功，请与开发商联系！", 48, "系统提示"
            End
        End If
        
        LabSysInfo = "正在设置WEB信息，请稍等！"
        LabSysInfo.Refresh
        
        

        '插入主页路径、域名、服务器名
        SName = GetPrimaryDCName("", "")
        MySql = "insert into mainpagepath values('" & Aimpath & "\','" & txtDomain & "','" & Sevname & "')"
        MyConn.Execute MySql, 64
        'MySql = "insert into "
        MyConn.Close
    Else
        rst.Close
        
        gclsDatabase.CloseRDODatabaseConnection
        Set gclsDatabase = Nothing
        
        If Len(Trim(PathName)) <> 0 Then
            Return_Var = SetCurrentDirectory(PathName)
        End If
        
        End
    End If
    
    Screen.MousePointer = 0
    
    Set MyConn = Nothing
    gclsDatabase.CloseRDODatabaseConnection
    Set gclsDatabase = Nothing
    
    
    MsgBox "数据库安装成功！" & Chr(13) & Chr(10) _
            & "请重新启动“Web管理控制台”，" & Chr(13) & Chr(10) _
            & "选择Web目录和初始化NT的用户！", , "系统信息"
    
    End
DatabaseError:
    Screen.MousePointer = 0
    
    Call ManageQuit
End Sub

Private Sub CmdIISInit_Click()
    Dim MyConn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim connstr As String
    Dim CreateDeviceStr As String
    Dim CreateDataStr As String
    Dim CreateTableStr As String
    Dim i As Integer
    Dim j As Integer
        
    i = 1
    
    rdoEngine.rdoRegisterDataSource "bkbtinfo", _
        "Microsoft Access Driver (*.mdb)", True, _
        "DBQ=" & Trim(PathName) & "\bkbtinfo.mdb"
    
    Set gclsDatabase = New DataAccess
    Call gclsDatabase.CreateRDODatabaseConnection
    
    connstr = "Driver={SQL SERVER};SERVER=(LOCAL);UID=bkbt919;PWD=919bkbt;DATABASE=bkbtinfo"
    MyConn.Open connstr

    sql = "SELECT * FROM FieldInfo"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO FieldInfo VALUES("
        sql = sql & Trim(str(rs(0))) & ","
        sql = sql & Trim(str(rs(1))) & ","
        sql = sql & "'" & Trim(rs(2)) & "',"
        sql = sql & "'" & Trim(rs(3)) & "',"
        sql = sql & Trim(str(rs(4))) & ","
        sql = sql & Trim(str(rs(5))) & ","
        sql = sql & "'" & Trim(rs(6)) & "',"
        sql = sql & Trim(str(rs(7))) & ","
        sql = sql & Trim(str(rs(8))) & ","
        sql = sql & Trim(str(rs(9))) & ","
        sql = sql & "'" & Trim(rs(10)) & "',"
        sql = sql & Trim(str(rs(9))) & ")*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM ListRecord"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO ListRecord VALUES("
        sql = sql & "'" & Trim(rs(1)) & "',"
        sql = sql & "'" & Trim(rs(2)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM mainpagestyle"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO mainpagestyle VALUES("
        sql = sql & "'" & Trim(rs(0)) & "',"
        sql = sql & "'" & Trim(rs(1)) & "',"
        sql = sql & "'" & Trim(rs(2)) & "',"
        sql = sql & "'" & Trim(rs(3)) & "',"
        sql = sql & "'" & Trim(rs(4)) & "',"
        sql = sql & "'" & Trim(rs(5)) & "',"
        sql = sql & Trim(str(rs(6))) & ","
        sql = sql & "'" & Trim(rs(7)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM NewsStyle"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO NewsStyle VALUES("
        sql = sql & "'" & Trim(rs(0)) & "',"
        sql = sql & Trim(str(rs(1))) & ","
        sql = sql & "'" & Trim(rs(2)) & "',"
        sql = sql & "'" & Trim(rs(3)) & "',"
        sql = sql & Trim(str(rs(4))) & ","
        sql = sql & "'" & Trim(rs(5)) & "',"
        sql = sql & "'" & Trim(rs(6)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM TableInfo"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO TableInfo VALUES("
        sql = sql & Trim(str(rs(0))) & ","
        sql = sql & "'" & Trim(rs(1)) & "',"
        sql = sql & "'" & Trim(rs(2)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM treebase order by treeno"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO treebase VALUES("
        sql = sql & "'" & Trim(rs(0)) & "',"
        sql = sql & "'" & Trim(rs(1)) & "',"
        sql = sql & Trim(str(rs(2))) & ","
        sql = sql & "'" & Trim(rs(3)) & "',"
        sql = sql & Trim(str(rs(4))) & ","
        sql = sql & Trim(str(rs(5))) & ","
        sql = sql & "'" & Trim(rs(6)) & "',"
        sql = sql & Trim(str(rs(7))) & ","
        sql = sql & "'" & Trim(rs(8)) & "',"
        sql = sql & "'" & Trim(rs(9)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    sql = "SELECT * FROM treedefault"
    Set rs = MyConn.Execute(sql, 64)
    Do While Not rs.EOF
        sql = "INSERT INTO 数据表拷贝 VALUES(" & Trim(str(i)) & ","
        sql = sql & "*INSERT INTO treedefault VALUES("
        sql = sql & "'" & Trim(rs(0)) & "',"
        sql = sql & Trim(str(rs(1))) & ","
        sql = sql & "'" & Trim(rs(2)) & "',"
        sql = sql & "'" & Trim(rs(3)) & "')*)"
        sql = Replace(sql, "'", "^")
        sql = Replace(sql, "*", "'")
        j = gclsDatabase.RDOInsert(sql)
        
        i = i + 1
        rs.MoveNext
    Loop

    rs.Close
    MyConn.Close
    Set MyConn = Nothing
    gclsDatabase.CloseRDODatabaseConnection
    Set gclsDatabase = Nothing
    
    End
End Sub


Private Sub Form_Load()
Dim Fso As FileSystemObject
Dim Tpath As String
Dim Windir  As String     '定义一个字符串变量用于保存windows系统目录
Dim windirleng   As Integer
Dim MI As Object

On Error GoTo err

    Set MI = CreateObject("crypt.clscrypt")
    If PubMdbConn.State = 1 Then
         PubMdbConn.Close
    End If
    PubMdbConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database\bkbtinfo.mdb;Persist Security Info=False"
    PubMdbConn.Open
    Call GetWebinfo
    
    If GetFirstInstall Then
        Unload Me
        FrmLicence.Show
        Exit Sub
    End If
    
    If Not MI.IsRegEdit Or err.Number <> 0 Then
        MsgBox MI.Errinfo, 64
        Set MI = Nothing
        Unload Me
        Exit Sub
    End If
 
    ProgName(0) = "SystemAsp\AppWizard\Input\AppInput.asp"
    ProgName(1) = "SystemAsp\AppWizard\Query\AppQuery.asp"
    ProgName(2) = "SystemAsp\AppWizard\Chang\AppQuery.asp"
    ProgName(3) = "SystemAsp\AppWizard\default\AppQuery.asp"
    
    'ProgName(3) = "SystemAsp\AppWizard\Input\AppInput.asp"
    'ProgName(4) = "SystemAsp\AppWizard\Query\AppQuery.asp"
    'ProgName(5) = "SystemAsp\AppWizard\Chang\AppQuery.asp"
    
    ContName(0) = "SystemAsp\Contract\input\inputcontract.asp"
    ContName(1) = "SystemAsp\Contract\query\SearchCont.asp"
    ContName(2) = "SystemAsp\Contract\chang\ModiCont.asp"
    
    FlowApp(0) = "SystemAsp\WorkFlow\SelPerson\ShowRoute.asp"
    FlowApp(1) = "SystemAsp\WorkFlow\BeginExm\ShowExm.asp"
    
    ColliName(0) = "SystemAsp\Contract\KindSearch\chaxun.asp"
    
    DocManage(0) = "SystemAsp\DocManage\FileUpload.asp"
    DocManage(1) = "SystemAsp\DocManage\SecureTypeEdit.asp"
    DocManage(2) = "SystemAsp\DocManage\SearchFiles\Begin.asp"
    DocManage(3) = "SystemAsp\DocManage\DelFiles\Begin.asp"
    
    
    SystemTools(0) = "SystemAsp\AppWizard\AppTable.asp"
    SystemTools(1) = "SystemAsp\Contract\CreaContStru.asp"
    SystemTools(2) = "SystemAsp\AppWizard\Tools\EditSelectInfo.asp"
    SystemTools(3) = "SystemAsp\GradeManage\CheckUser.asp"
    SystemTools(4) = "SystemAsp\WorkFlow\DefineFlow\workflow.asp"
    SystemTools(5) = "SystemAsp\WorkFlow\RouteDef\routedef.asp"
    SystemTools(6) = "SystemAsp\WorkFlow\RouteExm\routexm.asp"
    SystemTools(7) = "SystemAsp\WordTemp\AppDoc.asp"

    SystemApp(0) = "SystemAsp\DealNews\Provide\ProvideNews.asp"
    SystemApp(1) = "SystemAsp\DealNews\Check\CheckupNews.asp"
    SystemApp(2) = "SystemAsp\DealNews\Issue\IssueNews.asp"
    SystemApp(3) = "SystemAsp\E-mail\MailHome.asp"
    SystemApp(4) = "SystemAsp\WorkFlow\execFlow\DispFlow.asp"
    SystemApp(5) = "SystemAsp\WorkFlow\queryflow\allquery.asp"
    SystemApp(6) = "SystemAsp\BBS\Login1.asp"
    
    PathLength = 250
    PathName = Space(255)
    Return_Var = GetCurrentDirectory(PathLength, PathName)
    If Return_Var = 0 Then
        MsgBox "程序路径读错误！", vbExclamation, "系统信息"
        Exit Sub
    End If
    PathName = Mid(Trim(PathName), 1, Len(Trim(PathName)) - 1)

    rdoEngine.rdoRegisterDataSource "bkbtinfo", _
        "Microsoft Access Driver (*.mdb)", True, _
        "DBQ=" & Trim(App.Path) & "\database\bkbtinfo.mdb"
    
    Set gclsDatabase = New DataAccess
    Call gclsDatabase.CreateRDODatabaseConnection

    sql = "SELECT * FROM WebSet order by webid"
    Set rst = gclsDatabase.RDOSelect(sql)
    If rst.RowCount > 0 Then
        cmbWebName.Clear
        i = 0
        Do Until rst.EOF
        
            cmbWebName.AddItem rst("webname")
            cmbWebName.ItemData(i) = rst(0)
            i = i + 1
            rst.MoveNext
        Loop
        rst.Close
        cmbWebName.ListIndex = 0
    
    End If
    
    '换皮肤
    Call ChangeSkinInitial
    Call LoadSkin(Me)
    
    Exit Sub
err:
MsgBox err.Description, 64
Unload Me
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  '  SkinObj.ExitNow
  '  Set SkinObj = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set Pubsaconn = Nothing

End Sub

Private Sub TxtName_KeyPress(KeyAscii As Integer)
    If KeyCode = 13 Then
        SendKeys "{tab}"
    End If

End Sub


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

End Sub