VBAPassword Prompt while closing Excel - vba

Question

I've got code in a project to read data from a Sheet into a recordset. The VBA code is password protected.
For testing I simplified the code, as shown below:
Option Explicit
Sub sTest()
Dim dbtmp As DAO.Database
Set dbtmp = OpenDatabase(Application.ActiveWorkbook.FullName, False, True, _
"Excel 8.0;HDR=Yes")
dbtmp.Close
Set dbtmp = Nothing
End Sub
Whenever I run this code from a Userform, after closing excel, I get prompted for the VBAProject password. Depending on the, I guess, number of modules in the workbook, I've got to cancel, at least, twice.
I've been breaking my head over this for the last week, read every post on the net I could find, but didn't find a solution yet.

Answer 1

As stated by Miqi180, this issue occurs when references to the workbook are not properly cleared; see Microsoft Knowledge Database
It could also occur when Office AddIns are installed.
There were/are some known issues:
Acrobat PDFMaker COM Addin
Fixed in Acrobat 11.0.1
Dropbox
Not yet fixed; workaround
Other Addin?

Answer 2

Uncheck 'OLE Automation' in the References window:

Answer 3

I have experienced the same problem in an Outlook project which opens an Excel file, so contrary to what others have speculated, it is not directly related to database (ADO or DAO) technology.
From the Microsoft Knowledge Database:
SYMPTOMS
After running a macro that passes a reference for a workbook
containing a password-protected VBA project to an ActiveX dynamic-link
library (DLL), you are prompted for the VBA project password when
Excel quits.
CAUSE
This problem occurs if the ActiveX DLL does not properly release
the reference to the workbook that contains the password-protected VBA
project.
The problem typically occurs when a circular reference between objects exists and the password prompt appears if the objects hold onto a reference for a protected workbook when Excel is closed.
Example: objectA stores a reference to objectB, and objectB stores a reference to objectA. The two objects are not destroyed unless you explicitly set objectA.ReferenceToB = Nothing or objectB.ReferenceToA = Nothing.
As I cannot replicate the symptoms by running your code on my computer, my guess is that you have modified your code for Stackoverflow in a way that removes the problem, e.g. by redefining public variables within the scope of the procedure.

Answer 4

This is a problem that has intermittently plagued my own Excel VBA add-ins for a small number of customers. I've documented the problem in my online documentation: VB Password Prompt.
While working on a specific situation for a client, I came up with a solution. I don't know if it only works for his situation (on just my machine) or if it is more widely applicable.
Insert the line "ThisWorkbook.Saved = True" at the end of the Workbook_BeforeClose event:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' blah blah before close code
ThisWorkbook.Saved = True
End Sub
If anyone has a chance to try this, could you let me know if it helps for you and/or your clients.

Answer 5

DAO isn't a great platform for reading data out of Excel files.
Actually, none of the available Microsoft database driver technologies are - they've all got some memory leaks, and the older ones create a hidden instance of Excel.exe - so anything in the VBA project (like, for example, a missing library or an event that calls noncompiling code) will raise the kind of errors that would make Excel think you are attempting to access the code.
Here's some code that uses ADODB, a more recent database technology that may work around any specific problems with DAO.
I haven't had time to strip out all the stuff that's irrelevant to your request - apologies, there's a lot of it! - but leaving in all those alternative connection strings is probably quite helpful for you: anyone who gets this kind of problem needs to need to play around a little, and work out which technology works by trial and error:
Public Function FetchRecordsetFromWorkbook(ByVal SourceFile As String, _
ByVal SourceRange As String, _
Optional ReadHeaders As Boolean = True, _
Optional StatusMessage As String = "", _
Optional GetSchema As Boolean = False, _
Optional CacheFile As String = "" _
) As ADODB.Recordset
Application.Volatile False
' Returns a static persistent non-locking ADODB recordset from a range in a workbook
' If your range is a worksheet, append "$" to the worksheet name. A list of the 'table'
' names available in the workbook can be extracted by setting parameter GetSchema=True
' If you set ReadHeaders = True the first row of your data will be treated as the field
' names of a table; this means that you can pass a SQL query instead of a range or table
' If you set ReadHeaders = False, the first row of your data will be treatd as data; the
' column names will be allocated automatically as 'F1', 'F2'...
' StatusMessage returns the rowcount if retrieval proceeds without errors, or '#ERROR'
' Be warned, the Microsoft ACE database drivers have memory leaks and stability issues
On Error GoTo ErrSub
Const TIMEOUT As Long = 60
Dim objConnect As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strConnect As String
Dim bFileIsOpen As Boolean
Dim objFSO As Scripting.FileSystemObject
Dim i As Long
Dim TempFile As String
Dim strTest As String
Dim SQL As String
Dim strExtension As String
Dim strPathFull As String
Dim timeStart As Single
Dim strHeaders As String
Dim strFilter As String
If SourceFile = "" Then
Exit Function
End If
' Parse out web folder paths
If Left(SourceFile, 5) = "http:" Then
SourceFile = Right(SourceFile, Len(SourceFile) - 5)
SourceFile = Replace(SourceFile, "%20", " ")
SourceFile = Replace(SourceFile, "%160", " ")
SourceFile = Replace(SourceFile, "/", "\")
End If
strPathFull = SourceFile
If Len(Dir(SourceFile)) = 0 Then
Err.Raise 1004, APP_NAME & "GetRecordsetFromWorkbook", _
"#ERROR - file '" & SourceFile & "' not found."
Exit Function
End If
Set objFSO = FSO
strExtension = GetExtension(strPathFull)
bFileIsOpen = FileIsOpen(SourceFile)
If Not bFileIsOpen Then
TempFile = objFSO.GetSpecialFolder(2).Path & "\" & TrimExtension(objFSO.GetTempName()) _
& "." & strExtension
objFSO.CopyFile SourceFile, TempFile, True
SourceFile = TempFile
End If
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And _
InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
strHeaders = "HDR=Yes"
ElseIf ReadHeaders = True Then
strHeaders = "HDR=Yes"
Else
strHeaders = "HDR=No"
End If
Select Case strExtension
Case "xls"
'strConnect = "ODBC;DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "ReadOnly=1;DBQ=" & Chr(34) & SourceFile & Chr(34) & ";" _
' & ";Extended Properties=" &Chr(34) & "HDR=No;IMEX=1;MaxScanRows=0" & Chr(34) & ";"
'strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Chr(34) & SourceFile & _
' Chr(34) & ";Extended Properties=" & Chr(34) & "Excel 8.0;" & strHeaders _
' & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & _
Chr(34) & "Excel 8.0;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsx"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & Chr(34) & _
"Excel 12.0 Xml;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsm"
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & _
' "ReadOnly=1;DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & _
' ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & _
' ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & _
Chr(34) & ";Persist Security Info=True;Extended Properties=" & Chr(34) _
& "Excel 12.0 Macro;" & strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case "xlsb"
'strConnect = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" & "ReadOnly=1; _
' DBQ=" & SourceFile & ";" & Chr(34) & SourceFile & Chr(34) & ";" & _
' ";Extended Properties=" & Chr(34) & "Excel 12.0;" & strHeaders & _
' ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
' This ACE driver is unstable on xlsb files... But it's more likely to return a result, if you don't mind crashes:
strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Chr(34) & SourceFile & Chr(34) & _
";Persist Security Info=True;Extended Properties=" & Chr(34) & "Excel 12.0;" & _
strHeaders & ";IMEX=1;MaxScanRows=0" & Chr(34) & ";"
Case Else
Err.Raise 999, APP_NAME & "GetRecordsetFromWorkbook", "#ERROR - file format not known"
End Select
On Error GoTo ErrSub
'SetTypeGuessRows
timeStart = VBA.Timer
Set objConnect = New ADODB.Connection
With objConnect
.ConnectionTimeout = TIMEOUT
.CommandTimeout = TIMEOUT
.Mode = adModeRead
.ConnectionString = strConnect
.Open strConnect, , , adAsyncConnect
Do While .State > adStateOpen
If VBA.Timer > timeStart + TIMEOUT Then
Err.Raise -559038737, _
APP_NAME & " GetRecordsetFromWorkbook", _
"Timeout: the Excel data connection object did not respond in the " _
& TIMEOUT & "-second interval specified by this application."
Exit Do
End If
If .State > adStateOpen Then Sleep 100
If .State > adStateOpen Then Sleep 100
Loop
End With
Set rst = New ADODB.Recordset
timeStart = VBA.Timer
With rst
.CacheSize = 8
.PageSize = 8
.LockType = adLockReadOnly
If InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 And _
InStr(7, SourceRange, "FROM", vbTextCompare) > 1 Then
SQL = SourceRange
Else
.MaxRecords = 8192
SQL = "SELECT * FROM [" & SourceRange & "] "
' Exclude empty rows from the returned data using a 'WHERE' clause.
With objConnect.OpenSchema(adSchemaColumns)
strFilter = ""
.Filter = "TABLE_NAME='" & SourceRange & "'"
If .EOF Then
.Filter = 0
.MoveFirst
End If
Do While Not .EOF
If UCase(!TABLE_NAME) = UCase(SourceRange) Then
Select Case !DATA_TYPE
Case 2, 3, 4, 5, 6, 7, adUnsignedTinyInt, adNumeric
' All the numeric types you'll see in a JET recordset from Excel
strFilter = strFilter & vbCrLf & " AND [" & !COLUMN_NAME & "] = 0 "
Case 130, 202, 203, 204, 205
' Text and binary types that pun to vbstring or byte array
strFilter = strFilter & vbCrLf & " AND [" & !COLUMN_NAME & "] = '' "
End Select
' Note that we don't try our luck with the JET Boolean data type
End If
.MoveNext
Loop
.Close
End With
If strFilter <> "" Then
strFilter = Replace(strFilter, vbCrLf & " AND [", " [", 1, 1)
strFilter = vbCrLf & "WHERE " & vbCrLf & "NOT ( " & strFilter & vbCrLf & " ) "
SQL = SQL & strFilter
End If
End If
.Open SQL, objConnect, adOpenForwardOnly, adLockReadOnly, adCmdText + adAsyncFetch
i = 0
Do While .State > 1
i = (i + 1) Mod 3
Application.StatusBar = "Retrieving data" & String(i, ".")
If VBA.Timer > timeStart + TIMEOUT Then
Err.Raise -559038737, _
APP_NAME & " Fetch data", _
"Timeout: the Excel Workbook did not return data in the " & _
TIMEOUT & "-second interval specified by this application."
Exit Do
End If
If .State > 1 Then Sleep 100 ' There's a very slight performance gain doing it this way
If .State > 1 Then Sleep 100
Loop
End With
If rst.State = 1 Then
CacheFile = objFSO.GetSpecialFolder(2).Path & "\" & TrimExtension(objFSO.GetTempName()) & ".xml"
rst.Save CacheFile, adPersistXML ' , adPersistADTG
rst.Close
End If
Set rst = Nothing
objConnect.Close
objConnect.Errors.Clear
Set objConnect = Nothing
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.StayInSync = False
rst.Open CacheFile ', , adOpenStatic, adLockReadOnly, adCmdFile
StatusMessage = rst.RecordCount
Set FetchRecordsetFromWorkbook = rst
ExitSub:
On Error Resume Next
Set rst = Nothing
objConnect.Close
Set objConnect = Nothing
If (bFileIsOpen = False) And (FileIsOpen(SourceFile) = True) Then
For i = 1 To Application.Workbooks.Count
If Application.Workbooks(i).Name = Filename(SourceFile) Then
Application.Workbooks(i).Close False
Exit For
End If
Next i
End If
Exit Function
ErrSub:
StatusMessage = ""
StatusMessage = StatusMessage & ""
If InStr(Err.Description, "not a valid name") Then
StatusMessage = StatusMessage & "Cannot read the data from your file: "
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & Err.Description
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "It's possible that the file has been locked, _
but the most likely explanation is that the file _
doesn't contain the named sheet or range you're _
trying to read: check that you've saved the _
correct range name with the correct file name."
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "If this error persists, please contact the Support team."
MsgBox StatusMessage, vbCritical, APP_NAME & ": data access error:"
StatusMessage = "#ERROR " & StatusMessage
ElseIf InStr(Err.Description, "Could not find the object '& SourceRange") Then
StatusMessage = StatusMessage & ""
StatusMessage = StatusMessage & ""
StatusMessage = StatusMessage & ""
MsgBox Err.Description & vbCrLf & vbCrLf & "Please contact the Support team. _
This error probably means that source _
file is locked, or that the wrong file _
has been saved here: " & vbCrLf & vbCrLf & _
strPathFull, vbCritical, APP_NAME & ": file data error:"
StatusMessage = "#ERROR " & StatusMessage
ElseIf InStr(Err.Description, "Permission Denied") Then
StatusMessage = StatusMessage & "Cannot open the file: "
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & vbTab & Chr(34) & strPathFull & Chr(34)
StatusMessage = StatusMessage & vbCrLf & vbCrLf
StatusMessage = StatusMessage & "Another user probably has this file open. _
Please wait a few minutes, and try again. _
If this error persists, please contact Desktop team."
MsgBox StatusMessage, vbCritical, APP_NAME & ": file access error:"
StatusMessage = "#ERROR " & StatusMessage
Else
StatusMessage = StatusMessage & "#ERROR " & Err.Number & ": " & Err.Description
MsgBox StatusMessage, vbCritical, APP_NAME & ": file data error:"
End If
Resume ExitSub
' # leave this inaccessible statement in place for debugging:
Resume
End Function
Apologies if you run into problems with line breaks around the '_' split lines.
You'll also need declarations for the Constant 'APP_NAME':
PUBLIC CONST APP_NAME As String = "SQL Bluescreen demonstrator"
And a VBA API declaration for the 'Sleep' function:
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows: PtrSafe declarations and LongLong
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongLong)
#ElseIf VBA7 Then ' VBA7 in a 32-bit environment: PtrSafe declarations, but no LongLong
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else ' 32 bit Excel
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Running SQL against Microsoft Excel is best regarded as A Bad Thing: yes, SQL is by far the best tool for large volumes of tabulated data; but no, Microsoft aren't going to fix those memory leaks any time soon. No-one in Redmond is interested in what you are trying to do there - not when you could buy a copy of MS-Access or SQL server andport your data over.
However, it's still the least-worst solution when you're not going to get a SQL Server of your own and you've got a large volume of data in someone else's spreadsheet. Or spreadsheets, plural.
So here's a Horrible Hack to read Excel with SQL.
The subheading to that article reads:
A Cautionary Tale of things that no developer should ever see or do, with diversions and digressions into failures of business logic, workarounds and worse-arounds, budget fairies, business analysts, and scrofulous pilgrims seeking miraculous healing in the elevator lobby.
...and you should treat that as a warning of what you're in for: a long and bitter code-wrangling, to do something that you probably should've done some other way.

Answer 6

Magic! Send the .xlsm attached to an email. Send email to yourself and download the attachment. Launch, enable content received by Internet, enable macro execution. Problem disappeared.