Solved: Secure workbook by finding a file

[Gforce1]

I would like to secure an Excel file by forcing the user to enable macros to allow the workbook to open for use and then search for a file located either on a server or the hard drive. If the file is not found, then the workbook would close. I am able to force the user to enable macros but need guidance for the remainder. I want only people who work for the company to be able to use the workbook but understand the security limitations of Excel.

[Bob Phillips]

[vba]

On Error Resume Next
Filename = Dir(full_filename)
On Error Goto 0

If Filename = "" Then

ThisWorkbook.Close SaveChanges:=False
End If
[/vba]

[Gforce1]

Thanks for the fast reply. I tried your suggestion by itself and it worked. When I integrated it with the code I found on this forum that forces the user to enable macros, I got a compile error (didn't recognize "Filename") I forgot to mention we have both Excel 2003 and 2007.

[VBA]Option Explicit

Const WelcomePage = "Macros"
Const HidePage = "Sheet1"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Evaluate if workbook is saved and emulate default propmts
With ThisWorkbook
If Not .Saved Then
Select Case MsgBox("Do you want to save the changes you made to '" & .Name & "'?", _
vbYesNoCancel + vbExclamation)
Case Is = vbYes
'Call customized save routine
Call CustomSave
Case Is = vbNo
'Do not save
Case Is = vbCancel
'Set up procedure to cancel close
Cancel = True
End Select
End If

'If Cancel was clicked, turn events back on and cancel close,
'otherwise close the workbook without saving further changes
If Not Cancel = True Then
.Saved = True
Application.EnableEvents = True
.Close SaveChanges:=False
Else
Application.EnableEvents = True
End If
End With
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Turn off events to prevent unwanted loops
Application.EnableEvents = False

'Call customized save routine and set workbook's saved property to true
'(To cancel regular saving)
Call CustomSave(SaveAsUI)
Cancel = True

'Turn events back on an set saved property to true
Application.EnableEvents = True
ThisWorkbook.Saved = True
End Sub

Private Sub Workbook_Open()

Call FindKey

'Unhide all worksheets
Application.ScreenUpdating = False
Call ShowAllSheets
Application.ScreenUpdating = True
End Sub

Private Sub CustomSave(Optional SaveAs As Boolean)
Dim ws As Worksheet, aWs As Worksheet, newFname As String
'Turn off screen flashing
Application.ScreenUpdating = False

'Record active worksheet
Set aWs = ActiveSheet

'Hide all sheets
Call HideAllSheets

'Save workbook directly or prompt for saveas filename
If SaveAs = True Then
newFname = Application.GetSaveAsFilename( _
fileFilter:="Excel Files (*.xls), *.xls")
If Not newFname = "False" Then ThisWorkbook.SaveAs newFname
Else
ThisWorkbook.Save
End If

'Restore file to where user was
Call ShowAllSheets
aWs.Activate

'Restore screen updates
Application.ScreenUpdating = True
End Sub

Private Sub HideAllSheets()
'Hide all worksheets except the macro welcome page
Dim ws As Worksheet

Worksheets(WelcomePage).Visible = xlSheetVisible

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVeryHidden
Next ws

Worksheets(WelcomePage).Activate
End Sub

Private Sub ShowAllSheets()
'Show all worksheets except the macro welcome page

Dim ws As Worksheet

For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = WelcomePage Then ws.Visible = xlSheetVisible
Next ws

Worksheets(HidePage).Visible = xlSheetHidden

Worksheets(WelcomePage).Visible = xlSheetVeryHidden


End Sub
Private Sub FindKey()
On Error Resume Next
Filename = Dir("c:\Windows\nunya.txt")
On Error GoTo 0
If Filename = "" Then
ThisWorkbook.Close SaveChanges:=False

End If

End Sub
Sub Test1()
Dim a As Variant, s As String
s = """" & DesktopFolder & "\*.txt" & """"
a = FileList(s, True)
If UBound(a) = -1 Then Exit Sub
Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub

Sub Test2()
Dim a As Variant, s As String
s = """" & "c:\" & "DropDownList1.xls" & """"
a = FileList(s, True)
If UBound(a) = -1 Then
MsgBox "DropDownList1.xls not found."
Exit Sub
End If
Range("A1").Resize(UBound(a) + 1).Value = WorksheetFunction.Transpose(a)
End Sub

Function DesktopFolder()
Dim wshShell As Object
Set wshShell = CreateObject("WScript.Shell")
DesktopFolder = wshShell.specialfolders("Desktop")
End Function

Function FileList(Folder As String, Optional subFolders As Boolean = False) As Variant
Dim sf As String, tFile As String
Dim diff As Long
Dim hFile As Integer, Str As String, vArray As Variant, e As Variant
Dim i As Integer, FolderPart As String
Dim iHandle As Integer

'Search subfolders if subFolders=True
sf = ""
If subFolders = True Then sf = "/s "

'Delete temp file if it exists and create path
tFile = Environ$("temp") & "\FileList.txt"
'If Dir$(tFile) <> "" Then Kill tFile
'Write a 0 byte file
iHandle = FreeFile
Open tFile For Output Access Write As #iHandle
Close #iHandle

'Put files into tFile
Shell Environ$("comspec") & " /c Dir /b " & sf & Folder & " > " & tFile, vbHide

'Wait until file writing is complete
Application.StatusBar = "Writing to " & tFile
diff = 1000
Do Until (diff = 0)
Application.Wait (Now + TimeValue("0:00:01"))
diff = diff - FileLen(tFile) 'Allow time for process to complete
Application.Wait (Now + TimeValue("0:00:01"))
If diff = 0 Then Exit Do
diff = FileLen(tFile)
Loop
Application.StatusBar = ""

'Show tFile in Notepad
'Shell "Notepad " & tFile

'Put tFile contents into an array
hFile = FreeFile
Open tFile For Binary Access Read As #hFile
Str = Input(LOF(hFile), hFile)
Close hFile
vArray = Split(Str, vbCrLf)

'Add base path to vArray elements if needed
FolderPart = Left(Folder, InStrRev(Folder, "\"))
For i = 0 To UBound(vArray)
If InStr(vArray(i), ":") <> 2 Then
vArray(i) = FolderPart & vArray(i)
End If
Next i
On Error Resume Next
ReDim Preserve vArray(0 To UBound(vArray) - 1)
FileList = vArray
End Function

Function FolderPart(sPath As String) As String
FolderPart = Left(sPath, InStrRev(sPath, "\"))
End Function
[/VBA]

[Bob Phillips]

What does ... doesn't recognise Filename ... mean, and where does it error?

[Gforce1]

Compile Error: Variable not defined. "Filename =" is highlighted in the Private Sub "FindKey" (using Excel 2003 at the moment).

[Bob Phillips]

That is because, as you are not using Option Explicit, it implicitly declares each new variable, so Findkey has its own Filename variable, which is empty. The other Filename variable is local to its procedure.

You either need to pass Filename as a parameter, or declare it as Public variable.

[Gforce1]

Thank you! Works great!