GetOpenFile中存在InitialFileName的问题

Question

我从https://www.rondebruin.nl/win/s7/win002.htm获得了以下代码，以解压缩多个.zip文件。在原始代码中，它不是一个初始文件名，因此我尝试对其进行修改，但是它不起作用。代码从最近的目录开始，然后单击“取消”时出现错误。

我相信我缺少一些非常基本的东西，但感谢您的帮助。

Sub Unzip_arq()


Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim I As Long
Dim num As Long

Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                    MultiSelect:=True)

With Fname

    .InitialFileName = ThisWorkbook.Path & "\"
    .AllowMultiSelect = False

    If .Show <> -1 Then Exit Sub
End With


If IsArray(Fname) = False Then

Else
    'Root folder for the new folder.

    DefPath = ThisWorkbook.Path
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If


    strDate = Format(Now, " dd-mm-yyyy h_mm_ss")
    FileNameFolder = DefPath & "DEP " & strDate & "\"


    MkDir FileNameFolder


    Set oApp = CreateObject("Shell.Application")

    For I = LBound(Fname) To UBound(Fname)
        num = oApp.Namespace(FileNameFolder).items.Count

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items

    Next I


    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If



End Sub

Answer 1

这样做吧。

Sub Unzip_arq()


Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Dim I As Long
Dim num As Long

Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                    MultiSelect:=True)

If TypeName(Fname) = "Boolean" Then Exit Sub


    'Root folder for the new folder.

    DefPath = ThisWorkbook.Path
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If


    strDate = Format(Now, " dd-mm-yyyy h_mm_ss")
    FileNameFolder = DefPath & "DEP " & strDate & "\"


    MkDir FileNameFolder


    Set oApp = CreateObject("Shell.Application")

    For I = LBound(Fname) To UBound(Fname)
        num = oApp.Namespace(FileNameFolder).items.Count

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items

    Next I


    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

End Sub

Answer 2

不是很清楚您想做什么，但是这是一个从FilePicker对话框返回选定文件数组的函数。

Function MyFileNames() As String()

    Dim Fun() As String                     ' function return array
    Dim MyPath As String
    Dim i As Integer


    MyPath = ThisWorkbook.Path & "\DEP " & Format(Now, " dd-mm-yyyy h_mm_ss") & "\"
    MyPath = Environ("USERPROFILE") & "\Desktop"          ' remove: added for my testing

    With Application.FileDialog(msoFileDialogFilePicker)
        With .Filters
            .Clear
            .Add "Zip Files (*.zip)", "*.zip", 1
            .Add "All Files (*.*)", "*.*", 2
        End With
        .InitialFileName = MyPath
        .AllowMultiSelect = True

        If .Show Then
            With .SelectedItems
                ReDim Fun(1 To .Count)
                For i = 1 To .Count
                    Fun(i) = .Item(i)
                Next i
            End With
        End If
    End With

    MyFileNames = Fun
End Function

使用如下代码从您的过程中调用此函数：-

Dim FullFileName() as String
Dim i as integer
FullFileName = MyFileNames
If (Not FullFileName) = True Then
    For i = 1 to UBound(FullFileName)
        Debug.Print FullFileName(i)
    Next i
End If