Home » excel » vba – VBAPassword Prompt while closing Excel

vba – VBAPassword Prompt while closing Excel

Posted by: admin March 7, 2020 Leave a comment

Questions:

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.

How to&Answers:

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:

Answer:

Uncheck ‘OLE Automation’ in the References window:

enter image description here

Answer:

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:

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:

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:

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.