Origional Question:
How do I quickly scan an excel file and determine if it has/uses Macros
using VB6?
Where we are so far:
With the help of JLatham, NickHK, PFLugs and Peter T (sorry if I missed
anyone) I have thrown together the following program(I am using VB6).
As you can see there are different results in both scans, I also had to put
error handling in WorkbookHasVBACode and doIhavecode
to keep it running when I get errors trying to open some xls files. I
scanned about 100 files and recieved mixed results with both differnet macro
scans.
Also, I had problems with some of the code. Specifically: understanding the
filestocol function, the end of the line If by(i) = 95 Then '"_"
removing the hascode="true" in the same section and using cnt. and also the
section from PFlugs about adding setting Macro security. I have excel 2000
but am doing this in VB6
Also I didn't see the reference in excel for this (all blank)
If anybody would like to try this the whole program is included, I know it
doesn't use the best practices, and probably has a few bugs...for the most
part it is functional and I hope with a little work and the right info it
can be made reliable. Thanks again everybody for helping a noob.
CODE:::::
add the "microsoft common dialog control6 sp3" component
check the "microsoft excel 9.0 object library" reference
main form objects xlscanner.frm
add all the objects below to the main form xlscanner.frm
drive1 - drivelistbox
dir1 -dirlistbox
file1 -filelistbox
listview1 -listviewbox set
properties-view=3,multiselect=checked,allowcolumnreorder=checked,
fullrowselect=checked,sorted=checked with 4 column headers.
1=path,2=filename,3=macro,4=macro2
text1 -textbox with label next to stating "will be scanning"
label5 label with empty text field
text3 textbox
text2 textbox
includesubdirs checkbox with label next to stating "include subdirectories"
report checkbox with label stating "generate report to
"c:\xlsreport.txt"
scandirbutton command button labeled "Scan Directory"
processbutton command button labeled "process files"
exitbutton command button labeled "exit"
add a secondary form called "reading.frm" no code, just have a small form
that has a label with "reading" in a big font
a general module with the following...I know....
Public sPath$
Public tmpary(100000) As String
Public tyhdpath(100000) As String
Public tyhdpath2(100000) As String
Public tmparycnt
Public tyhd(100000) As String
Public tyhdcnt
Public tmp1$
Public flag2$
this is the code for the main form:xlscanner.frm
(just paste into the xlscanner.frm)
Sub DoIHaveCode()
Dim HasCodeResult As Boolean
On Error GoTo ErrorHandler
HasCodeResult = WorkbookHasVBACode(ActiveWorkbook)
Worksheets("Sheet1").Activate
ErrorHandler:
End Sub
Function WorkbookHasVBACode(wb As Workbook) As Boolean
'adapted from
'
http://j-walk.com/ss/excel/tips/tip70.htm
'by J. Walkenbach
'
flag2$ = "Error"
On Error GoTo ErrorHandler
WorkbookHasVBACode = False ' default
If wb.VBProject.VBComponents(wb.CodeName). _
CodeModule.CountOfLines > 0 Then
WorkbookHasVBACode = True
flag2$ = "True"
End If
If wb.VBProject.VBComponents(wb.CodeName). _
CodeModule.CountOfLines = 0 Then
WorkbookHasVBACode = False
flag2$ = "False"
End If
ErrorHandler:
End Function
Function hasCode(sFile As String) As Variant
Dim FF As Integer
Dim i As Long, j As Long
Dim cnt As Long
Dim ba() As Byte
Dim by() As Byte
ba() = "_VBA_PROJECT_CUR"
FF = FreeFile
On Error GoTo errH
Open sFile For Binary As FF
ReDim by(LOF(FF) - 1)
Get FF, , by()
Close FF
For i = 0 To UBound(by)
If by(i) = 95 Then '"_"
For j = 0 To UBound(ba) Step 2
If by(i + j) <> ba(j) Then Exit For
Next
If j = UBound(ba) + 1 Then
hasCode = True
Exit Function
'' or comment above & return cnt of occurrences
' cnt = cnt + 1
End If
End If
Next
' hasCode = cnt
Exit Function
errH:
'Stop
Close FF
End Function
Private Sub processbutton_Click()
'scan the selected files
reading.Show
main.Enabled = False
DoEvents
If report.Value = 1 Then Open "C:\xlsreport.txt" For Output As #1
ListView1.ListItems.Clear
'start main loop - process all files in array
For l = 1 To tyhdcnt
tmp1$ = tyhdpath(l) + tyhd(l)
Text2.Text = tmp1$
'copy file to temp location so it doesn't get messed up
tmp1d$ = "c:\temp\" + tyhd(l)
FileCopy tmp1$, tmp1d$
'process temp file
Text3.Text = tmp1d$
'call hascode function macro scan 1
tmp2$ = hasCode(tmp1d$)
'call workbookhasvbacode function macro scan 2
Workbooks.Open FileName:=tmp1d$, ReadOnly:=True, UpdateLinks:=0,
Notify:=False
'tmp2$ = WorkbookHasVBACode(ActiveWorkbook)
Call DoIHaveCode
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
'set to true or false from hascode function
If tmp2$ <> "True" Then tmp2$ = "False"
'write to report on c:\xlsreport.txt
If report.Value = 1 Then Print #1, tyhdpath(l) + tyhd(l) + "," + tmp2$ + ","
+ flag2$
'add items to listview1 box with color as they are processed
Set list_item = ListView1.ListItems.Add(, , tyhdpath(l))
If tmp2$ = "True" Then list_item.ForeColor = vbRed Else list_item.ForeColor
= vbGreen
Set list_sub = list_item.ListSubItems.Add
If tmp2$ = "True" Then list_sub.ForeColor = vbRed Else list_sub.ForeColor =
vbGreen
Set list_sub2 = list_item.ListSubItems.Add
If tmp2$ = "True" Then list_sub2.ForeColor = vbRed Else list_sub2.ForeColor
= vbGreen
list_item.SubItems(1) = tyhd(l)
If tmp2$ <> "True" Then list_item.SubItems(2) = "False" Else
list_item.SubItems(2) = "True"
Set list_sub3 = list_item.ListSubItems.Add
If flag2$ = "True" Then list_sub3.ForeColor = vbRed
If flag2$ = "False" Then list_sub3.ForeColor = vbGreen
If flag2$ = "Error" Then list_sub3.ForeColor = vbBlack
list_item.SubItems(3) = flag2$
DoEvents
Kill tmp1d$
Next l
Close #1
reading.Hide
main.Enabled = True
main.Show
End Sub
Private Sub scandirbutton_Click()
'clicked scan the dir----this will create an array of only the excel files
'check includesubdirs.value for subdirs-stores xls files in array
tyhdpath(tyhdcnt)
tyhdcnt = 0
ListView1.ListItems.Clear
tmparycnt = 0
reading.Show
main.Enabled = False
DoEvents
'get files from just this dir, subdir not checked
If main.includesubdirs.Value = 0 Then
For l = 0 To File1.ListCount
tyhdcnt = tyhdcnt + 1
'save path
tyhdpath(tyhdcnt) = sPath$
'save filename
tyhd(tyhdcnt) = File1.List(l)
tyhd(tyhdcnt) = Trim(tyhd(tyhdcnt))
'check to see if xls=set to "" and don't add this one if not
tmp2$ = (Right$(tyhd(tyhdcnt), 3))
tmp2$ = UCase$(tmp2$)
If tmp2$ <> "XLS" Then tyhdcnt = tyhdcnt - 1
DoEvents
Next l
End If
DoEvents
'get files from this dir and all subdirs
If main.includesubdirs.Value = 1 Then
scnpth = sPath$
ListAllFilesInAllSubDirs (scnpth)
'loop through results of file list to remove non-xls and blank and add to
main array
tyhdcnt = 0
For l = 0 To tmparycnt
tmpary(l) = Trim(tmpary(l))
goodfile = 1
If tmpary(l) = "" Then goodfile = 0
'check to see if xls don't add this one if not
tmp2$ = (Right$(tmpary(l), 3))
tmp2$ = UCase$(tmp2$)
If tmp2$ <> "XLS" Then goodfile = 0
If goodfile = 1 Then
tyhdcnt = tyhdcnt + 1
instring$ = tyhdpath2(l)
Begin7:
instring$ = Replace(instring$, "\\", "\")
If (Replace(instring$, "\\", "\") <> instring$) Then GoTo Begin7
instring$ = Trim(instring$)
tyhdpath2(l) = instring$
tyhd(tyhdcnt) = tmpary(l)
tyhdpath(tyhdcnt) = tyhdpath2(l)
End If
Next l
End If
goodfile = 1
reading.Hide
main.Enabled = True
main.Show
DoEvents
'print to listview1 for review
For l = 1 To tyhdcnt
tmp1$ = tyhdpath(l) + tyhd(l)
Set list_item = ListView1.ListItems.Add(, , tyhdpath(l))
list_item.SubItems(1) = tyhd(l)
Next l
'update total items counter
Text1.Text = ListView1.ListItems.Count
tmp1$ = Str(tyhdcnt) + " :Files Selected"
Label5.Caption = tmp1$
If tyhdcnt > 0 Then processbutton.Visible = True
End Sub
Private Sub ListAllFilesInAllSubDirs(ByVal strStartingDir As String)
'Recursive function to traverse a directory tree.
Dim dir_names() As String
Dim num_dirs As Integer
Dim i As Integer
Dim strFileName As String
Dim attr As Integer
On Error Resume Next
' tmparycnt = 0
' Get the files in the current directory.
strFileName = Dir(strStartingDir & "\" & "*.*", vbNormal)
Do While strFileName <> ""
'Do something with the file
tmparycnt = tmparycnt + 1
'use variables for tydb and tycnt for flexibility
tmpary(tmparycnt) = strFileName
'need path saved in array for deletion
tyhdpath2(tmparycnt) = strStartingDir & "\"
tyhdpath2(tmparycnt) = Trim(tyhdpath2(tmparycnt))
tmpary(tmparycnt) = Trim(tmpary(tmparycnt))
If tmpary(tmparycnt) = "" Then tmparycnt = tmparycnt - 1
strFileName = Dir()
Loop
' Get the list of the subdirectories in this directory
strFileName = Dir(strStartingDir & "\*.*", vbDirectory)
Do While strFileName <> ""
' Skip this dir and its parent.
attr = 0 ' In case there's an error.
attr = GetAttr(strStartingDir & "\" & strFileName)
If strFileName <> "." And _
strFileName <> ".." And _
(attr And vbDirectory) <> 0 Then
num_dirs = num_dirs + 1
ReDim Preserve dir_names(1 To num_dirs)
dir_names(num_dirs) = strFileName
End If
strFileName = Dir()
Loop
' Search all the other subdirectories.
For i = 1 To num_dirs ' The recursion bottoming out condition
' This is the recursive line
ListAllFilesInAllSubDirs strStartingDir & "\" & dir_names(i)
Next i
DoEvents
End Sub
Private Sub Dir1_Change()
'changed dir-set scan path-update drive,dir and file boxes
sPath$ = Trim$(Dir1.Path): File1.Path = sPath$
'check for trailing "\" and add if missing
If Right$(sPath$, 1) <> "\" Then sPath$ = sPath$ + "\"
'Update textbox to show dir to scan
Text1.Text = sPath$
End Sub
Private Sub Drive1_Change()
'changed drive-set scan path-update drive,dir and file boxes
Dir1.Path = Drive1.Drive: sPath$ = Dir1.Path: sPath$ = Trim$(sPath$):
File1.Path = sPath$
'check for trailing "\" and add if missing
If Right$(sPath$, 1) <> "\" Then sPath$ = sPath$ + "\"
'Update textbox to show dir to scan
Text1.Text = sPath$
End Sub
Private Sub exitbutton_Click()
'exit
End
End Sub
Private Sub Form_Load()
processbutton.Visible = False
End Sub
Private Sub ListView1_ColumnClick(ByVal ColumnHeader As
MSComctlLib.ColumnHeader)
'performs sort on either column
If ListView1.SortOrder = lvwAscending Then
ListView1.SortOrder = lvwDescending
Else: ListView1.SortOrder = lvwAscending
End If
ListView1.SortKey = ColumnHeader.Index - 1
End Sub