Excel 提取压缩文件需要授权

我正在尝试使用FileCopy方法将xlsm文件复制到zip文件。之后，我需要将压缩文件解压缩到临时路径 下面的代码第一次运行良好

Sub Test()
Dim tmpPdf      As String
Dim oApp        As Object
Dim i           As Long

Dim tmpPath       As Variant
tmpPath = ThisWorkbook.Path & "\Temp"

Dim excelFile     As Variant
excelFile = ThisWorkbook.Path & "\New.xlsm"

Dim zipName       As Variant
zipName = ThisWorkbook.Path & "\New.zip"

On Error Resume Next
    Kill zipName

    With CreateObject("Scripting.FileSystemObject")
        .DeleteFolder tmpPath
        .CreateFolder tmpPath
        Application.Wait Now + TimeValue("00:00:03")
    End With

    'Kill tmpPath & "\*.*"

    FileCopy excelFile, zipName
    'If Err.Number <> 0 Then MsgBox "Unable To Copy": Exit Sub
On Error GoTo 0
Set oApp = CreateObject("Shell.Application")

UnZipFile zipName, tmpPath


MsgBox "Done...", 64

End Sub

Sub UnZipFile(zippedFileFullName As Variant, unzipToPath As Variant)
Dim shellApp As Object

Set shellApp = CreateObject("Shell.Application")
shellApp.Namespace(unzipToPath).CopyHere shellApp.Namespace(zippedFileFullName).items
End Sub

子测试（）
将tmpPdf设置为字符串
作为对象的Dim oApp
我想我会坚持多久
Dim tmpPath作为变体
tmpPath=thispoolk.Path&“\Temp”
将文件作为变量
excelFile=ThisWorkbook.Path&“\New.xlsm”
Dim zipName作为变体
zipName=thispoolk.Path&“\New.zip”
出错时继续下一步
杀死zipName
使用CreateObject（“Scripting.FileSystemObject”）
.delete文件夹tmpPath
.CreateFolder tmpPath
应用程序。立即等待+时间值（“00:00:03”）
以
'Kill tmpPath&'\*.'
FileCopy excelFile，zipName
'如果错误号为0，则MsgBox“无法复制”：退出Sub
错误转到0
设置oApp=CreateObject（“Shell.Application”）
UnZipFile zipName，tmpPath
MsgBox“完成…”，64
端接头
子解压文件（zippedFileFullName作为变量，解压路径作为变量）
将shellApp设置为对象
设置shellApp=CreateObject（“Shell.Application”）
shellApp.Namespace（unzipToPath）.CopyHere shellApp.Namespace（zippedFileFullName）.items
端接头

但第二次尝试我就犯了这样的错误

---

有什么想法吗？

试着保存到

Environ$（“temp”）

？我试过了，但在这一行

shellApp.Namespace（unzipToPath）。CopyHere shellApp.Namespace（zippedFileFullName）。items

tmpPath=thishbook.Path&“\temp”出现运行时错误91

应该是

tmpPath=thispoolk.Path&“\Temp\”

@alowflyingpig我已经试过了，但还是遇到了同样的错误。。