List Files by File name AND Last Modified Date

'DocScan Report Program
'Scans folders for old files, and generates a report
'Reads a text file for options of folders to scan, file types and age
 
Const ForReading = 1
Dim aDirs
aDirs="D:\"
Dim aExts
Dim dOptionsDate
dOptionsDate=cdate("01/01/2008")
Dim strSortBy
Dim intFileCount
Dim intTotalMB
Dim iMsg 
Dim iConf 
Dim Flds, fName 
Dim strHTML
Dim strSubject
Dim strFrom
Dim strAttachment
dim mailSTR
Const adVarChar = 200
Const adDouble = 5
Const adInteger = 3
Const adDate = 7
Const adCurrency = 6
Const MaxCharacters = 255
'strFile="options.ini"
bDebug=False
Dim log
 
Set oShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set oregexp=new regexp
oregexp.global=true
oregexp.ignorecase=true
 
'******************************
'read the Options.ini file
'*****************************
call ReadOptions()
 
Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "Path", adVarChar, MaxCharacters
DataList.Fields.Append "Size", adDouble, MaxCharacters
DataList.Fields.Append "Age", adInteger, MaxCharacters
DataList.Fields.Append "LastMod", adDate, MaxCharacters
DataList.Open
 
baseDate = Now - dOptionsDate
 
'*************************************
'loop through all folder to read files
'*************************************
for i=lbound(aDirs) to ubound(aDirs)
  on error resume next
  Set fl = fso.GetFolder(aDirs(i))
  If err.number <> 0 then
    Err.Clear
  Else
    'set up regexp search pattern based on extensions from options file
    'pattern should appear something like "^[w- .]+.(com|pif|vbs|vbe|exe|bat|cmd)$"
    strpattern="^[w- .]+.("
    for j=lbound(aExts) to ubound(aExts)
       strpattern = strpattern & (aExts(j))
       if j <> ubound(aExts) then strpattern = strpattern & "|"
    next
    strpattern = strpattern & ")$"
    if bDebug then wscript.echo strpattern
    oregexp.pattern=strpattern
    'call routine to scan folder and recurse through subfolders
    Call ScanFolder (fl)
  End If
next
 
'Write results to file
WriteLogFile
 
'**************************************************************************
Function ScanFolder(fl)
  on error resume next
  Dim sfls, sfl, f, fs
  Set fs = fl.files
  if bDebug then wscript.echo oregexp.pattern
  if bDebug then wscript.echo fl.path
  'loop through each file
  For Each f In fs
    fileName = F.Name
    sFileExt = right(fileName,4)
    IF sFileExt = ".mdc" then
        IF bDebug then wscript.echo f.name
        If f.DateLastModified < baseDate and oregexp.test(f.name) then
          intFileCount=intFilecount+1
          intTotalMB = intTotalMB + (f.size/1024)
          DataList.AddNew
          DataList("Path") = f.name
          DataList("Size") = f.size/1024
          'DataList("Age") = now-f.DateLastModified
          DataList("LastMod") = f.DateLastModified
          DataList.Update
          err.clear
        End If
    End if
  Next
  set sfls = fl.SubFolders
  'recurse through subfolders
  For Each sfl in sfls
    ScanFolder sfl
  Next
End Function
 
'**************************************************************************
Sub ReadOptions()
'Set objFSO = CreateObject("Scripting.FileSystemObject")
'if objFSO.fileexists (strFile) then
  'Set objTextFile = objFSO.OpenTextFile (strFile, ForReading)
  'Do Until objTextFile.AtEndOfStream
    'strTextLine = objTextFile.Readline
    'select case ucase(mid(strTextLine,1,4))
      'case "DIRS"
        'strValue=mid(strTextLine,7,len(strTextLine)-7)
        strValue="D:\Cognos OLAP\JAC_IMS"
        aDirs=split(strValue,";")
      'case "EXTS"
        strValue="mdc"
        aExts=split(strValue,";")
      'case "AGE="
        dOptionsDate=365
      'case "SORT"
        strSortBy="lastmod"
    'end select
  'Loop
  'objTextFile.Close
'else
  'no options file - abort
  'kill message box
 ' retval=oShell.AppActivate("** DocScan Report **")
  'if retval then oShell.SendKeys "{Enter}"
 
 ' wscript.echo "DocScan Error #1 - no options.ini file found.  Program aborted."
  'wscript.quit(1)
'end if
 
if bDebug then
  strmsg="DIRS" & vbcrlf
  for i=lbound(aDirs) to ubound(aDirs)
    strmsg=strmsg & vbtab & aDirs(i) & vbcrlf
  next
  strmsg=strmsg & "EXTS" & vbcrlf
  for i=lbound(aExts) to ubound(aExts)
    strmsg=strmsg & vbtab & aExts(i) & vbcrlf
  next
  strmsg=strmsg & "Date=" & dOptionsDate & vbcrlf
  strmsg=strmsg & "Sort By=" & strSortBy & vbcrlf
  wscript.echo strmsg
end if
End Sub
 
'**************************************************************************
Sub WriteLogFile()
 
 
mailSTR = "<html>"
 
mailSTR=mailSTR & "<header></header>"
mailSTR=mailSTR & "<body>"
 
DataList.Sort = strSortBy
DataList.MoveFirst
mailSTR=mailSTR & "<table>"
Do Until DataList.EOF
  mailSTR=mailSTR & "<tr>"
  mailSTR=mailSTR & "<td>" & DataList.Fields.Item("Path") &  "</td>" & _
      "<td>" & formatnumber(DataList.Fields.Item("Size"),1,0,0,-1) & "</td>" & _
      "<td>" & formatnumber(DataList.Fields.Item("Age"),0,0,0,-1) & "</td>" & _
      "<td>" & DataList.Fields.Item("LastMod") & "</td>"
	mailSTR=mailSTR & "</tr>"
	'mailSTR=mailSTR & "<br>"
    DataList.MoveNext
Loop
mailSTR=mailSTR & "</table>"
 
'write trailing data to output file
mailSTR=mailSTR & "</body>"
mailSTR =mailSTR & "</html>"
 
End Sub
 
'**************************
'envia eMail com lista
'**************************
 
set imsg = createobject("cdo.message")
set iconf = createobject("cdo.configuration")
                        
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.eu.com"
    .Update
End With
 
strHTML=mailSTR
strSubject = "IMS"
strFrom = "sales_ims@its.com"
 
                                
With iMsg
    Set .Configuration = iConf
        .To = "sergiolucena82@gmail.com"        
        .From = strFrom 
        .Subject = strSubject 
        .HTMLBody = strHTML
           
        .Send
    End With
                        
Set iMsg = Nothing
Set iConf = Nothing
                                  

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219: