Backup DB and Email

'************************************************************************
'VBSCRIPT to backup database's and email results
'Watch for SMTP Message size limit when sending DB
'1 Novenber 2003 Don Grover
'************************************************************************
Option Explicit

'Configurable variables
Const myMailServer = "assoftsvr"                                          'The IP or Name of Your Mail Server
Const mySqlServer = "assoftsvr"                                           'The IP or Name of Your SQL Server
Const myEmailPort = 25                                                    'The Outgoing Email Port
Const sEmailAddFrom = "xxxx@assoft.com.au"                             'Who this email is from
Const sEmailAddToo = "xxxx@assoft.com.au"                              'Who this email is to
Const sConEmailMonitor = "xxxx@assoft.com.au"                          'An extra email for sending copy to other person
Const sDBFileLocation = "\\Nassvr\Data\backups\"                          'Backup loacation where database & Logs go
Const iNumOfDays = 31                                                     'Cleanup files older than 31 days
Const bSendAttachment = False                                              'Set to True if Send DB email or False not too


'**** No need to edit below this line *******

'Delete any old backup files
fncCleanBackups sDBFileLocation, iNumOfDays

'On Error Resume Next
Dim conn
'Open connection to SQL Server, Change the Connection string to TCP IP Connection if Needed
Set conn = CreateObject("ADODB.Connection")
conn.Open _
        "Provider=SQLOLEDB" & _
        ";Data Source=" & mySqlServer & _
        ";Integrated Security=SSPI"

'Non connection error trap
If Err <> 0 Then
    WScript.Quit
End If
On Error GoTo 0


'Call the backup routine, Add more in if you want to backup more than one database
'DoBackup "CokeShop",True
DoBackup "postcodes", True
conn.Close
Set conn = Nothing



'Script finishes here
WScript.Quit



Sub DoBackup(sDbName, bSendDB)
    'Sub accepts a database name and backs up to predefined location on another server
    Dim sFileName
    If bSendDB = True Then
        sFileName = sDBFileLocation & sDbName & "_db_" & Day(Date) & "_" & Month(Date) & ".bak"
    Else
        sFileName = ""
    End If

    'On Error Resume Next
    conn.Execute _
            "BACKUP DATABASE " & sDbName & _
            " TO DISK='" & sDBFileLocation & sDbName & "_db_" & Day(Date) & "_" & Month(Date) & ".bak'" & _
            " WITH INIT"

    conn.Execute _
            "BACKUP LOG " & sDbName & _
            " TO DISK='" & sDBFileLocation & sDbName & "_log_" & Day(Date) & "_" & Month(Date) & ".bak'" & _
            " "
    If Err.Number = 0 Then
        SendEmail "Database " & UCASE(sDbName) & " backup " & FormatDateTime(Date,2), "BACKUP SUCCESS", sFileName
    Else
        SendEmail "Database " & UCASE(sDbName) & " backup " & FormatDateTime(Date,2), "BACKUP FAILED " & VBCrLf & Err.Number & VbCrLf & "Desc: " & Err.Description, ""
    End If
    Err.Clear
    On Error GoTo 0
End Sub

Sub SendEmail(TheSubJect, TheMessage, TheUploadFile)

    '******************************************************
    '*** Send the message Using CDOSYS Win2k & Win2003 ****
    '******************************************************
'    On Error Resume Next
    Dim sch, cdoConfig, cdoMessage, sError
    sch = "http://schemas.microsoft.com/cdo/configuration/"
    Set cdoConfig = CreateObject("CDO.Configuration")
    cdoConfig.Fields.Item(sch & "sendusing") = 2
    cdoConfig.Fields.Item(sch & "smtpserverport") = myEmailPort
    cdoConfig.Fields.Item(sch & "smtpserver") = myMailServer
    cdoConfig.Fields.Update
    Set cdoMessage = CreateObject("CDO.Message")
    Set cdoMessage.Configuration = cdoConfig
    cdoMessage.From = sEmailAddFrom
    cdoMessage.To = sEmailAddToo
    cdoMessage.CC = sConEmailMonitor
    cdoMessage.BCC = ""
    cdoMessage.Subject = TheSubJect
    If Trim(TheUploadFile) <> "" AND bSendAttachment = True Then
        cdoMessage.AddAttachment "file://" & TheUploadFile
    ElseIf Trim(TheUploadFile) <> "" AND  bSendAttachment = False Then
        TheMessage = "Database Backed upto " & TheUploadFile & VbCrLf & TheMessage
    End If
    cdoMessage.TextBody = TheMessage & vbCrLf & vbCrLf & SendEmailBlurb
    '   cdoMessage.item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate").value = 1 ' use clear text authenticate
    '   cdoMessage.item("http://schemas.microsoft.com/cdo/configuration/sendpassword").value ="mypassword"
    '   cdoMessage.item("http://schemas.microsoft.com/cdo/configuration/sendusername").value ="yourusername"
    cdoMessage.Fields.Item("urn:schemas:mailheader:X-MSMail-Priority") = "High"
    cdoMessage.Fields.Item("urn:schemas:mailheader:X-Priority") = 2
    cdoMessage.Fields.Item("urn:schemas:mailheader:Keywords") = "DBA SUPPORT"
    cdoMessage.Fields.Item("urn:schemas:mailheader:Sensitivity") = "Company-Confidential"
    cdoMessage.Fields.Item("urn:schemas:mailheader:X-Message-Flag") = "Do not Forward"
    cdoMessage.Fields.Item("urn:schemas:mailheader:Disposition-Notification-To") = "Don Grover <dgrover@assoft.com.au>"
    cdoMessage.Fields.Update
    cdoMessage.Send
    Set cdoMessage = Nothing
    Set cdoConfig = Nothing
    If Err.Number <> 0 Then
        sErrorDesc = Err.Description
        sErrorNum = Err.Number
        'Wscript.Echo sErrorDesc & VBCrLf & sErrorNum
    Else
        'Wscript.Echo "Mail Sent"
    End If
    On Error GoTo 0
End Sub

'Search the output folder for output files older than 30 days
Function fncCleanBackups(folderspec, DaysToClean)
    Dim fso, f, f1, fc, s, c
    'On Error Resume next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFolder(folderspec)
    Set fc = f.Files
    For Each f1 In fc
        c = ShowFileInfo(f1.Name)
        If Abs(DateDiff("d", c, Date)) > DaysToClean And LCase(Right(f1.Name, 4)) = ".bak" Then
            DeleteAFile f1.Name
        End If
        If Abs(DateDiff("d", c, Date)) > DaysToClean And LCase(Right(f1.Name, 4)) = ".log" Then
            DeleteAFile f1.Name
        End If
    Next
    fncCleanBackups = s
    Set fc = Nothing
    Set f = Nothing
    Set fso = Nothing
End Function


'Get The Date Last Modified
Function ShowFileInfo(filespec)
    Dim fso, f
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.GetFile(sDBFileLocation & filespec)
    ShowFileInfo = f.DateLastModified
    Set f = Nothing
    Set fso = Nothing
End Function

'Delete file
Sub DeleteAFile(filespec)
    'On Error Resume Next
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.DeleteFile (sDBFileLocation & filespec)
    Set fso = Nothing
    On Error GoTo 0
End Sub

Function SendEmailBlurb()
    'Message to attach to each email
    SendEmailBlurb = " " & VbCrLf & String(66,"=") & VbCrLf & "WARNING - This email and any attachments may be confidential. If received in error, please delete and inform us by return email." & VbCrLf & VbCrLf &_
    "Because emails and attachments may be interfered with, may contain computer viruses or other defects and may not be successfully replicated on other systems, you must be cautious." & VbCrLf &_
    "CokeShop cannot guarantee that what you receive is what we sent. If you have any doubts about the authenticity of an email by Support, please contact us immediately. " & VbCrLf &_
    "It is also important to check for viruses and defects before opening or using attachments. Supports liability is limited to resupplying any affected attachments." & VbCrLf &_
    String(66,"*") & VbCrLf & "Support Online" & VbCrLf & VbCrLf & String(66,"*") & VbCrLf & "[backupdbs]" & VbCrLf
End Function