'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
' NAME: List_Apps_On_Drive (prompts for drive letter and file extension).vbs
'
' AUTHOR: John F. Fuhrman III
' DATE : 1/22/2010
'
' COMMENT: This script creates a new Excel Workbook and Spreadsheet
' for the Drive and File Extension the user specifies.
' The new Excel document is placed in the users "My Documents"
' directory by default.
' UPDATED:
' 2/8/2010 - John Fuhrman
' Added coments to code by sections.
' Converted user prompts to Functions.
' Added File Extension
' 2/19/2010 - John Fuhrman
' Added Date to filename.
' 3/5/2010
' Decared all objects and variables and added
' a cleanup section to the end of the script.
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><> <><>
'<><> Start of Main Script <><>
'<><> <><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
Option Explicit
Dim strComputer, objWMIService, objShell
strComputer = "." ' use "." for local computer
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set objShell = CreateObject("Wscript.Shell")
'******************************************************************************
' Prompted User Input
'******************************************************************************
Dim strDrive, strExtension
strDrive = funDriveSelect
strExtension = funFileExtention
'strDateInput = funDateInput
'******************************************************************************
' Create Spreadsheet and Open Excel
'******************************************************************************
Dim strExcelPath, objExcel, objWorksheet
' Spreadsheet file to be created.
If strExtension = "*" Then
strExcelPath = "File_Listing_for_Drive_" & strDrive & ".xls"
Else
strExcelPath = strExtension & "-File_Listing_for_Drive_" & strDrive & ".xls"
End If
' Wscript.Echo strExcelPath
' Bind to Excel object.
Set objExcel = CreateObject("Excel.Application")
If Err.Number <> 0 Then
Wscript.Echo "Excel application not found."
Wscript.Quit
End If
'Set this True if you would like to see the Spreadsheet being updated.
objExcel.Visible = True
'Create a new workbook
objExcel.Workbooks.Add
' Bind to worksheet.
Set objWorksheet = objExcel.ActiveWorkbook.Worksheets(1)
If strExtension = "*" Then
objWorksheet.Name = "File Listing for Drive " & strDrive
Else
objWorksheet.Name = strExtension & "-File Listing for Drive " & strDrive
End If
'******************************************************************************
' Populate spreadsheet cells with user attributes.
'******************************************************************************
objWorksheet.Cells(1,1).Value = "File Type" 'Cell A1
objWorksheet.Cells(1,2).Value = "File Name" 'Cell B1
objWorksheet.Cells(1,3).Value = "File Extension" 'Cell C1
objWorksheet.Cells(1,4).Value = "Drive" 'Cell D1
objWorksheet.Cells(1,5).Value = "Folder" 'Cell E1
objWorksheet.Cells(1,6).Value = "File Size" 'Cell F1
objWorksheet.Cells(1,7).Value = "Creation Date" 'Cell G1
objWorksheet.Cells(1,8).Value = "Last Modified" 'Cell H1
objWorksheet.Cells(1,9).Value = "File Owner" 'Cell I1
objWorksheet.Cells(1,10).Value = "Point of Contact" 'Cell J1
objWorksheet.Cells(1,11).Value = "POC Contact Number" 'Cell K1
objWorksheet.Cells(1,12).Value = "File Status" 'Cell L1
'******************************************************************************
'Set Column Headings to Bold
'******************************************************************************
objWorksheet.Range("A1:Z1").Font.Bold = True
'******************************************************************************
' Format the spreadsheet.
'******************************************************************************
Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1
'******************************************************************************
'Defign Worksheet Ranges for Sorting and column sizing.
'******************************************************************************
Dim objRange, objRange1, objRange2, objRange3, objRange4
Dim objRange5, objRange6, objRange7, objRange8, objRange9
Set objRange = objWorksheet.UsedRange
Set objRange1 = objExcel.Range("A1") 'Sort by File Type
Set objRange2 = objExcel.Range("B1") 'Sort by File Name
Set objRange3 = objExcel.Range("C1") 'Sort by Extension
Set objRange4 = objExcel.Range("D1") 'Sort by Drive Letter
Set objRange5 = objExcel.Range("E1") 'Sort by Path (Folder)
Set objRange6 = objExcel.Range("F1") 'Sort by File Size
Set objRange7 = objExcel.Range("G1") 'Sort by Creation Date
Set objRange8 = objExcel.Range("H1") 'Sort by Last Modified
Set objRange9 = objExcel.Range("I1") 'Sort by File Owner
'******************************************************************************
' Format FileSize with Commas
'******************************************************************************
objRange6.EntireColumn.NumberFormat = "#,##0"
objRange7.EntireColumn.NumberFormat = "mm/dd/yyyy hh:mm;@"
objRange8.EntireColumn.NumberFormat = "mm/dd/yyyy hh:mm;@"
'******************************************************************************
'Autofit all columns
'******************************************************************************
objRange.EntireColumn.Autofit()
'******************************************************************************
' Search for user specified files
'******************************************************************************
Dim colFiles
If strExtension = "*" Then
Set colFiles = objWMIService. _
ExecQuery("SELECT * FROM CIM_DataFile" _
& " WHERE Drive = '" & strDrive & ":'")
StrFileCount = colFiles.Count
Else
Set colFiles = objWMIService. _
ExecQuery("SELECT * FROM CIM_DataFile" _
& " WHERE Drive = '" & strDrive & ":'" _
& " AND Extension = '" & strExtension & "'")
StrFileCount = colFiles.Count
End If
' WScript.Echo "# of files found: " & colFiles.Count
'******************************************************************************
' Fill in the open Excel Spreadsheet
'******************************************************************************
Dim objFile, strOwner
k = 2
For Each objFile in colFiles
objWorksheet.Cells(k,1).Value = objFile.FileType 'A
objWorksheet.Cells(k,2).Value = objFile.FileName 'B
objWorksheet.Cells(k,3).Value = LCase(objFile.Extension) 'C
objWorksheet.Cells(k,4).Value = UCase(objFile.Drive) 'D
objWorksheet.Cells(k,5).Value = objFile.Path 'E
objWorksheet.Cells(k,6).Value = objFile.FileSize 'F
objWorksheet.Cells(k,7).Value = ConvWMITime(objFile.CreationDate) 'G
objWorksheet.Cells(k,8).Value = ConvWMITime(objFile.LastModified) 'H
strOwner = GetOwner(objFile.Name) 'I
If strOwner = NULL Then
objWorksheet.Cells(k,9).Value = "Unknown"
ElseIf strOwner = "" Then
objWorksheet.Cells(k,9).Value = "Unknown"
Else
objWorksheet.Cells(k,9).Value = strOwner
End If
k = k + 1
' End If
Next
'******************************************************************************
'Autofit all columns
'******************************************************************************
objRange.EntireColumn.Autofit()
'******************************************************************************
'Set sorting order
'******************************************************************************
' objRange.Sort objRange1, xlAscending, , , , , , xlYes
' objRange.Sort objRange2, xlAscending, , , , , , xlYes
' objRange.Sort objRange3, xlAscending, , , , , , xlYes
' objRange.Sort objRange4, xlAscending, , , , , , xlYes
objRange.Sort objRange5, xlAscending, objRange1, , xlDescending, _
objRange8, xlDescending, xlYes
'******************************************************************************
'Display Count of ROWS Added
'******************************************************************************
Dim strFileCountMSG, StrFileCount, k
strFileCountMSG = msgbox(k - 2 & " ROWS written out of " & StrFileCount,_
48,"ALERT")
'******************************************************************************
' Save Spreadsheet and Quit Excel.
'******************************************************************************
' Save the spreadsheet and close the workbook.
objExcel.ActiveWorkbook.SaveAs strExcelPath
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit
'******************************************************************************
' Clean up Objects and Variables we created.
'******************************************************************************
Set objExcel = Nothing
Set objWMIService = Nothing
Set objShell = Nothing
Set objWorksheet = Nothing
Set colFiles = Nothing
Set objFile = Nothing
Set objRange = Nothing
Set objRange1 = Nothing
Set objRange2 = Nothing
Set objRange3 = Nothing
Set objRange4 = Nothing
Set objRange5 = Nothing
Set objRange6 = Nothing
Set objRange7 = Nothing
Set objRange8 = Nothing
Set objRange9 = Nothing
strComputer = Null
strDrive = Null
strExtension = Null
strExcelPath = Null
k = Null
StrFileCount = Null
strFileCountMSG = Null
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><> <><>
'<><> Start of Subroutines and Functions <><>
'<><> <><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
'******************************************************************************
' Convert WMI Time Function
'******************************************************************************
Public Function ConvWMITime(wmiTime)
Dim yr, mo, dy, tm
yr = left(wmiTime,4)
mo = mid(wmiTime,5,2)
dy = mid(wmiTime,7,2)
tm = mid(wmiTime,9,6)
ConvWMITime = mo & "/" & dy & "/" & yr & " " & FormatDateTime(left(tm,2) & _
":" & Mid(tm,3,2) & ":" & Right(tm,2),3)
End Function
'******************************************************************************
' Convert WMI Time Function
'******************************************************************************
Public Function dtConvert(strDateTime)
Dim strConvertDT
' Convert File DateTime Stamp to a readable format
strConvertDT = CDate(Mid(strDateTime, 5, 2) & "/" &_
Mid(strDateTime, 7, 2) & _
"/" & Left(strDateTime, 4) & " " &_
Mid (strDateTime, 9, 2) & ":" & _
Mid(strDateTime, 11, 2) & ":" & _
Mid(strDateTime, 13, 2))
dtConvert = strConvertDT
End Function
'******************************************************************************
' Get File Attribute "Owner"
'******************************************************************************
Public Function GetOwner(strFile)
Dim objCollection, objSID
On Error Resume Next
' When processing multiple files make the WMI Local Computer Object Global!
' (Move outside the Function)
'strComputer = "."
'Set objWMIService = GetObject("winmgmts:" _
' & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set objCollection = objWMIService.ExecQuery _
("ASSOCIATORS OF {Win32_LogicalFileSecuritySetting='" & strFile _
& "'} WHERE AssocClass=Win32_LogicalFileOwner ResultRole=Owner")
For Each objSID in objCollection
GetOwner = objSID.AccountName
Next
If VarType(GetOwner) = 0 Then
GetOwner = "error"
End If
On Error GoTo 0
End Function
'******************************************************************************
' Convert Standard DateTime to WMI DateTime Function
'******************************************************************************
Public Function ConvDateTimeWMI(strDateTime)
Dim oswbemdtm
set oswbemdtm=createobject("wbemscripting.swbemdatetime")
oswbemdtm.setvardate strDateTime,true 'CONVERT_TO_LOCAL_TIME=true
ConvDateTimeWMI = oswbemdtm
set oswbemdtm = Nothing
End Function
'******************************************************************************
' Prompt User for Drive Letter to search.
'******************************************************************************
Public Function funDriveSelect()
Dim strDriveSelect, intReturn
Const TimeOut = 20
strDriveSelect=UCase(InPutBox("Enter Drive Letter", "Search Drive", "O"))
If strDriveSelect = "" Then
intReturn = objShell.Popup("No User Input Found." & vbCrLf &_
"Would you like to Retry?" ,TimeOut, _
"Information Window", vbYesNo)
Select CASE intReturn
Case 1
' Wscript.Echo "You clicked the OK button."
Case 2
' Wscript.Echo "You clicked the CANCEL button."
Wscript.Quit
Case 3
' Wscript.Echo "You clicked the ABORT button."
Case 4
' Wscript.Echo "You clicked the RETRY button."
subDriveSelect()
Case 5
' Wscript.Echo "You clicked the IGNOR button."
Case 6
' Wscript.Echo "You clicked the YES button."
subDriveSelect()
Case 7
' Wscript.Echo "You clicked the NO button."
Wscript.quit
Case Else
' Wscript.echo "PopUp Timed Out!!"
Wscript.quit
End Select
End If
funDriveSelect = strDriveSelect
End Function
'******************************************************************************
' Prompt User for File Extention to search for.
'******************************************************************************
Public Function funFileExtention()
Dim strFileExtension, intReturn
Const TIMEOUT = 20 ' Constant set for User prompt timeout
strFileExtension=UCase(InPutBox("Enter File Name Extension to search for.", _
"File Extension Search", "MDB"))
If strFileExtension = "" Then
intReturn = objShell.Popup("No User Input Found." & vbCrLf &_
"Would you like to Retry?" ,TimeOut, _
"Information Window", vbYesNo)
Select CASE intReturn
Case 1
' Wscript.Echo "You clicked the OK button."
Case 2
' Wscript.Echo "You clicked the CANCEL button."
Wscript.Quit
Case 3
' Wscript.Echo "You clicked the ABORT button."
Case 4
' Wscript.Echo "You clicked the RETRY button."
subDriveSelect()
Case 5
' Wscript.Echo "You clicked the IGNOR button."
Case 6
' Wscript.Echo "You clicked the YES button."
subDriveSelect()
Case 7
' Wscript.Echo "You clicked the NO button."
Wscript.quit
Case Else
' Wscript.echo "PopUp Timed Out!!"
Wscript.quit
End Select
End If
funFileExtention = strFileExtension
End Function
'******************************************************************************
' Prompt User for Date and Time to search for.
'******************************************************************************
Public Function funDateInput()
Dim strDate, intReturn
Const TIMEOUT = 20 ' Constant set for User prompt timeout
strDate=InPutBox("Enter beginning Date and Time for Search." & VBcrlf & _
VBcrlf & "Ending Date and Time will be: " & vbCrLf &_
" " & Date() & " 12:00 AM", _
"Date Range Search", datevalue(dateadd("m",-1,Now())) _
& " 12:00 AM")
If strDate = "" Then
intReturn = objShell.Popup("No User Input Found." & vbCrLf &_
"Would you like to Retry?" ,TimeOut, _
"Information Window", vbYesNo)
Select CASE intReturn
Case 1
' Wscript.Echo "You clicked the OK button."
Case 2
' Wscript.Echo "You clicked the CANCEL button."
Wscript.Quit
Case 3
' Wscript.Echo "You clicked the ABORT button."
Case 4
' Wscript.Echo "You clicked the RETRY button."
subDriveSelect()
Case 5
' Wscript.Echo "You clicked the IGNOR button."
Case 6
' Wscript.Echo "You clicked the YES button."
subDriveSelect()
Case 7
' Wscript.Echo "You clicked the NO button."
Wscript.quit
Case Else
' Wscript.echo "PopUp Timed Out!!"
Wscript.quit
End Select
funDateInput = strDate
End If
End Function
'******************************************************************************
' Icons for objShell.Popup
'******************************************************************************
' STOP vbCritical 16
' QUESTION MARK vbQuestion 32
' EXCLAMATION MARK vbExclamation 48
' INFORMATION vbInformation 64
'******************************************************************************
' Button Set for objShell.Popup
'******************************************************************************
' OK vbOKOnly 0
' OK and CANCEL vbOKCancel 1
' ABORT, RETRY and IGNORE vbAbortRetryIgnore 2
' YES, NO and CANCEL vbYesNoCancel 3
' YES and NO vbYesNo 4
' RETRY and CANCEL vbRetryCancel 5
'******************************************************************************
' Default Buttons for objShell.Popup
'******************************************************************************
' LEFT vbDefaultButton1 0
' MIDDLE vbDefaultButton2 256
' RIGHT vbDefaultButton3 512
'******************************************************************************
' Buttons Values for objShell.Popup
'******************************************************************************
' 1 VbOK OK
' 2 VbCancel Cancel
' 3 VbAbort Abort
' 4 VbRetry Retry
' 5 VbIgnore Ignore
' 6 VbYes Yes
' 7 VbNo No
