Environment: Windows Server, Microsoft SQL Server
Description: This script report is run weekly and gives each network user a recap and detail of their personal network share usage. This report is run after the process 'x' has gotten the network detail into an MS SQL database, which simplifies access and reporting. Any errors are written to the application event log to help trouble shooting.
Sample Report:
Code:
'=========================================================================
' FILE: MSUagageReport.vbs
' AUTHOR: Robert Lawson
' COMPANY: Soka University of America
' DATE: 6/04/2008 Robert Lawson, Creation Date
' COMMENT:
' - Reports on information summared in SQL database by OneCard: MSrefresh
' - Server run on has to be allow SMTP relay on Exchange
'=========================================================================
option explicit
On Error Resume Next
const conScriptName = "MSUagageReport.vbs"
const conSendMail = FALSE ' TRUE = will send email, FALSE=will not
strCSSfile = "C:\data\vbscript\MSUagageReportCSS.html" ' Figure out to get from same dir as this script
' strCSSfile = "D:\Tech\MSUagageReportCSS.html" ' Figure out to get from same dir as this script
const conDEBUG = TRUE ' TRUE = SQL and displays, FALSE= full SQL and no displays
const conUDriveKey = 0 ' Key value for UDrive
Dim objShell, strMsg, intLoc
Dim strCSSfile, strHTML, strHTMLCSS, strTempFile
Dim objFile, fso, objFileTemp
Dim objConn, objRS, objRS2, objRS3, strSQL, strConn
' Data
Dim strSource, strType, strAsOf, strName, strEmail
Dim strID, strNETUser, strNameFirst, strNameLast, strNETEmail
Dim strDtlFile, strDtlFolder, strDtlDateCreate, strDtlLastAccess
Dim strTypelist, strTotCount, strTotSize
Dim numTotCount, numTotSize, numCutOffSize
Dim numPctUsed, numSize, numCount, numDtlSize, numQuota
Dim strPctUsed, strSize, strCount, strDtlSize, strQuota, strCutOffSize
Dim numSourceK, numUserK
Dim datAsOf, datDtlDateCreate, datDtlLastAccess
Dim datStartDate
' SMTP email
Dim strTo, strBCC, strCC, strFrom, strSubject, strTextBody
Const conMaxDetailLines = " Top 30 "
Const conDtlFolderMax = 34
Const conDtlFileMax = 23
Const conUdriveSource = 0 ' This is agreed upon (with myself) #
Const conFromUser = "MSNotification@campus.edu" ' valid email if you want user to reply
Const conEmailAdminUser = "robert.lawson@campus.edu" ' comma seperated
Const ForReading = 1 ' FSO
' ============================================================
' Setup
' ============================================================
Set objShell = CreateObject( "WScript.Shell" )
' Write event log that you started
strMsg = "BEGIN: " & conScriptName
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
' DB stuff
Set objConn = CreateObject("ADODB.Connection")
Set objRS = CreateObject("ADODB.Recordset")
Set objRS2 = CreateObject("ADODB.Recordset")
Set objRS3 = CreateObject("ADODB.Recordset")
strConn = "Provider=SQLOLEDB; SERVER=ServerName; DATABASE=DBname;Integrated Security = SSPI"
objConn.Open strConn
' ============================================================
' Load initial XHTML: CSS
' ============================================================
Set fso = CreateObject("Scripting.FileSystemObject")
Set objFile = fso.OpenTextFile(strCSSfile, ForReading)
if objFile > 0 then
strHTMLCSS = objFile.ReadAll
'if conDEBUG then Wscript.Echo "+objFile = " & strHTML
else
Wscript.Echo conScriptName & ". ERROR: Unable to open CSS file: " & strCSSfile
wscript.quit
end if
strTempFile = "C:\temp\MSUagageReport.html"
Set objFileTemp = fso.CreateTextFile(strTempFile, 2,TRUE)
' ============================================================
' Find out about the source
' ============================================================
strSQL = "SELECT * FROM MSsource WHERE SourceK = " & conUDriveSource
if conDEBUG then Wscript.Echo "strSQL = " & strSQL
objRS.Open strSQL, objConn, 2
if (objRS.BOF or objRS.EOF) then
strMsg = conScriptName & ": Unable to get source info: " & conUDriveSource
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
WScript.Quit
end if
numCutOffSize = objRS("CutOffSize")
objRS.Close
Select Case numCutOffSize
Case 1024 : strCutOffSize = "1KB"
Case 1048576 : strCutOffSize = "1MB"
Case 1073741824 : strCutOffSize = "1GB"
Case Else strCutOffSize = "?"
End Select
' ============================================================
' Get all users for a source, then detail and email'em
' ============================================================
strSQL = "SELECT * FROM MSuser WHERE SourceK = " & conUDriveSource
'strSQL = strSQL & " AND NETUser IN ('sleepy','dopey','sneezy')" '******** DEBUG ************
if conDEBUG then strSQL = strSQL & " AND NETUser IN ('sleepingb')"
if conDEBUG then strSQL = "SELECT * FROM MSuser WHERE SourceK = 3"
if conDEBUG then Wscript.Echo "strSQL = " & strSQL
objRS.Open strSQL, objConn, 2
if (objRS.BOF or objRS.EOF) then
strMsg = conScriptName & ": No MS users to process for source " & conUDriveSource
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
WScript.Quit
end if
strDateTime = Date & " " & Time
numUsers = 0
do while not objRS.EOF
strNETUser = objRS("NETUser")
strID = objRS("ID")
strSource = objRS("Source")
datStartDate = objRS("StartDate")
numSourceK = objRS("SourceK")
numUserK = objRS("UserK")
if conDEBUG then Wscript.Echo "--Working on NETUser = " & strNETUser
numUsers = numUsers + 1
strSQL = "SELECT * FROM OneCardMaster WHERE ID = '" & strID & "'"
if conDEBUG then Wscript.Echo strSQL
objRS2.Open strSQL, objConn, 2
if (objRS2.BOF or objRS2.EOF) then
strMsg = conScriptName & ": Unable to open OneCardMaster for ID " & strID
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
WScript.Quit
end if
strNameFirst = TRIM(objRS2("NameFirst"))
strNameLast = TRIM(objRS2("NameLast"))
strNETEmail = objRS2("NETEmail")
strNETUser = objRS2("NETuser")
objRS2.Close
' ============================================================
' Build header
' ============================================================
numSize = objRS("FileSpace")
numCount = objRS("FileCount")
numQuota = objRS("FileQuota")
' Quota and Pct Used
if numQuota = -1 then
strQuota = "Unlimited"
strPctUsed = "_"
elseif numQuota = -2 then
strQuota = "Not Set"
strPctUsed = "_"
Else
strQuota = pad(FormatNumber(numQuota,0,false,false,true),"r",10)
if numSize <> -1 then
numPctUsed = (numSize/numQuota)
strPctUsed = FormatPercent(numPctUsed,0,false,false,true)
end if
end if
if numSize <> -1 then
strSize = pad(FormatNumber(numSize,0,true,false,true),"r",10)
else
strSize = "???/Error"
end if
' Create header
strName = strNameFirst & " " & strNameLast
strEmail = strNETEmail
'strEmail = "robert.lawson@uni.edu" ' ***** DEBUG
strCount = pad(FormatNumber(numCount,0,true,false,true),"r",10)
strAsOf = FormatDateTime(datStartDate, vbShortDate)
strHTML = strHTMLCSS ' Initialize
strHTML = strHTML & "strHTML = strHTML & "
strHTML = strHTML & "
| strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " |
|---|---|---|---|---|---|
| " & strPctUsed & " | "" & strSize & " | "" & strQuota & " | "" & strCount & " | "" & strSource & " | "" & strAsOf & " | "
' ============================================================
' Build detail lines
' ============================================================
strSQL = "SELECT " & conMaxDetailLines & _
" * FROM MSUserFile WHERE SourceK = " & numSourceK & " AND UserK = " & numUserK & _
" ORDER BY Size DESC"
if conDEBUG then Wscript.Echo "strSQL = " & strSQL
objRS3.Open strSQL, objConn, 2
strHTML = strHTML & "
strHTML = strHTML & "
| strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " |
|---|---|---|---|---|
| " & strDtlSize & " | "" & strDtlFile & " | "" & strDtlFolder & " | "" & strDtlDateCreate & " | "" & strDtlLastAccess & " | "
objRS3.Close
' ============================================================
' File Extension Recep
' ============================================================
strSQL = "SELECT * FROM MSUserFileExtSum " & _
" WHERE SourceK = " & numSourceK & " AND UserK = " & numUserK & _
" ORDER BY TotSize DESC"
if conDEBUG then Wscript.Echo "strSQL = " & strSQL
objRS3.Open strSQL, objConn, 2
strHTML = strHTML & "
strHTML = strHTML & "
| strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " | strHTML = strHTML & " |
|---|---|---|---|
| " & strType & " | "" & strTotSize & " | "" & numTotCount & " | "" & strTypelist & " | "
objRS3.Close
' Disclaimer stuff
strHTML = strHTML & "
strHTML = strHTML & "This report is a recap of your Soka Udrive account, intended for your personal use and review. The detail of your largest files, sorted by size, is to help you keep tabs on 'the big ones'. Note that only files larger than " & strCutOffSize & " are considered in count and detail report. Files and folders too large to display will be abbreviated with a set of periods. If you have any questions or concerens, please call the IT Help Desk at 949.480.6666 or send an email to helpdesk@uni.edu."
strHTML = strHTML & "
" & strDateTime & "; " & conScriptName & "
strHTML = strHTML & "" ' *** END
' ============================================================
' Create email
' ============================================================
if numCount > 0 then
strTo = strEmail
if conDEBUG then strBCC = conEmailAdminUser
strCC = ""
strFrom = conFromUser
strSubject = "U Drive Summary" & conMaxDetailLines & "" & strNETUser
else ' You had summary record with no supporting detail
strTo = conEmailAdminUser
strBCC = ""
strCC = ""
strFrom = conFromUser
strSubject = "Failure to Email User:" & strNETUser & ", No supporting detal"
end if
if conDEBUG then Wscript.Echo strHTML
' Set the message properties.
if conSendMail then
Call SendMail(strFrom,strTo,strCC,strBCC,strSubject,strHTML,TRUE)
strMsg = conScriptName & ": Mailed: " & strName & " @ " & strSubject & _
"; Size: " & strSize & "; Limit: " & strLimit & "; Count: " & strCount
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
end if
objRS.movenext
Loop ' All users
strMsg = conScriptName & ": end execution. Total emails sent = " & numUsers
if conDEBUG then Wscript.Echo strMsg
objShell.LogEvent 0,strMsg
' ============================================================
' The End
' ============================================================
strMsg = "END: " & conScriptName
if conDEBUG then
Wscript.Echo strMsg
objFileTemp.Write(strHTML)
End if
objShell.LogEvent 0,strMsg
objRS.Close
objConn.Close
Set objFile = nothing
Set objFile = nothing
' ======================================================
Function DoError(strErrMsg)
On Error Resume Next
Dim objShell
if conDEBUG then wscript.Echo strErrMsg
Set objShell=CreateObject("wscript.shell")
objShell.LogEvent 1,strErrMsg
End Function
' ======================================================
Function pad(strString, strWay, numLen)
' Padd out a passed string
' strWay "r" right, "l" left pad
' numLen overall size you want
Dim numLenVar, numDelta
numLenVar = LEN(strString)
if numLenVar > numLen then
pad = LEFT(strString,numLen)
Exit Function
elseif numLenVar = numLen then
pad = strString
Exit Function
end if
numDelta = numLen - numLenVar
if strWay = "l" then
pad = strString & String(numDelta, " ")
else ' "r"
pad = string(numDelta," ") & strString
end if
End Function
' ==================================================
' SUB: SendMail
' ===================================================
Sub SendMail(sFromAddress, sToAddress, sCcAddress, sBccAddress, sSubject, sBody, bolHTML)
' FILE: SampleEmail.vbs
' PURPOSE: Send SMTP email, html or text, supporting Asian Languages (UTF-8)
' AUTHOR: Robert Lawson
' COMPANY: Soka University of America
' DATE: 08-May-2008 Robert Lawson, Creation Date
' From http://www.sqlteam.com/forums/topic.asp?TOPIC_ID=45670'
on error resume next
Const cdoDispositionNotificationTo = "urn:schemas:mailheader:disposition-notification-to"
Const cdoReturnReceiptTo = "urn:schemas:mailheader:return-receipt-to"
dim cdoMessage, cdoConfiguration
Set cdoConfiguration = CreateObject ("CDO.Configuration")
With cdoConfiguration
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.uni.edu"
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
.Fields.Update
End With
Set cdoMessage = CreateObject("CDO.Message")
With cdoMessage
' Update the CDOSYS Configuration (don't make 1 line!!!)
SET .Configuration = cdoConfiguration
.BodyPart.charset = "unicode-1-1-utf-8"
.Fields.Update
.From = sFromAddress
.ReplyTo = sFromAddress
.To = sToAddress
.Cc = sCcAddress
.Bcc = sBccAddress
.Subject = sSubject
if bolHTML then
.HTMLBody = sBody
else
.Textbody = sBody
end if
.Send
End With
Set cdoMessage = Nothing
Set cdoConfiguration = Nothing
End Sub
