关闭Excel时VBAPassword提示

Question

关闭Excel时VBAPassword提示

我在项目中有代码将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

Run Code Online (Sandbox Code Playgroud)

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

上周我一直在打破这个问题,阅读我能找到的网上的每一篇文章,但还没有找到解决方案.

Answer 1

Nig*_*nan 0

DAO 并不是一个从 Excel 文件读取数据的好平台。

实际上，所有可用的 Microsoft 数据库驱动程序技术都没有 - 它们都有一些内存泄漏，并且较旧的技术会创建 Excel.exe 的隐藏实例 - 因此 VBA 项目中的任何内容（例如，缺少库或调用非编译代码的事件）将引发某种错误，使 Excel 认为您正在尝试访问该代码。

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

我没有时间删除所有与您的要求无关的内容 - 抱歉，内容太多了！- 但是保留所有这些替代连接字符串可能对您很有帮助：任何遇到此类问题的人都需要稍微尝试一下，并通过反复试验找出哪种技术有效：



公共函数 FetchRecordsetFromWorkbook(ByVal SourceFile As String, _
                                           ByVal SourceRange 作为字符串，_
                                           可选 ReadHeaders 作为 Boolean = True, _
                                           可选 StatusMessage As String = "", _
                                           可选 GetSchema 作为 Boolean = False, _
                                           可选的 CacheFile As String = "" _
                                           ) 作为 ADODB.Recordset
应用程序.Volatile False

' 从工作簿中的范围返回静态持久非锁定 ADODB 记录集

' 如果您的范围是工作表，请将“$”附加到工作表名称。“表”的列表
' 可以通过设置参数 GetSchema=True 来提取工作簿中可用的名称

' 如果设置 ReadHeaders = True，数据的第一行将被视为字段
' 表的名称；这意味着您可以传递 SQL 查询而不是范围或表

' 如果设置 ReadHeaders = False，则数据的第一行将被视为数据；这
' 列名将自动分配为 'F1', 'F2'...

' 如果检索过程没有错误，则 StatusMessage 返回行计数，或者 '#ERROR'

' 请注意，Microsoft ACE 数据库驱动程序存在内存泄漏和稳定性问题

出错时转到 ErrSub

常量超时只要 = 60

Dim objConnect As ADODB.Connection
首先变暗为 ADODB.Recordset
Dim strConnect 作为字符串
Dim bFileIsOpen As Boolean

将 objFSO 调暗为 Scripting.FileSystemObject
暗淡我只要

将临时文件变暗为字符串
将 strTest 变暗为字符串
将 SQL 变暗为字符串
将 strExtension 变暗为字符串
Dim strPathFull 作为字符串
昏暗的时间开始为单身
将 strHeaders 变暗为字符串
Dim strFilter 作为字符串

如果 SourceFile = "" 那么
    退出功能
万一

' 解析出Web文件夹路径
如果 Left(SourceFile, 5) = "http:" 那么
    源文件 = 右(源文件, Len(源文件) - 5)
    SourceFile = 替换(SourceFile, "%20", " ")
    SourceFile = 替换(SourceFile, "%160", " ")
    SourceFile = 替换(SourceFile, "/", "\")
万一

strPathFull = 源文件

如果 Len(Dir(SourceFile)) = 0 那么
    Err.Raise 1004，APP_NAME 和“GetRecordsetFromWorkbook”，_
    “#ERROR - 文件 '” & SourceFile & “' 未找到。”
    退出功能
万一

设置 objFSO = FSO

strExtension = GetExtension(strPathFull)

bFileIsOpen = FileIsOpen(源文件)
如果不是 bFileIsOpen 那么
    TempFile = objFSO.GetSpecialFolder(2).Path & "\" & TrimExtension(objFSO.GetTempName()) _
    ＆“。” &str 扩展名
    objFSO.CopyFile 源文件、临时文件、True
    源文件 = 临时文件
万一

如果 InStr(1, SourceRange, "SELECT", vbTextCompare) > 0 且 _
    InStr(7, SourceRange, "FROM", vbTextCompare) > 1 然后
    strHeaders =“HDR=是”
ElseIf ReadHeaders = True 那么
    strHeaders =“HDR=是”
别的
    strHeaders = "HDR=否"
万一

选择案例 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) & ";"
Run Code Online (Sandbox Code Playgroud)

案例“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) & ";"
Run Code Online (Sandbox Code Playgroud)

案例“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) & ";"
Run Code Online (Sandbox Code Playgroud)

案例“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) & ";"
Run Code Online (Sandbox Code Playgroud)

其他情况
    Err.Raise 999、APP_NAME 和“GetRecordsetFromWorkbook”、“#ERROR - 文件格式未知”
结束选择

出错时转到 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
Run Code Online (Sandbox Code Playgroud)

退出子目录：
出错时继续下一步

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
Run Code Online (Sandbox Code Playgroud)

错误子：

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
Run Code Online (Sandbox Code Playgroud)

' # 保留这个不可访问的语句以进行调试：
    恢复

结束功能

如果您遇到“_”分割线周围的换行问题，我们深表歉意。

您还需要常量“APP_NAME”的声明：

PUBLIC CONST APP_NAME As String = "SQL 蓝屏演示器"

以及“睡眠”函数的 VBA API 声明：

#If VBA7 And Win64 Then ' 64 位 Windows 下的 64 位 Excel：PtrSafe 声明和 LongLong 私有声明 PtrSafe Sub Sleep Lib“kernel32”（ByVal dwMilliseconds As LongLong） #ElseIf VBA7 Then ' 32 位环境中的 VBA7：PtrSafe 声明，但没有 LongLong 私有声明 PtrSafe Sub Sleep Lib“kernel32”（ByVal dwMilliseconds As Long） #Else ' 32 位 Excel 私有声明子睡眠库“kernel32”（ByVal dwMilliseconds As Long）＃万一

对 Microsoft Excel 运行 SQL 最好被视为一件坏事：是的，SQL 是迄今为止处理大量表格数据的最佳工具；但微软不会很快修复这些内存泄漏。雷德蒙德没有人对您试图在那里做的事情感兴趣 - 当您可以购买 MS-Access 或 SQL Server 的副本并移植您的数据时。

然而，当您不打算拥有自己的 SQL Server 并且您在别人的电子表格中拥有大量数据时，它仍然是最不糟糕的解决方案。或电子表格，复数。

所以这里有一个用 SQL 读取 Excel 的可怕黑客。

该文章的小标题如下：

这是一个关于开发人员不应该看到或做的事情的警示故事，涉及业务逻辑失败、变通方法和更糟糕的方法、预算仙女、业务分析师和在电梯大厅寻求奇迹治愈的贪婪朝圣者的转移和离题。

...你应该将其视为对你所面临的警告：一场漫长而痛苦的代码争论，去做一些你可能应该以其他方式做的事情。

归档时间：	11 年，5 月前
查看次数：	2989 次
最近记录：	8 年，7 月前