module1.bas

微软msde

Attribute VB_Name = "Module1"
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
'访问键值用的api
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Const HKEY_CURRENT_USER = &H80000001 '访问注册表信息
Const EM_GETLINE = &HC4
Const EM_LINELENGTH = &HC1
Const EM_GETSEL = &HB0
Const EM_LINEFROMCHAR = &HC9
Const EM_LINEINDEX = &HBB
Const WM_USER = &H400
Const EM_SETTARGETDEVICE = (WM_USER + 72)
Public errrow As Integer
Public fMainForm As frmMain
Public username As String '登陆数据库用户名
Public computername As String '登陆数据库服务器名
Public adoconn As ADODB.Connection
Public usedb As String
Public lDocumentCount As Integer
Public currgN As Integer
Public bakpath As String
Public dbpath As String
Public sqlpath As String



'Public adocom As ADODB.Command



Sub Main()
'获取备份文件以及数据库和sql脚本存放路径
'从注册表获得信息
    Dim lauth As String
    Dim hKey As Long, ret As Long, lenData As Long, typeData As Long
    Dim Name As String
    Name = "zs_bakpath"
    RegOpenKey HKEY_CURRENT_USER, "ison", hKey
    
    RegQueryValueEx hKey, Name, 0, typeData, ByVal vbNullString, lenData
    bakpath = String(lenData, Chr(0))
    If bakpath <> "" Then
        RegQueryValueEx hKey, Name, 0, typeData, ByVal bakpath, lenData  '注意ByVal千万别忘了
        bakpath = Left(bakpath, InStr(bakpath, Chr(0)) - 1)
    End If
    
    Name = "zs_dbpath"
    RegQueryValueEx hKey, Name, 0, typeData, ByVal vbNullString, lenData
    dbpath = String(lenData, Chr(0))
    If dbpath <> "" Then
        RegQueryValueEx hKey, Name, 0, typeData, ByVal dbpath, lenData  '注意ByVal千万别忘了
        dbpath = Left(dbpath, InStr(dbpath, Chr(0)) - 1)
    End If
    
    Name = "zs_sqlpath"
    RegQueryValueEx hKey, Name, 0, typeData, ByVal vbNullString, lenData
    sqlpath = String(lenData, Chr(0))
    If sqlpath <> "" Then
        RegQueryValueEx hKey, Name, 0, typeData, ByVal sqlpath, lenData  '注意ByVal千万别忘了
        sqlpath = Left(sqlpath, InStr(sqlpath, Chr(0)) - 1)
    End If
    RegCloseKey hKey
'*****************************

    Dim prom As String
    Dim promlen As Long
    If VBA.command <> "" Then
        prom = VBA.command
        promlen = Len(prom)
        If Asc(prom) = 34 Then
        '判断是否是双引号,因为关联文件传进来得某些参数是带引号得
        prom = Mid(prom, 2, promlen - 2)
        End If
        '建立与msde的连接
        public_str_AdoPath = "PROVIDER=MSDASQL;Driver=SQL Server;server=;Database=master;"
        Set adoconn = New ADODB.Connection
        adoconn.ConnectionTimeout = 5
        adoconn.Open (public_str_AdoPath)
        '判断参数类型执行不同操作
        If prom = "0" Or prom = "1" Then
            If prom = "1" Then
                run (1)
            Else
                run (0)
            End If
        Else
          
         
            If prom = "2" Then
                backup
            Else
                Dim dircom As ADODB.command
                Set dircom = New ADODB.command
              
                If prom = "3" Then
                    dircom.ActiveConnection = adoconn
                    MousePointer = 11 '改变鼠标样子
                    dircom.CommandText = " RESTORE DATABASE [mcad_zs] FROM  DISK = N'" + bakpath + "mcad_zs.bak' WITH  FILE =1,NOUNLOAD,STATS = 10,RECOVERY,REPLACE,MOVE N'MCAD_zs' TO N'" + dbpath + "mcad_zs.mdf',MOVE N'MCAD_zs_log' TO N'" + dbpath + "mcad_zs_log.ldf'"
                    On Error GoTo erro1
                    dircom.Execute , , 1
                    Exit Sub
erro1:
                    MousePointer = 0 '改变鼠标样子
                    MsgBox err.Description + Chr(13) + Chr(10) + "数据库已经还原为最初的备份!"
                Else
                    If prom = "4" Then
                        Dim rst As ADODB.Recordset
                        Set rst = New ADODB.Recordset
                        dircom.ActiveConnection = adoconn
                        dircom.CommandText = "restore headeronly from disk='" + bakpath + "mcad_zs.bak'"
                        Set rst = dircom.Execute(, , 1)
                        Dim filen As Integer
                        While Not rst.EOF
                        filen = filen + 1
                        rst.MoveNext
                        Wend
                        dircom.CommandText = " RESTORE DATABASE [mcad_zs] FROM  DISK = N'" + bakpath + "mcad_zs.BAK' WITH  FILE =" & filen & ",NOUNLOAD,STATS = 10,RECOVERY,REPLACE,MOVE N'MCAD_zs' TO N'" + dbpath + "mcad_zs.mdf',MOVE N'MCAD_zs_log' TO N'" + dbpath + "mcad_zs_log.ldf'"
                        On Error GoTo erro2
                        dircom.Execute , , 1
                        Exit Sub
erro2:
                        MsgBox err.Description + Chr(13) + Chr(10) + "数据库已经还原为最近的备份!"
                        
                    Else
                        End
                    End If
                End If
            End If
         End If
    Else
        Dim fLogin As New frmLogin
        fLogin.Show vbModal
  
        If Not fLogin.OK Then
        '登录失败，退出应用程序
        End
        End If
        Unload fLogin
        Set fMainForm = New frmMain
        fMainForm.Show
    End If
End Sub

Public Sub GetCaretPos(ByVal TextHwnd As Long, LineNo As Long, ColNo As Long)
Dim i As Long, j As Long
Dim lParam As Long, wParam As Long
Dim k As Long

'首先向文本框传递EM_GETSEL消息以获取从起始位置到
'光标所在位置的字符数

i = SendMessage(TextHwnd, EM_GETSEL, wParam, lParam)
j = i / 2 ^ 16

'再向文本框传递EM_LINEFROMCHAR消息根据获得的字符
'数确定光标以获取所在行数

LineNo = SendMessage(TextHwnd, EM_LINEFROMCHAR, j, 0)
LineNo = LineNo + 1

'向文本框传递EM_LINEINDEX消息以获取所在列数

k = SendMessage(TextHwnd, EM_LINEINDEX, -1, 0)
ColNo = j - k + 1
End Sub

Public Function Reflash()
frmMain.Combo1.Text = ActiveForm.StatusBar1.Panels(4).Text
End Function

Public Function Srun(temp As String) As Integer
    v = MsgBox(temp + Chr(13) + Chr(10) + "是否运行该操作？", 1, "single sql operation")
    If v = 1 Then
        fMainForm.MousePointer = 11 '改变鼠标样子
        Dim scom As ADODB.command
        Set scom = New ADODB.command
        scom.ActiveConnection = adoconn
        scom.CommandText = temp
        scom.Execute , , 1
        MsgBox " successfully complete!!!", 0
        fMainForm.MousePointer = 0 '改变鼠标样子
        Srun = 1
    End If
End Function
Public Function TB_GetLine(ByVal hwnd As Long, ByVal whichLine As Long, Line As String)
Dim length As Long, bArr() As Byte, bArr2() As Byte, lc As Long

lc = SendMessage(hwnd, EM_LINEINDEX, whichLine, ByVal 0&)
If lc >= 0 Then
    length = SendMessage(hwnd, EM_LINELENGTH, lc, ByVal 0&)
    If length > 0 Then
        ReDim bArr(length + 1) As Byte, bArr2(length - 1) As Byte
        Call RtlMoveMemory(bArr(0), length, 2)
        Call SendMessage(hwnd, EM_GETLINE, whichLine, bArr(0))
        Call RtlMoveMemory(bArr2(0), bArr(0), length)
        Line = StrConv(bArr2, vbUnicode)
    Else
        Line = ""
    End If
Else
    Line = Chr(0)
End If
End Function
'消除每一行的tab按钮
Public Function RemoveTabAndEnter(temp As String) As String
    While Right$(temp, 1) = Chr(9) Or Right$(temp, 1) = Chr(13)
        temp = Left$(temp, Len(temp) - 1)
    Wend
    While Left$(temp, 1) = Chr(9)
        temp = Right$(temp, Len(temp) - 1)
    Wend
    RemoveTabAndEnter = temp
  End Function


Public Function backup()
            MousePointer = 11 '改变鼠标样子
            Dim dircom As ADODB.command
            Set dircom = New ADODB.command
            dircom.ActiveConnection = adoconn
            dircom.CommandText = "BACKUP DATABASE [mcad_zs] TO DISK=N'" + bakpath + "mcad_zs.bak' WITH  NOINIT ,  NOUNLOAD ,  NAME = N'mcad_zs_backup',  NOSKIP ,  STATS = 10,  NOFORMAT"
            On Error GoTo erro1
            dircom.Execute , , 1
            '写入备份文件信息
erro1:
             MousePointer = 0 '改变鼠标样子
             MsgBox err.Description + Chr(13) + Chr(10) + "数据库已经备份完毕!"
End Function

Public Function run(filen As Integer)
    MousePointer = 11 '改变鼠标样子
    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
    
            
            Dim nextline As String
            Dim dircom As ADODB.command
            Dim trs As Recordset
            Set dircom = New ADODB.command
            dircom.ActiveConnection = adoconn
            
            On Error GoTo erro1
            If filen = 0 Then
                Open sqlpath + "update.sql" For Input As #1 '获取文件的句柄＃1并打开文件
            Else
                Open sqlpath + "mcad_zsAUTHset.sql" For Input As #1
            End If
            On Error GoTo erro
            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 = ""
                
                    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
            MousePointer = 0  '改变鼠标样子
            MsgBox errdesp + Chr(13) + Chr(10) + "数据库存储过程执行完成", 1
    Exit Function
erro1:
    MsgBox err.Description
    Exit Function
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
        Resume Next
End Function