绿色SQL Server原理（10）VB6启动停止模块[GreenSQL.bas]

Option Explicit

'*******************************************

'绿色SQL Server模块

‘doStartSQLServe,启动SQL Server

‘doCheckSQLServerStatus,查找sqlservr.exe进程

‘doTerminateSQLServer, 杀掉sqlservr.exe进程

'*******************************************

Public Const listen_port = "7788" '监听端口

Public Const instance_name = "GreenSQL" 'SQL Server实例名

Private Const RegFile = "GreenSQL.reg" 'reg文件名

Private bSingleUser As Boolean   '单用户模式

'======================用于创建进程API函数常数定义=====================

Private Type PROCESS_INFORMATION

    hProcess As Long

    hThread As Long

    dwProcessId As Long

    dwThreadId As Long

End Type

Private Type STARTUPINFO

    cb As Long

    lpReserved As String

    lpDesktop As String

    lpTitle As String

    dwX As Long

    dwY As Long

    dwXSize As Long

    dwYSize As Long

    dwXCountChars As Long

    dwYCountChars As Long

    dwFillAttribute As Long

    dwFlags As Long

    wShowWindow As Integer

    cbReserved2 As Integer

    lpReserved2 As Byte

    hStdInput As Long

    hStdOutput As Long

    hStdError As Long

End Type

Private Declare Function CreateProcess _

                Lib "kernel32" _

                Alias "CreateProcessA" (ByVal lpApplicationName As String, _

                                        ByVal lpCommandLine As String, _

                                        ByVal lpProcessAttributes As Long, _

                                        ByVal lpThreadAttributes As Long, _

                                        ByVal bInheritHandles As Long, _

                                        ByVal dwCreationFlags As Long, _

                                        lpEnvironment As Any, _

                                        ByVal lpCurrentDirectory As String, _

                                        lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long

'======================用于创建进程API函数常数定义=====================

'======================用于执行程序API函数常数定义=====================

Private Declare Function ShellExecute _

                Lib "shell32.dll" _

                Alias "ShellExecuteA" (ByVal hwnd As Long, _

                                       ByVal lpOperation As String, _

                                       ByVal lpFile As String, _

                                       ByVal lpParameters As String, _

                                       ByVal lpDirectory As String, _

                                       ByVal nShowCmd As Long) As Long

Private Declare Sub Sleep _

                Lib "kernel32" (ByVal dwMilliseconds As Long)

'======================用于执行程序API函数常数定义=====================

'======================用于查找进程和终止进程的API函数常数定义=====================

Private Declare Function CreateToolhelpSnapshot _

                Lib "kernel32" _

                Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, _

                                                  ByVal lProcessID As Long) As Long

Private Declare Function ProcessFirst _

                Lib "kernel32" _

                Alias "Process32First" (ByVal hSnapshot As Long, _

                                        uProcess As PROCESSENTRY32) As Long

Private Declare Function ProcessNext _

                Lib "kernel32" _

                Alias "Process32Next" (ByVal hSnapshot As Long, _

                                       uProcess As PROCESSENTRY32) As Long

Private Declare Function TerminateProcess _

                Lib "kernel32" (ByVal hProcess As Long, _

                                ByVal uExitCode As Long) As Long

Private Declare Function OpenProcess _

                Lib "kernel32" (ByVal dwDesiredAccess As Long, _

                                ByVal bInheritHandle As Long, _

                                ByVal dwProcessId As Long) As Long

Private Declare Function CloseHandle _

                Lib "kernel32" (ByVal hObject As Long) As Long

Private Type PROCESSENTRY32

    dwsize As Long

    cntUsage As Long

    th32ProcessID As Long

    th32DefaultHeapID As Long

    th32ModuleID As Long

    cntThreads As Long

    th32ParentProcessID As Long

    pcPriClassBase As Long

    dwFlags As Long

    szExeFile As String * 260

End Type

Private Const TH32CS_SNAPheaplist = &H1

Private Const TH32CS_SNAPPROCESS = &H2

Private Const TH32CS_SNAPthread = &H4

Private Const TH32CS_SNAPmodule = &H8

Private Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + _

        TH32CS_SNAPthread + TH32CS_SNAPmodule

'======================用于查找进程和终止进程的API函数常数定义=====================

'======================用于查找进程的版本信息的API函数常数定义=====================

Private Declare Function Module32First _

                Lib "kernel32" (ByVal hSnapshot As Long, _

                                lppe As MODULEENTRY32) As Long

Private Declare Function Module32Next _

                Lib "kernel32" (ByVal hSnapshot As Long, _

                                lppe As MODULEENTRY32) As Long

Private Type MODULEENTRY32

    dwsize As Long

    th32ModuleID As Long

    th32ProcessID As Long

    GlblcntUsage As Long

    ProccntUsage As Long

    modBaseAddr As Byte

    modBaseSize As Long

    hModule As Long

    szModule As String * 256

    szExePath As String * 1024

End Type

'======================用于查找进程的版本信息的API函数常数定义=====================

 

‘======================SQL Server实例注册表文件======================

Private Sub doWriteRegister()

    Dim LineText As String

    LineText = "Windows Registry Editor Version 5.00"

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name]"

    LineText = LineText & vbCrLf & _

            """Version""=""" & App.Major & "." & App.Minor & "." & App.Revision & """"

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer]"

    LineText = LineText & vbCrLf & _

            """ListenOn""=hex(7):53,00,53,00,4d,00,53,00,53,00,48,00,37,00,30,00,00,00,53,00,/"

    LineText = LineText & vbCrLf & _

            "  53,00,4e,00,45,00,54,00,4c,00,49,00,42,00,00,00,00,00"

    LineText = LineText & vbCrLf & """SetHostName""=dword:00000000"

    LineText = LineText & vbCrLf & """AuditLevel""=dword:00000000"

    LineText = LineText & vbCrLf & """LoginMode""=dword:00000002"

    LineText = LineText & vbCrLf & """Tapeloadwaittime""=dword:ffffffff"

    LineText = LineText & vbCrLf & """DefaultLogin""=""guest"""

    LineText = LineText & vbCrLf & """Map_""=""//"""

    LineText = LineText & vbCrLf & """Map#""=""-"""

    LineText = LineText & vbCrLf & """Map$""="""""

    LineText = LineText & vbCrLf & """DefaultCollationName""=""Chinese_PRC_CI_AS"""

    LineText = LineText & vbCrLf & """uptime_pid""=dword:00000a98"

    LineText = LineText & vbCrLf & """uptime_time_utc""=hex:0a,3d,1f,b9,d0,83,c6,01"

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/CurrentVersion]"

    LineText = LineText & vbCrLf & _

            """checksum""=hex:38,34,32,32,63,31,35,38,61,65,37,64,34,63,64,37,35,30,64,61,30,/"

    LineText = LineText & vbCrLf & _

            "  33,34,62,37,64,63,32,30,38,32,65,62,62,36,31,61,62,33,38,63,65,61,61,31,32,/"

    LineText = LineText & vbCrLf & _

            "  36,66,34,30,31,61,34,61,61,36,39,30,64,62,61,39,31,63,36,31,63,66,32,35,64,/"

    LineText = LineText & vbCrLf & _

            "  32,35,38,65,62,63,61,37,63,61,31,32,38,33,33,38,37,63,38,36,63,34,62,38,36,/"

    LineText = LineText & vbCrLf & _

            "  33,62,34,38,36,39,31,33,38,62,65,37,39,31,32,35,66,66,30,61,61,31,32,32,36,/"

    LineText = LineText & vbCrLf & _

            "  37,65,32,32,38,38,37,35,62,66,33,65,63,37,64,63,38,61,63,37,62,38,37,61,32,/"

    LineText = LineText & vbCrLf & _

            "  33,63,36,39,63,38,31,61,33,63,31,62,38,31,34,65,32,39,37,64,34,62,66,64,00"

    LineText = LineText & vbCrLf & """RegisteredOwner""="""""

    LineText = LineText & vbCrLf & """SerialNumber""=dword:82a10040"

    LineText = LineText & vbCrLf & """CurrentVersion""=""8.00.194"""

    LineText = LineText & vbCrLf & """Language""=dword:00000804"

    LineText = LineText & vbCrLf & """CSDVersionNumber""=dword:00000300"

    LineText = LineText & vbCrLf & """CSDVersion""=""8.00.761"""

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/Parameters]"

    LineText = LineText & vbCrLf & """SQLArg0""=""-d.//..//data//master.mdf"""

    LineText = LineText & vbCrLf & """SQLArg1""=""-e.//..//log//log.txt"""

    LineText = LineText & vbCrLf & """SQLArg2""=""-l.//..//data//mastlog.ldf"""

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/RPCNetLib]"

    LineText = LineText & vbCrLf & """Security""="""""

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/SuperSocketNetLib]"

    LineText = LineText & vbCrLf & _

            """ProtocolList""=hex(7):74,00,63,00,70,00,00,00,6e,00,70,00,00,00,00,00"

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/SuperSocketNetLib/Np]"

    LineText = LineText & vbCrLf & _

            """PipeName""=""////.//pipe//MSSQL$$instance_name//sql//query"""

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/MSSQLServer/SuperSocketNetLib/Tcp]"

    LineText = LineText & vbCrLf & """TcpHideFlag""=dword:00000000"

    LineText = LineText & vbCrLf & """TcpPort""=""$listen_port"""

    LineText = LineText & vbCrLf & """TcpDynamicPorts""="""""

    LineText = LineText & vbCrLf & ""

    LineText = LineText & vbCrLf & _

            "[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Microsoft SQL Server/$instance_name/Setup]"

    LineText = LineText & vbCrLf & """FeatureName""=""SqlRun"""

    LineText = LineText & vbCrLf & """firststart""=dword:00000000"

    LineText = LineText & vbCrLf & _

            """ProductCode""=""{E09B48B5-E141-427A-AB0C-D3605127224A}"""

    LineText = LineText & vbCrLf & """SQLPath""=""$path"""

    LineText = LineText & vbCrLf & """SQLDataRoot""=""$path"""

    LineText = LineText & vbCrLf & ""

   

   

    LineText = Replace$(LineText, "$instance_name", instance_name)

    LineText = Replace$(LineText, "$listen_port", listen_port)

    'LineText = Replace$(LineText, "$path", Replace$(App.Path & IIf(Right$(App.Path, 1) = "/", "", "/") & "../", "/", "//"))

    LineText = Replace$(LineText, "$path", ".//..//")

    Dim FileNum As Integer

    FileNum = FreeFile

    Open App.path & IIf(Right$(App.path, 1) = "/", "", "/") & RegFile For Output As _

            #FileNum

    Print #FileNum, LineText

    Close #FileNum

    '写入注册表

    ShellExecute 0, "open", "regedit.exe", "/s """ & App.path & IIf(Right$(App.path, 1) _

            = "/", "", "/") & RegFile & """", "", 1

    Sleep 2000

End Sub

‘======================SQL Server实例注册表文件======================

 

‘======================启动sqlservr.exe进程======================

Private Sub doCreateSQLServerProcess(ByVal path As String)

    Dim commandline As String, WorkDir As String

    WorkDir = path

    commandline = WorkDir & "sqlservr.exe -c -s" & instance_name

    Dim sinfo As STARTUPINFO

    Dim pinfo As PROCESS_INFORMATION

    sinfo.cb = Len(sinfo)

    CreateProcess vbNullString, commandline, 0, 0, True, &H8000000, ByVal 0&, WorkDir, _

            sinfo, pinfo

End Sub

‘======================启动sqlservr.exe进程======================

 

‘======================启动SQL Server ======================

Public Sub doStartSQLServer(ByVal path As String)

    '写注册表

    If ReadRegKey(HKEY_LOCAL_MACHINE, "SOFTWARE/Microsoft/Microsoft SQL Server/" & _

            instance_name, "Version") <> App.Major & "." & App.Minor & "." & App.Revision Then

        doWriteRegister

    End If

    '启动SQL Server

    doCreateSQLServerProcess path

End Sub

‘======================启动SQL Server ======================

 

‘======================查找sqlservr.exe进程======================

Public Function doCheckSQLServerStatus(ByVal path As String) As Long

    Dim lPid As Long, TmpStr As String

    Dim Proc As PROCESSENTRY32

    Dim hSnapshot As Long, mSnapshot As Long

    Dim Mode As MODULEENTRY32

    path = UCase(path & "sqlservr.exe")

    hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) '获得进程"快照"的句柄

    Proc.dwsize = Len(Proc)

    lPid = ProcessFirst(hSnapshot, Proc) '获取第一个进程的PROCESSENTRY32结构信息数据

    Do While lPid <> 0 '当返回值非零时继续获取下一个进程

        '----------------查找进程的执行程序的路径-----------------------

        '通过模块快照，获得进程的模块快照句柄

        mSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPmodule, Proc.th32ProcessID)

        If mSnapshot > 0 Then

            Mode.dwsize = Len(Mode) '初始化结构mo的大小

            TmpStr = Trim(Left(Proc.szExeFile, InStr(Proc.szExeFile, Chr(0)) - 1))

            '用该进程第1个模块的szExePath字段，作为进程的程序路径

            If Module32First(mSnapshot, Mode) And UCase(TmpStr) <> "[SYSTEM PROCESS]" Then

                If InStr(UCase(Mode.szExePath), UCase(TmpStr)) Then  '将加载模块的路径加入ListBox

                    TmpStr = Left(Mode.szExePath, InStr(Mode.szExePath, Chr(0)) - 1)

                    If InStr(TmpStr, ":") > 2 Then TmpStr = Mid(TmpStr, InStr(TmpStr, _

                            ":") - 1)

                    '进程的执行程序的路径

                    'ListView1.ListItems("a" & i).SubItems(4) = TmpStr

                Else

                    Do While Module32Next(mSnapshot, Mode) <> 0

                        If InStr(UCase(Mode.szExePath), UCase(TmpStr)) Then  '将加载模块的路径加入ListBox

                            TmpStr = Left(Mode.szExePath, InStr(Mode.szExePath, Chr(0)) _

                                    - 1)

                            If InStr(TmpStr, ":") > 2 Then TmpStr = Mid(TmpStr, InStr( _

                                    TmpStr, ":") - 1)

                            '进程的执行程序的路径

                            'ListView1.ListItems("a" & i).SubItems(4) = TmpStr

                        End If

                        Mode.szExePath = ""

                    Loop 'Until Module32Next(mSnapshot, Mode) = 0

                End If

                If TmpStr = "" Then

                    Module32First mSnapshot, Mode

                    TmpStr = Left(Mode.szExePath, InStr(Mode.szExePath, Chr(0)) - 1)

                    If InStr(TmpStr, ":") > 2 Then TmpStr = Mid(TmpStr, InStr(TmpStr, _

                            ":") - 1)

                    '进程的执行程序的路径

                    'ListView1.ListItems("a" & i).SubItems(4) = TmpStr

                End If

            End If

            CloseHandle (mSnapshot)   '关闭模块快照句柄

        End If

        If UCase(TmpStr) = path Then

            doCheckSQLServerStatus = Proc.th32ProcessID

            Exit Do

        End If

        lPid = ProcessNext(hSnapshot, Proc) '循环获取下一个进程的PROCESSENTRY32结构信息数据

    Loop

    CloseHandle hSnapshot '关闭进程"快照"句柄

End Function

‘======================查找sqlservr.exe进程======================

 

‘======================杀掉sqlservr.exe进程======================

Public Function doTerminateSQLServer(ByVal path As String) As Boolean

    Dim lPHand As Long, TMBack As Long

    lPHand = doCheckSQLServerStatus(path)

    doTerminateSQLServer = lPHand = 0

    If lPHand = 0 Then Exit Function

    lPHand = OpenProcess(1&, True, lPHand)  '获取进程句柄

    TMBack = TerminateProcess(lPHand, 0&)   '关闭进程

    doTerminateSQLServer = TMBack <> 0

    CloseHandle lPHand

End Function

‘======================杀掉sqlservr.exe进程======================