Question

我在项目中有代码将Sheet中的数据读入记录集。 VBA代码受密码保护为了测试我简化了代码，如下所示：

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

每当我从Userform运行此代码时，关闭excel后，系统会提示我输入VBAProject密码。根据，我猜，工作簿中的模块数量，我必须取消，至少两次。

上周我一直在讨论这个问题，阅读我能找到的网上的每一篇文章，但还没有找到解决方案。

Answer 1

如{{1}}所述，如果未正确清除对工作簿的引用，则会出现此问题;见Microsoft Knowledge Database

安装 Office AddIns 时也可能发生这种情况。有一些已知的问题：

Acrobat PDFMaker COM Addin
- 已在Acrobat 11.0.1中修复
Dropbox
- 尚未修复; workaround
其他Addin？

Answer 2

我在打开Excel文件的Outlook项目中遇到了同样的问题，因此与其他人推测的相反，它与数据库（ADO或DAO）技术没有直接关系。

来自Microsoft Knowledge Database：

症状

运行传递工作簿引用的宏之后   包含受密码保护的VBA项目到ActiveX动态链接   库（DLL），当提示您输入VBA项目密码时   Excel退出。

原因

如果ActiveX DLL未正确释放，则会出现此问题   对包含受密码保护的VBA的工作簿的引用   项目

当对象之间存在循环引用时，如果对象在Excel关闭时保留在受保护工作簿的引用上，则会出现密码提示，则通常会出现此问题。

示例：objectA存储对objectB的引用，objectB存储对objectA的引用。除非您明确set objectA.ReferenceToB = Nothing或objectB.ReferenceToA = Nothing。

，否则不会销毁这两个对象

由于我无法通过在我的计算机上运行代码来复制症状，我的猜测是您已经以一种消除问题的方式修改了Stackoverflow的代码，例如：通过在程序范围内重新定义公共变量。

Answer 3

取消选中＆＃OLE; OLE Automation＆＃39;在“参考”窗口中：

enter image description here

Answer 4

这是一个为少数客户间歇性地困扰我自己的Excel VBA加载项的问题。我在在线文档中记录了这个问题：VB Password Prompt。

在为客户处理特定情况时，我想出了一个解决方案。我不知道它是否只适用于他的情况（只在我的机器上）或是否适用范围更广。

插入行＆＃34; ThisWorkbook.Saved = True＆＃34;在Workbook_BeforeClose事件结束时：

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ' blah blah before close code

    ThisWorkbook.Saved = True
End Sub

如果有人有机会试试这个，你能告诉我这对你和/或你的客户是否有帮助。

Answer 5

DAO不是一个从Excel文件中读取数据的绝佳平台。

实际上，没有一种可用的Microsoft数据库驱动程序技术 - 它们都有一些内存泄漏，旧版本创建了Excel.exe的隐藏实例 - 所以VBA项目中的任何内容（例如，等等），一个丢失的库或一个调用非编译代码的事件）将引发一种错误，使Excel认为您试图访问该代码。

这里有一些使用ADODB的代码，这是一种可以解决DAO任何特定问题的最新数据库技术。

我还没有时间去除与你的要求无关的所有东西 - 道歉，其中有很多！ - 但是留在所有这些替代连接字符串中可能对你很有帮助：任何遇到此类问题的人都需要玩一点，并通过反复试验找出哪种技术有效：



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

如果你在＆＃39; _＆＃39;周围出现换行问题，请道歉。分裂线。

您还需要申报Constant＆＃39; APP_NAME＆＃39;：

h = {"A"=> 0, "B"=> 0, "C"=> 1, "D"=> 3, "E"=> 0}
arr = []
h.each {|k,v| arr.include?(v) ? h.delete(k) : arr << v }
#=> {"A"=>0, "C"=>1, "D"=>3}

＆＃39; Sleep＆＃39;的VBA API声明功能：

    private static Expression<Func<T, bool>> BuildContainsPredicate<T>(string propertyName, string propertyValue)
    {
        PropertyInfo propertyInfo = typeof (T).GetProperty(propertyName);

        // ListOfProducts.Where(p => p.Contains(propertyValue))
        ParameterExpression pe = Expression.Parameter(typeof(T), "p");

        MemberExpression memberExpression = Expression.MakeMemberAccess(pe, propertyInfo);
        // Thanks to Servy's suggestion
        Expression toLowerExpression = Expression.Call(memberExpression, typeof(string).GetMethod("ToLower", Type.EmptyTypes));

        MethodInfo methodInfo = typeof (string).GetMethod("Contains", new Type[] {typeof (string)});
        ConstantExpression constantExpression = Expression.Constant(propertyValue, typeof(string));

        // Predicate Body - p.Name.Contains("Saw")
        Expression call = Expression.Call(toLowerExpression, methodInfo, constantExpression);

        Expression<Func<T, bool>> lambda = Expression.Lambda<Func<T, bool>>(call, pe);
        return lambda;
    }

针对Microsoft Excel运行SQL最好被视为一件坏事：是的，SQL是目前大量表格数据的最佳工具;但不，微软不会很快修复这些内存泄漏。雷德蒙德中没有人对您在那里尝试做什么感兴趣 - 而不是当您可以购买MS-Access或SQL服务器的副本并将数据移植到其中时。

但是，如果您不想获得自己的SQL Server并且其他人拥有大量数据，那么它仍然是最差的解决方案。＆＃39;的电子表格。或电子表格，复数。

So here's a Horrible Hack to read Excel with SQL。

该文章的副标题为：

一个警示故事，没有任何开发人员应该看到或做的事情，对业务逻辑，变通办法和更糟糕的事情，预算仙女，商业分析师和寻求奇迹般的治愈的sc sc的朝圣者的失败进行改编和挖掘电梯大厅。

...你应该把它当作对你所做的事情的警告：做一个漫长而痛苦的代码纠缠，做一些你可能应该做的事情。

Answer 6

魔术！发送附加到电子邮件的.xlsm。发送电子邮件给自己并下载附件。启动，启用Internet接收的内容，启用宏执行。问题消失了。

关闭Excel时的VBA密码提示

6 个答案: