frmcreate.frm

来自「OA编程 源代码」· FRM 代码 · 共 432 行

VERSION 5.00
Begin VB.Form FrmCreate 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "新增Web站点"
   ClientHeight    =   4395
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5775
   Icon            =   "FrmCreate.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4395
   ScaleWidth      =   5775
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton Command1 
      Caption         =   "上一步"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   345
      Index           =   2
      Left            =   2400
      TabIndex        =   3
      Top             =   3900
      Width           =   1515
   End
   Begin VB.CommandButton Command1 
      Caption         =   "开始安装"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   345
      Index           =   0
      Left            =   4230
      TabIndex        =   2
      Top             =   3900
      Width           =   1515
   End
   Begin VB.CommandButton Command1 
      Caption         =   "退出安装程序"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   345
      Index           =   1
      Left            =   90
      TabIndex        =   1
      Top             =   3900
      Width           =   1425
   End
   Begin VB.TextBox Text1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000004&
      ForeColor       =   &H00400000&
      Height          =   3735
      Left            =   60
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   0
      Width           =   5685
   End
End
Attribute VB_Name = "FrmCreate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private CanExit As Boolean
Private Sub Command1_Click(Index As Integer)
Dim MyConn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim Rst1 As New ADODB.Recordset
Dim Rst2 As New ADODB.Recordset
Dim j, DbSize As Integer
Dim TempV As String
Dim dbpath, tempPath As String
Dim exitUser As Integer
Dim Myary
Dim Sqlstring As String
Dim Rtnvalue As Integer
Dim Txt As TextStream
Dim Fso As New FileSystemObject
Dim Maxval As Integer
Dim File As File
Dim Errinfo As String

'表示程序安装状态，如果已经创建了数据库或Web站点，将其删除
Dim State As String

Select Case Index
        Case 0
        
        'On Error GoTo err
        If Command1(0).Caption = "安装成功" Then
           Unload Me
           MDIForm1.Show
           Exit Sub
        End If
        CanExit = False
        Me.MousePointer = 13
        Command1(0).Enabled = False
        
        MyConn.ConnectionString = Pubsaconnstring
        MyConn.Open
        
        If err.Number <> 0 Then
           MsgBox "数据库无法连接！", 64
           Me.MousePointer = 0
           Set MyConn = Nothing
           Exit Sub
        End If
            
            
        Command1(0).Enabled = False
        Command1(1).Enabled = False
        Command1(2).Enabled = False
        
        
        State = 0
        
        '复制系统文件
        Text1.Text = Text1.Text & vbCrLf & "●复制系统文件"
        Text1.Refresh
        
        If CopyFile = 0 Then
            Text1.Text = Text1.Text & vbCrLf & "------系统文件复制完成" & vbCrLf
            
        Else
            Text1.Text = Text1.Text & vbCrLf & "------系统文件复制失败！" & vbCrLf
            GoTo err
        End If

        Text1.Refresh
        
        '创建Web站点
        Text1.Text = Text1.Text & vbCrLf & "●创建Web站点!"
        If SetIIS(Aimpath) = False Then
           Text1.Text = Text1.Text & vbCrLf & "------创建Web站点失败（" & err.Description & ")" & vbCrLf
           Me.MousePointer = 0
           Set MyConn = Nothing
           Exit Sub
        Else
           Text1.Text = Text1.Text & vbCrLf & "------成功创建Web站点" & vbCrLf
        End If
        Text1.Refresh
        
        State = 1
        
        '创建数据库
        Text1.Text = Text1.Text & vbCrLf & "●创建数据库！"
        Sqlstr = " CREATE DATABASE " & Curdb
        MyConn.Execute Sqlstr, 64
        If err.Number <> 0 Then
            '删除已经创建的Web站点
            If WebName <> "" Then
            DelWeb (WebName)
            End If
            Text1.Text = Text1.Text & vbCrLf & "------创建数据库失败（" & err.Description & ")" & vbCrLf
            Me.MousePointer = 0
            Set MyConn = Nothing
            Exit Sub
        Else
            Text1.Text = Text1.Text & vbCrLf & "------创建数据库成功" & vbCrLf
        End If
        Text1.Refresh
        
        State = 2
        
        err.Clear
        '设置新的连接
        If MyConn.State = 1 Then
           MyConn.Close
        End If
        MyConn.Open Pubsaconnstring
        '判断数据库用户bkbt919是否已存在
        Sqlstr = "select name from syslogins where name='bkbt919'"
        Set rs = MyConn.Execute(Sqlstr)
        If rs.EOF Then
           '创建用户
           Sqlstr = "sp_addlogin 'bkbt919', '919bkbt', '" & Curdb & "'"
           MyConn.Execute Sqlstr, 64
        End If
        MyConn.Execute ("use " & Curdb)
        '使用户bkbt919有当前数据库的权限
        Sqlstr = "sp_grantdbaccess 'bkbt919'"
        MyConn.Execute Sqlstr, 64
        
        '增加用户的db_owner角色
        Sqlstr = "sp_addrolemember 'db_owner', 'bkbt919'"
        MyConn.Execute Sqlstr, 64
               
        
        
        err.Clear
        Text1.Refresh
        
        
        '创建基础数据表(包含基本栏目信息的数据导入)
        If BuildTable(MyConn) = 1 Then
            Text1.Text = Text1.Text & vbCrLf & "------基础表创建成功！" & vbCrLf
        Else
           Text1.Text = Text1.Text & vbCrLf & "------基础表创建失败！" & vbCrLf
           GoTo err
        End If
        
        Text1.Refresh
        
        '插入主页路径
        MyConn.Execute ("use " & Curdb)
        MySQL = "insert into mainpagepath values('" & Aimpath & "\','bkbt','" & Sevname & "')"
        MyConn.Execute MySQL, 64
        
        
        
        '更新本地数据表
        sql = "select max(webid) from webset"
        Set Rst1 = PubMdbConn.Execute(sql)
        If IsNull(Rst1(0)) Or Rst1(0) = "" Then
            Maxval = 0
        Else
            Maxval = Rst1(0) + 1
        End If
            
        sql = "insert into webset (webid,webname,sevname,dbname) values('" & Maxval & "','" & WebName & "','" & Sevname & "','" & dbName & "')"
        PubMdbConn.Execute sql
        

         
        

        
               
        '改写服务器Global.asa文件
        Set File = Fso.GetFile(Aimpath & "\global.asa")
        File.Attributes = Archive
        
        
        Set Txt = Fso.OpenTextFile(Aimpath & "\global.asa")
        sql = Txt.ReadAll
        sql = Replace(sql, "SERVERNAME=######", "SERVERNAME=" & Chr(34) & Sevname & Chr(34), , , vbTextCompare)
        sql = Replace(sql, "DATABASE=######", "DATABASE=" & Chr(34) & Curdb & Chr(34), , , vbTextCompare)
        Txt.Close
               
        Set Txt = Fso.OpenTextFile(Aimpath & "\global.asa", ForWriting)
        Txt.Write sql
        Txt.Close
        Set Fso = Nothing
        
        '为邮件进行设定
        Call CfgforMail(Sevname, dbName)
        
        
        Me.MousePointer = 0
        
        Set MyConn = Nothing
        Set rs = Nothing
        Set Rst1 = Nothing
        Set Rst2 = Nothing
        Command1(0).Caption = "安装成功"
        
        
        Command1(0).Enabled = True
        Command1(1).Enabled = False
        Command1(2).Enabled = False
        Screen.MousePointer = 0
        
        CanExit = True
        Exit Sub
        
err:
On Error GoTo 0
        Errinfo = err.Description
        '删除文件
        On Error Resume Next
        Select Case State
               Case 1
                  Rtnvalue = DelWeb(WebName)
                  
               Case 2
                  Rtnvalue = DelWeb(WebName)
                  MyConn.Execute "use master"
                  MyConn.Execute "drop database " & Curdb
        
        End Select
        
        
        err.Clear
        
        Command1(0).Enabled = False
        Command1(1).Enabled = True
        Command1(2).Enabled = True
        Text1.Text = Text1.Text & vbCrLf & "------出现意外错误！(" & Errinfo & ")"
        Text1.Refresh
        Screen.MousePointer = 0
        Set MyConn = Nothing
        
        Set rs = Nothing
        Set Rst1 = Nothing
        Set Rst2 = Nothing
        Set gclsDatabase = Nothing
        CanExit = True
        
        
        
        Case 1
        Unload Me
        Case 2
        Me.Hide
        FrmShixian.Show 1
End Select

Me.MousePointer = 1
End Sub

Private Sub Form_Activate()
On Error Resume Next
Dim i As Integer
Dim TestPath As Integer
Dim MyConn As New ADODB.Connection
CanExit = True
Text1.Text = "数据库名称:" & Curdb & vbCrLf
Text1.Text = Text1.Text & "Web站点名称:" & WebName & vbCrLf
Text1.Text = Text1.Text & "程序安装路径:" & Aimpath
Text1.Text = Text1.Text & vbCrLf & "--------------------------------------------------" & vbCrLf
i = 0

Text1.Text = Text1.Text & vbCrLf & "●测试数据库连接"

MyConn.ConnectionString = Pubsaconnstring
MyConn.Open


If err.Number <> 0 Then
   i = i + 1
   Text1.Text = Text1.Text & vbCrLf & "------数据库连接失败！" & vbCrLf
Else
   Text1.Text = Text1.Text & vbCrLf & "------数据库连接成功！" & vbCrLf
End If
err.Clear

Text1.Text = Text1.Text & vbCrLf & "●测试Web站点是否存在"
If WebExist(WebName) = 1 Then
    Text1.Text = Text1.Text & vbCrLf & "------当前Web站点已经存在！" & vbCrLf
    i = i + 1
Else
    Text1.Text = Text1.Text & vbCrLf & "------Web站点测试成功！" & vbCrLf
End If

err.Clear

Text1.Text = Text1.Text & vbCrLf & "●检测数据库是否存在"
'检测数据库是否存在
MyConn.Execute ("use " & Curdb)
If err.Number = 0 Then
   Text1.Text = Text1.Text & vbCrLf & "------要创建的数据库已经存在！" & vbCrLf
   i = i + 1
Else
   Text1.Text = Text1.Text & vbCrLf & "------数据库检测通过！" & vbCrLf
End If
err.Clear

'判断光驱中的盘是否为安装盘=1表示不是安装盘，=2表示没有光驱
Text1.Text = Text1.Text & vbCrLf & "●检测安装盘!"
TestPath = CheckSourPath
If TestPath = 1 Then
   Text1.Text = Text1.Text & vbCrLf & "------安装盘不存在" & vbCrLf
   i = i + 1
Else
   Text1.Text = Text1.Text & vbCrLf & "------安装盘正确" & vbCrLf
End If

If i = 0 Then
   Command1(0).Enabled = True
Else
   Command1(0).Enabled = False
End If

Set MyConn = Nothing


End Sub

Private Sub Form_Load()
    '窗体居中
    Me.Move Screen.Width / 2 - Me.Width / 2, Screen.Height / 2 - Me.Height / 2 - 600
    Call LoadSkin(Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
If CanExit = False Then
   MsgBox "程序正在运行，无发退出！", 64
   Cancel = 1
   Exit Sub
End If
Unload FrmShixian
Unload FrmInfoCol
Unload FrmConfigMain
If Command1(0).Caption <> "安装成功" Then
   End
End If
End Sub




Private Sub Text1_Change()
Dim Scrrtn As Long
Scrrtn = SendMessage(Text1.hwnd, WM_VSCROLL, SB_BOTTOM, Null)

End Sub