modmain.bas

连接SQL用连接查询SQL字段做新表等等对新人比较有价值

Attribute VB_Name = "modMain"
Option Explicit

'API Types
Public Type SHITEMID
   cb             As Long
   abID           As Byte
End Type

Public Type ITEMIDLIST
   mkid           As SHITEMID
End Type

Public Type BROWSEINFO
   hOwner         As Long
   pidlRoot       As Long
   pszDisplayName As String
   lpszTitle      As String
   ulFlags        As Long
   lpfn           As Long
   lParam         As Long
   iImage         As Long
End Type

'API Constants
Public Const BIF_RETURNONLYFSDIRS = &H1

'API Functions
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
                "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
                "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

'Public variables
Public objServer As New SQLDMO.SQLServer
Public strServerNameSW As String
Public strLoginSW As String
Public strPasswordSW As String
Public vDatabasesSW As Variant
Public strDestDirSW As String
Public bDelOldFilesSW As Boolean
Public iDelWeeksSW As Integer
Public bSaveDTSPackagesSW As Boolean
Public bScriptAlertsSW As Boolean
Public bScriptServerLoginsSW As Boolean
Public bScriptAgentJobsSW As Boolean
Public bScriptBackupDevicesSW As Boolean
Public bRunUnAttendedSW As Boolean

Public bNoGUI As Boolean
Public strUnattendedLog As String
Public strLogFile As String


Public Function BrowseForFolder(szPrompt As String) As String
   Dim biInfo As BROWSEINFO
   Dim pidl As Long
   Dim szPath As String
   
   szPath = Space$(512)
   
   biInfo.hOwner = 0&
   biInfo.pidlRoot = 0&
   biInfo.lpszTitle = szPrompt
   biInfo.ulFlags = BIF_RETURNONLYFSDIRS
   
   pidl = SHBrowseForFolder(biInfo)
   SHGetPathFromIDList ByVal pidl, ByVal szPath
   
   BrowseForFolder = Trim$(szPath)
End Function

Public Sub SaveLog(ByVal strLogFile As String)
    Dim iFileNumber As Integer
    
    On Error Resume Next
    iFileNumber = FreeFile
    Open strLogFile For Output As #iFileNumber
    Print #iFileNumber, strUnattendedLog
    Close #iFileNumber
    DoEvents
End Sub

Public Sub StatusMessage(ByVal strMessage As String)
    Const ciMaxVisualLogLength As Integer = 30000
    Const cstrLogDateTimeFormat As String = "yyyymmdd Hh:Mm:Ss"
    
    Dim strLogEntry As String
    Dim iPos As Integer
    
    On Error Resume Next
    strLogEntry = Format(Now, cstrLogDateTimeFormat) & vbTab & strMessage
    strUnattendedLog = strUnattendedLog & strLogEntry & vbNewLine
    If Not bNoGUI Then
        With frmMain.lblStatus
            .Caption = " " & strMessage
            .Refresh
        End With
        If Len(strUnattendedLog) > ciMaxVisualLogLength Then
            iPos = InStr(Right$(strUnattendedLog, ciMaxVisualLogLength), vbNewLine)
            With frmMain.txtLog
                .Text = Right$(strUnattendedLog, ciMaxVisualLogLength - iPos - 1)
                .SelStart = Len(.Text)
                .Refresh
            End With
        Else
            With frmMain.txtLog
                .Text = strUnattendedLog
                .SelStart = Len(.Text)
                .Refresh
            End With
        End If
    End If
End Sub

Public Sub GenerateScripts(strServerName As String, _
                           strDir As String, _
                           Optional vDatabases As Variant, _
                           Optional bTrustedConnection As Boolean = True, Optional strLogin As String, Optional strPassword As String, _
                           Optional bDelOldFiles As Boolean = False, Optional iDelWeeks As Integer = 4, _
                           Optional bScriptDBTables As Boolean = True, _
                           Optional bScriptDBViews As Boolean = True, _
                           Optional bScriptDBSPs As Boolean = True, _
                           Optional bScriptDBRules As Boolean = True, _
                           Optional bScriptDBDefaults As Boolean = True, _
                           Optional bScriptDBRoles As Boolean = True, _
                           Optional bScriptDBFullText As Boolean = True, _
                           Optional bScriptDBUsers As Boolean = True, _
                           Optional bScriptDBUDTs As Boolean = True, _
                           Optional bSaveDTSPackages As Boolean = False, _
                           Optional bScriptAlerts As Boolean = False, _
                           Optional bScriptAgentJobs As Boolean = False, _
                           Optional bScriptServerLogins As Boolean = False, _
                           Optional bScriptBackupDevices As Boolean = False)

    Const cScriptOptions = SQLDMOScript_Default Or SQLDMOScript_Drops Or _
                           SQLDMOScript_IncludeHeaders Or SQLDMOScript_Permissions Or _
                           SQLDMOScript_OwnerQualify
    Const cTableScriptOptions = cScriptOptions Or SQLDMOScript_Indexes Or SQLDMOScript_Triggers Or _
                                SQLDMOScript_DRI_All Or SQLDMOScript_Bindings
    
    
    Dim objLogin As SQLDMO.Login
    Dim objDatabase As SQLDMO.Database
    Dim objCatalog As SQLDMO.FullTextCatalog
    Dim objTab As SQLDMO.Table
    Dim objView As SQLDMO.View
    Dim objProc As SQLDMO.StoredProcedure
    Dim objRule As SQLDMO.Rule
    Dim objDefault As SQLDMO.Default
    Dim objUser As SQLDMO.User
    Dim objRole As SQLDMO.DatabaseRole
    Dim objUDT As SQLDMO.UserDefinedDatatype
    Dim objBackupDevice As SQLDMO.BackupDevice
    Dim qryResults As SQLDMO.QueryResults
    Dim objPackage As DTS.Package
    Dim strScript As String, strScript2 As String
    Dim strYYYYMMDD As String, strDelCommand As String, strFile As String
    Dim strSQLquery As String, strPackageFile As String
    Dim i As Integer, i2 As Integer, j As Integer, iFileNumber As Integer
    Dim dtDelDate As Date
    Dim msgResult As VbMsgBoxResult
    Dim strCheckPoint As String
    Dim strPackageName As String
    
    strYYYYMMDD = Format(Date, "yyyymmdd")
    
    'Deleting old files
    If bDelOldFiles Then
        strCheckPoint = "deleting"
        On Error Resume Next
        StatusMessage "Deleting old files in [" & strDir & "]:"
        dtDelDate = DateAdd("ww", -iDelWeeks, Date)
        If InStr(strDir, ":") > 0 Then ChDrive Left$(Trim$(strDir), 1)
        ChDir strDir
        strFile = Dir("*.*")
        i = 0
        While Len(strFile) <> 0
            If DateValue(FileDateTime(strFile)) <= dtDelDate Then
                i = i + 1
                Kill strFile
                StatusMessage "- Deleted file " & CStr(i) & ": " & strFile
                DoEvents
            End If
            strFile = Dir
        Wend
        StatusMessage "* " & CStr(i) & " old files deleted."
    End If
    
    'Save DTS Packages
    On Error GoTo ErrorHandler
    If objServer.Issysadmin And bSaveDTSPackages Then
        strCheckPoint = "dts"
        StatusMessage "Saving DTS packages as Structured Storage Files:"
        Set qryResults = objServer.ExecuteWithResults("USE msdb SELECT DISTINCT name FROM sysdtspackages")
        With qryResults
            For i = 1 To .Rows
                strPackageName = .GetColumnString(i, 1)
                StatusMessage "- Saving DTS package " & CStr(i) & ": " & strPackageName
                Set objPackage = New DTS.Package
                If objServer.LoginSecure Then
                    objPackage.LoadFromSQLServer ServerName:=strServerName, PackageName:=strPackageName, Flags:=DTSSQLStgFlag_UseTrustedConnection
                Else
                    objPackage.LoadFromSQLServer ServerName:=strServerName, ServerUserName:=strLoginSW, ServerPassword:=strPasswordSW, PackageName:=strPackageName
                End If
                DoEvents
                strPackageFile = strDir & strYYYYMMDD & "." & strPackageName & ".dts"
                objPackage.SaveToStorageFile strPackageFile
                DoEvents
NextDTSPackage:
                objPackage.UnInitialize
                Set objPackage = Nothing
            Next i
        End With
        StatusMessage "* " & CStr(i - 1) & " DTS packages saved."
        DoEvents
    End If

    'Script Operators/Alerts
    If objServer.Issysadmin And bScriptAlerts Then
        strCheckPoint = "alerts"
        StatusMessage "Generating script for Operators and Alerts:"
        strScript = objServer.JobServer.Operators.Script(ScriptType:=cScriptOptions)
        DoEvents
        strScript2 = objServer.JobServer.Alerts.Script(ScriptType:=cScriptOptions, Script2Type:=SQLDMOScript2_AgentNotify)
        DoEvents
        iFileNumber = FreeFile
        strFile = strDir & strYYYYMMDD & "." & strServerName & "_Alerts.sql"
        Open strFile For Output As #iFileNumber
        Print #iFileNumber, strScript
        DoEvents
        Print #iFileNumber, strScript2
        DoEvents
        Close #iFileNumber
        i = objServer.JobServer.Alerts.Count
        i2 = objServer.JobServer.Operators.Count
        StatusMessage "* " & CStr(i2) & " Operators and " & CStr(i) & " Alerts scripted."
        DoEvents
    End If
    
    'Script SQL Agent Jobs
    If objServer.Issysadmin And bScriptAgentJobs Then
        strCheckPoint = "jobs"
        StatusMessage "Generating script for SQL Agent Jobs:"
        strScript = objServer.JobServer.Jobs.Script(ScriptType:=cScriptOptions)
        DoEvents
        iFileNumber = FreeFile
        strFile = strDir & strYYYYMMDD & "." & strServerName & "_Jobs.sql"
        Open strFile For Output As #iFileNumber
        Print #iFileNumber, strScript
        DoEvents
        Close #iFileNumber
        i = objServer.JobServer.Jobs.Count
        StatusMessage "* " & CStr(i) & " SQL Agent Jobs scripted."
        DoEvents
    End If
    
    'Script Server Logins
    If objServer.Issysadmin And bScriptServerLogins Then
        strCheckPoint = "logins"
        StatusMessage "Generating script for Server Logins:"
        iFileNumber = FreeFile
        strFile = strDir & strYYYYMMDD & "." & strServerName & "_Logins.sql"
        Open strFile For Output As #iFileNumber
        i = 0
        For Each objLogin In objServer.Logins
            i = i + 1
            StatusMessage "- Generating T-SQL code for Server Login " & CStr(i) & ": " & objLogin.Name
            strScript = objLogin.Script(ScriptType:=cScriptOptions, Script2Type:=SQLDMOScript2_LoginSID)
            DoEvents
            Print #iFileNumber, strScript
            DoEvents
        Next objLogin
        Close #iFileNumber
        StatusMessage "* " & CStr(i) & " Server Logins scripted."
        DoEvents
    End If
    
    'Script Backup Devices
    If objServer.Issysadmin And bScriptBackupDevices Then
        strCheckPoint = "backupdevices"
        StatusMessage "Generating script for Backup Devices:"
        iFileNumber = FreeFile
        strFile = strDir & strYYYYMMDD & "." & strServerName & "_BackupDevices.sql"
        Open strFile For Output As #iFileNumber
        i = 0
        For Each objBackupDevice In objServer.BackupDevices
            i = i + 1
            StatusMessage "- Generating T-SQL code for Backup Device " & CStr(i) & ": " & objBackupDevice.Name
            strScript = objBackupDevice.Script(ScriptType:=cScriptOptions)
            DoEvents
            Print #iFileNumber, strScript
            DoEvents
        Next objBackupDevice
        Close #iFileNumber
        StatusMessage "* " & CStr(i) & " Backup Devices scripted."
        DoEvents
    End If
    
    'Script Databases
    If Not IsMissing(vDatabases) Then
        strCheckPoint = "databases"
        i = 0
        StatusMessage "Generating scripts for Databases:"
        For j = 0 To UBound(vDatabases)
            'Script the Database
            i = i + 1
            StatusMessage "- Generating T-SQL code for Database " & CStr(i) & ": " & vDatabases(j)
            Set objDatabase = objServer.Databases(vDatabases(j))
            DoEvents
            strScript = objDatabase.Script(ScriptType:=cScriptOptions)
            DoEvents
            iFileNumber = FreeFile
            strFile = strDir & strYYYYMMDD & "." & objDatabase.Name & "_Database.sql"
            Open strFile For Output As #iFileNumber
            Print #iFileNumber, strScript
            DoEvents
            If bScriptDBFullText Then
                'Script the FullText catalogs
                StatusMessage "  - Generating scripts for FullText Catalogs:"
                i2 = 0
                For Each objCatalog In objDatabase.FullTextCatalogs
                    i2 = i2 + 1
                    StatusMessage "    - Generating T-SQL code for FullText Catalog " & CStr(i2) & ": " & objCatalog.Name
                    strScript = objCatalog.Script(ScriptType:=cScriptOptions, Script2Type:=SQLDMOScript2_FullTextCat)
                    Print #iFileNumber, strScript
                    Print #iFileNumber, "GO"
                    DoEvents