VBAPassword在closuresExcel时提示
我有一个项目中的代码来从工作表读取数据到logging集。 VBA代码是密码保护的。
为了testing，我简化了代码，如下所示：
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 每当我从一个用户窗体运行这个代码，closuresexcel后，我会提示inputVBAProject的密码。 根据我猜想，工作簿中的模块数量，我必须至less取消两次。
上周我一直在为这个问题烦恼，阅读我能find的每一篇文章，但是还没有find解决办法。
如Miqi180 ，当对工作簿的引用没有被正确地清除时，就会出现这个问题。 请参阅Microsoft知识库
Office AddIns安装时也可能发生。 有一些已知的问题：
- Acrobat PDFMaker COM Addin
- 在Acrobat 11.0.1中已修复
- Dropbox的
- 尚未修复; 解决方法
- 其他Addin？
取消选中“参考”窗口中的“OLE自动化”：
我在一个打开Excel文件的Outlook项目中遇到了同样的问题，与其他人所猜测的相反，它与数据库（ADO或DAO）技术没有直接关系。
从Microsoft知识库 ：
症状
运行一个将包含受密码保护的VBA项目的工作簿的引用传递给ActiveXdynamic链接库（DLL）的macros后，退出Excel时系统会提示您inputVBA项目密码。
原因
如果ActiveX DLL不正确释放对包含受密码保护的VBA项目的工作簿的引用，则会出现此问题。
当对象之间存在循环引用时，通常会出现此问题，并且如果在closuresExcel时对象保留在受保护的工作簿的引用上，则会出现密码提示。
示例：objectA存储对objectB的引用，objectB存储对objectA的引用。 除非明确set objectA.ReferenceToB = Nothing或objectB.ReferenceToA = Nothing否则两个对象不会被销毁。
由于我无法通过在计算机上运行代码来复制症状，所以我猜测您已经以某种方式修改了您的Stackoverflow代码，例如通过在过程范围内重新定义公共variables。
这是一个问题，间歇性地困扰着我自己的Excel VBA加载项为less数客户。 我已经logging在我的在线文档中的问题： VB密码提示 。
在为客户处理特定情况的同时，我提出了一个解决scheme。 我不知道它是否适用于他的情况（仅在我的机器上），还是适用于更广泛的情况。
在Workbook_BeforeClose事件的末尾插入“ThisWorkbook.Saved = True”行：
Private Sub Workbook_BeforeClose(Cancel As Boolean) ' blah blah before close code ThisWorkbook.Saved = True End Sub
如果任何人有机会尝试这个，你能不能让我知道它是否有助于你和/或你的客户。
DAO不是一个很好的从Excel文件中读取数据的平台。
实际上，没有一种可用的Microsoft数据库驱动程序技术 – 它们都有一些内存泄漏，而较旧的则创build了Excel.exe的隐藏实例 – 因此VBA项目中的任何内容（例如缺less的库或一个调用非编译代码的事件）将会引起Excel认为你正试图访问代码的那种错误。
下面是一些使用ADODB的代码，这是一个更新的数据库技术，可以解决DAO的任何特定问题。
我没有时间去除与你的请求无关的所有东西 – 道歉，有很多！ – 但是留下所有这些替代的连接string对你来说可能是相当有帮助的：任何得到这种问题的人都需要玩一下，然后通过反复试验找出哪种技术是可行的：
公共职能FetchRecordsetFromWorkbook（ByVal SourceFile作为string，_
ByVal SourceRange As String，_
可选的ReadHeaders为Boolean = True，_
可选的StatusMessage As String =“”，_
可选的GetSchema为布尔=假，_
可选CacheFile As String =“”_
）作为ADODB.Recordset
Application.Volatile False
从工作簿中的范围返回一个静态持久非lockingADODBlogging集
'如果您的范围是工作表，请将“$”附加到工作表名称。 “表”的列表
通过设置参数GetSchema = True，可以提取工作簿中的可用名称
'如果设置ReadHeaders = True，则数据的第一行将被视为字段
'一张桌子的名字; 这意味着您可以传递SQL查询而不是范围或表
'如果您设置ReadHeaders = False，您的数据的第一行将被视为数据; 该
'列名将自动分配为'F1'，'F2'…
'如果检索进行时没有错误，StatusMessage返回行计数，或'#ERROR'
“被警告，微软的ACE数据库驱动程序有内存泄漏和稳定性问题
在错误转到ErrSub
Const TIMEOUT As Long = 60
Dim objConnect As ADODB.Connection
昏暗rst作为ADODB.Recordset
Dim strConnect As String
昏暗的bFileIsOpen作为布尔值
Dim objFSO As Scripting.FileSystemObject
昏暗我只要
Dim TempFile As String
Dim strTest As String
Dim SQL As String
Dim strExtension As String
昏暗strPathFull作为string
昏暗的时间开始为单身
Dim strHeaders As String
Dim strFilter As String
如果SourceFile =“”那么
退出function
万一
parsing出networking文件夹path
如果左（SourceFile，5）=“http：”那么
SourceFile = Right（SourceFile，Len（SourceFile） – 5）
SourceFile = Replace（SourceFile，“％20”，“”）
SourceFile = Replace（SourceFile，“％160”，“”）
SourceFile = Replace（SourceFile，“/”，“\”）
万一
strPathFull = SourceFile
如果Len（Dir（SourceFile））= 0那么
Err.Raise 1004，APP_NAME＆“GetRecordsetFromWorkbook”，_
“#ERROR – 文件'”＆SourceFile＆“'找不到”。
退出function
万一
设置objFSO = FSO
strExtension = GetExtension（strPathFull）
bFileIsOpen = FileIsOpen（SourceFile）
如果不是bFileIsOpen那么
TempFile = objFSO.GetSpecialFolder（2）.Path＆“\”＆TrimExtension（objFSO.GetTempName（））_
＆“。” ＆strExtension
objFSO.CopyFile SourceFile，TempFile，True
SourceFile = TempFile
万一
如果InStr（1，SourceRange，“SELECT”，vbTextCompare）> 0而_
InStr（7，SourceRange，“FROM”，vbTextCompare）> 1然后
strHeaders =“HDR =是”
ElseIf ReadHeaders = True然后
strHeaders =“HDR =是”
其他
strHeaders =“HDR =否”
万一
select案例strExtension
案例“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) & ";"
案例“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) & ";"
案例“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) & ";"
案例“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) & ";"
其他情况
Err.Raise 999，APP_NAME＆“GetRecordsetFromWorkbook”，“#ERROR – 文件格式未知”
结束select
在错误转到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：
在错误恢复下一步
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
'＃为debugging留下这个无法访问的声明：
恢复
结束function
如果遇到“_”分割线周围的换行问题，请抱歉。
您还需要为常量“APP_NAME”声明：
PUBLIC CONST APP_NAME As String =“SQL Bluescreen demonstrator”
和一个VBA API声明的'睡眠'function：
＃如果VBA7和Win64那么64位窗口下的64位Excel：PtrSafe声明和LongLong
私人声明PtrSafe子睡眠库“kernel32”（ByVal dwMilliseconds As LongLong）
#ElseIf VBA7然后'在32位环境中的VBA7：PtrSafe声明，但没有LongLong
私有声明PtrSafe子睡眠库“kernel32”（ByVal dwMilliseconds As Long）
#Else'32位Excel
Private Declare Sub Sleep Lib“kernel32”（ByVal dwMilliseconds As Long）
＃万一
对Microsoft Excel运行SQL最好被认为是一件坏事：是的，SQL是大量列表数据的最佳工具; 但是不，微软不会很快解决这些内存泄漏问题。 雷蒙德没有人对你想要做的事情感兴趣 – 而不是当你可以购买MS-Access或SQL服务器的副本并将你的数据传输出去。
但是，如果你不打算获得你自己的SQL Server，并且在别人的电子表格中有大量的数据，它仍然是最差的解决scheme。 或电子表格，复数。
所以这里有一个可怕的黑客读取SQL与SQL 。
该条的副标题是：
小心提醒没有开发者应该看到或做的事情，在商业逻辑，解决方法和恶劣环境，预算精灵，业务分析师，以及在电梯大厅寻求奇迹般的治疗的sc pil的朝圣者的失败。
…你应该把它看作是你在做什么的警告：一个漫长而痛苦的代码争吵，做一些你可能应该以其他方式做的事情。
魔法！ 发送附加到电子邮件的.xlsm。 发送电子邮件给自己并下载附件。 启动，启用互联网接收的内容，启用macros执行。 问题消失了。