frmmain.frm

微软msde

        'ToDo: 设置 common dialog 控件的标志和属性
        .ShowOpen
        If Trim(.FileName) = "" Then
            Exit Sub
        Else
            Open dlgCommonDialog.FileName For Input As #1 '获取文件的句柄＃1并打开文件
            Dim nextline As String
            temptext = ""
            '因为以文本格式打开可能显示在form中的格式有预料不到的结果，保险起见将对文件文本逐行读入
            Do While Not EOF(1)
                Line Input #1, nextline '读入文件一行，文件指针自动指向下一行
                temptext = temptext + nextline + Chr(13) + Chr(10) '在读入行最后加入换行符号
            Loop
            Close #1 '关闭文件
            sfile = .FileName
        End If
    End With
    On Error GoTo err
    '将读入内容导入新打开的编辑文本中
    LoadNewDoc
    ActiveForm.rtfText.Text = Trim(temptext)
    If Right$(ActiveForm.rtfText.Text, 1) = Chr(0) Then
    ActiveForm.rtfText.Text = Left$(ActiveForm.rtfText.Text, Len(ActiveForm.rtfText.Text) - 1)
    End If
    ActiveForm.Caption = sfile
    Exit Sub
err:
    MsgBox err.Description
End Sub

Private Sub mnuFileNew_Click()
    LoadNewDoc
    ActiveForm.StatusBar1.Panels(4).Text = Me.Combo1.Text
    comboReflash
End Sub

Private Sub mnuFiledisconnect_Click()
Do Until ActiveForm Is Nothing
 mnuFileClose_Click
Loop
End Sub

Private Sub mnuFileconnect_Click()
    '应做:添加 'mnuFileconnect_Click' 代码。
    frmLogin.Show
End Sub


Private Sub directrun_Click()
    Dim dirtext As String
    errrow = 0
    Dim errorline As Integer
    Dim errdesp As String
    Dim result As String
    Dim rownum As Integer
    Dim temp As String
    
        rownum = 0
    dlgCommonDialog.ShowOpen
    If dlgCommonDialog.FileName <> "" Then
        u = MsgBox("是否要运行脚本？", 1)
        If u = 1 Then
            Me.MousePointer = 11 '改变鼠标样子
            Dim nextline As String
            Dim dircom As ADODB.command
            Dim trs As Recordset
            Set dircom = New ADODB.command
            dircom.ActiveConnection = adoconn
            Open dlgCommonDialog.FileName For Input As #1
            
            Do While Not EOF(1)
                Line Input #1, nextline
                dirtext = dirtext + nextline + Chr(13) + Chr(10)
                nextline = Trim(RemoveTabAndEnter(nextline))
                rownum = rownum + 1
                If LCase$(Trim(nextline)) = "go" Then
                    dircom.CommandText = result
                    result = ""
                On Error GoTo erro
                    dircom.Execute , , 1
                    errrow = rownum
                Else
                    result = result + nextline + Chr(13) + Chr(10)
                End If
            Loop
            Close #1
            If result <> "" Then
                dircom.CommandText = result
                dircom.Execute , , 1
            End If
            Me.MousePointer = 0 '改变鼠标样子
            If v = 1 Then
                w = MsgBox(errdesp + Chr(13) + Chr(10) + "completed" + Chr(13) + Chr(10) + "是否调试脚本?", 1)
                If w = 1 Then
                    LoadNewDoc
                    ActiveForm.Caption = dlgCommonDialog.FileName
                    ActiveForm.rtfText.Text = dirtext
                    ActiveForm.Text1.Text = errdesp
                    dlgCommonDialog.FileName = ""
                End If
            Else
                MsgBox "completed"
            End If
        End If
    End If
        Exit Sub
erro:
        If Mid$(err.Description, 48, 2) = "第 " Then '如果是英语版本msde则将条件语句换成“Mid$(Text1.text, 48, 5) = "Line " ”
            errorline = Val(Mid$(err.Description, 50)) + errrow '如果是英语版本msde则将换成(Text1.text, 53)
            errdesp = errdesp + Left$(err.Description, 49) & errorline & Mid$(err.Description, InStr(err.Description, ":") - 1) + Chr(13) + Chr(10)
        Else
            errdesp = errdesp + err.Description + Chr(13) + Chr(10)
        End If
        v = 1
        Resume Next
End Sub




Private Sub mnuFileRun_click()
    Dim temptext As String
    errrow = 0
    ActiveForm.Text1.Text = ""
If ActiveForm.rtfText.Text = "" Then
         MsgBox "请先打开一个脚本文件", 0, "错误信息"
Else
        ActiveForm.Grid1(0).Visible = True
        ActiveForm.prev.Enabled = False
        ActiveForm.next.Enabled = False
        ActiveForm.Text3.Text = 0
        
        temptext = ActiveForm.rtfText.Text
        Dim errorline As Integer
        Dim result As String
        Dim rownum As Integer
        Dim temp As String
        
        currgN = 0
        rownum = 0
 '网格视图初始化
        Me.MousePointer = 11 '改变鼠标样子
        On Error GoTo goon
        
        If ActiveForm.rtfText.seltext = "" Then
           Do
                '得到当前运行脚本的第rownum行，temp存放该行的文本内容
                Call TB_GetLine(ActiveForm.rtfText.hwnd, rownum, temp)
                rownum = rownum + 1 '读取指针指向下一行
                temp = Trim(temp)
                temp = RemoveTabAndEnter(temp) '出去tab键字符chr（9）和该行最后的换行符chr（13）
                '判断该行是否为go语句或文件末尾
                If LCase$(Trim(temp)) = "go" Or temp = Chr(0) Then
                    '如果是的话将go注释掉，因为msde引擎不认识go语句
                    result = result + " " + Chr(13) + Chr(10)
                    ActiveForm.com.CommandText = result
                    result = ""
                    Set trs = New ADODB.Recordset
                    Set trs = ActiveForm.com.Execute(, , adExecuteAsync)
                If trs.Fields.Count <> 0 Then
                  Do Until trs Is Nothing
                   '动态生成grid显示有数据集返回的数据信息
                    currgN = currgN + 1
                    If currgN > ActiveForm.gridn Then
                    Load ActiveForm.Grid1(currgN)
                    End If
                  '  ActiveForm.Grid1(currgN).Clear
                   ' ActiveForm.Grid1(currgN).ClearStructure
                    Set ActiveForm.Grid1(currgN).DataSource = trs
                    ActiveForm.Grid1(currgN).Refresh
                    Set trs = trs.NextRecordset
                  Loop
                End If
                    
goon1:
                    '记住目前读到的行数，为报错处理定位错误行做准备
                    errrow = rownum
                Else
                    result = result + temp + Chr(13) + Chr(10)
                End If
            
            Loop While temp <> Chr(0) '如果已经到达文件末尾则退出循环
    Else
        Dim seltext As String
        ActiveForm.com.CommandText = ActiveForm.rtfText.seltext
        Set trs = New ADODB.Recordset
        Set trs = ActiveForm.com.Execute(, , adExecuteAsync)
        If trs.Fields.Count <> 0 Then
            Do Until trs Is Nothing
            '动态生成grid显示有数据集返回的数据信息
                currgN = currgN + 1
                If currgN > ActiveForm.gridn Then
                    Load ActiveForm.Grid1(currgN)
                End If
                    Set ActiveForm.Grid1(currgN).DataSource = trs
                    ActiveForm.Grid1(currgN).Refresh
                    Set trs = trs.NextRecordset
                  Loop
                End If
    End If
    
    ActiveForm.Text1.Text = ActiveForm.Text1.Text + "completed"
End If
    If currgN > 0 Then
    ActiveForm.Grid1(1).Visible = True
    ActiveForm.Text3.Text = 1
    If currgN > 1 Then ActiveForm.next.Enabled = True
    ActiveForm.Grid1(0).Visible = False
    End If
    If currgN > ActiveForm.gridn Then
    ActiveForm.gridn = currgN
    End If
    Call comboReflash '刷新下拉列表框
    Me.MousePointer = 0 '改变鼠标样子
    Exit Sub
goon:
    If err.Number = 3251 Or err.Number = 30022 Then
    a = currgN
    Unload ActiveForm.Grid1(a)
    currgN = currgN - 1
    GoTo goon1
    End If
    If Mid$(err.Description, 48, 2) = "第 " Then '如果是英语版本msde则将条件语句换成“Mid$(Text1.text, 48, 5) = "Line " ”
        errorline = Val(Mid$(err.Description, 50)) + errrow '如果是英语版本msde则将换成(Text1.text, 53)
        ActiveForm.Text1.Text = ActiveForm.Text1.Text + Left$(err.Description, 49) & errorline & Mid$(err.Description, InStr(err.Description, ":") - 1) + Chr(13) + Chr(10)
    Else
        ActiveForm.Text1.Text = ActiveForm.Text1.Text + err.Description + Chr(13) + Chr(10)
    End If
  Resume Next
End Sub

  
  
  
  
  '将连接能访问的数据库导入combobox下拉列表框中
Private Function comboReflash()
    temp = ActiveForm.StatusBar1.Panels(4).Text
    ActiveForm.com.CommandText = "use [master] select * from sysdatabases"
    '定义查询数据库返回结果的数据集
    Set trs = New ADODB.Recordset
    Set trs = ActiveForm.com.Execute(, , adCmdText)
    Dim n As Integer
   '清空原combobox中item
    n = Combo1.ListCount - 1
    While n >= 0
    Combo1.RemoveItem n
    n = n - 1
    Wend
    '重新添加item
    n = 0
    While Not trs.EOF
    Combo1.AddItem trs.Fields("name"), n
    n = n + 1
    trs.MoveNext
    Wend
    Combo1.Text = temp
    ActiveForm.com.CommandText = "use [" + Combo1.Text + "]"
    ActiveForm.com.Execute , , adCmdText
End Function
'将菜单转换成连接的状态
Private Function CMenStaToC()
        Me.mnuFileconnect.Enabled = False
        Me.mnuEditCopy.Enabled = True
        Me.mnuEditCut.Enabled = True
        Me.mnuEditPaste.Enabled = True
        Me.mnuFileClose.Enabled = True
        Me.mnuFiledisconnect.Enabled = True
        Me.mnuFileNew.Enabled = True
        Me.mnuFileOpen.Enabled = True
        Me.mnuFilePrint.Enabled = True
        Me.mnuFileSave.Enabled = True
        Me.mnuFileSaveAs.Enabled = True
        Me.mnuFilerun.Enabled = True
        Me.mnuWindowCascade.Enabled = True
        Me.mnuWindowTileHorizontal.Enabled = True
        Me.mnuWindowTileVertical.Enabled = True
        Me.tbToolBar.Enabled = True
        Me.directrun.Enabled = True
End Function
'将菜单转换成断开连接的状态
Private Function CMenStaToD()
        Me.tbToolBar.Enabled = False
        Me.mnuFileconnect.Enabled = True
        Me.mnuEditCopy.Enabled = False
        Me.mnuEditCut.Enabled = False
        Me.mnuEditPaste.Enabled = False
        Me.mnuFileClose.Enabled = False
        Me.mnuFiledisconnect.Enabled = False
        Me.mnuFileNew.Enabled = False
        Me.mnuFileOpen.Enabled = False
        Me.mnuFilePrint.Enabled = False
        Me.mnuFileSave.Enabled = False
        Me.mnuFileSaveAs.Enabled = False
        Me.mnuFilerun.Enabled = False
        Me.mnuWindowCascade.Enabled = False
        Me.mnuWindowTileHorizontal.Enabled = False
        Me.mnuWindowTileVertical.Enabled = False
        Me.directrun.Enabled = False
        Me.Combo1.Text = ""
End Function
'特定功能的工具条事件处理，数据库操作对象只限mcad_zs，备份文件只限mcadnt
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    On Error Resume Next
    Select Case Button.Key
        Case "Run"
            Dim RSFform As New RunSqlFile
            RSFform.Show
        Case "Restore"
             Dim resform As New restoreDB
             resform.Show
        Case "BackUp"
            Call backup
        End Select
End Sub