Проблема с InitialFileName из GetOpenFile

Question

Я получил код ниже https://www.rondebruin.nl/win/s7/win002.htm, чтобы распаковать несколько файлов .zip. В исходном коде это не было исходное имя файла, поэтому я попытался его адаптировать, но он не работает. Код начинается в недавнем каталоге, а затем, когда я нажимаю «Отмена», я получаю сообщение об ошибке.

Мне кажется, что я упускаю что-то очень простое c, но я ценю вашу помощь.

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

Не очень понятно, что вы хотите сделать, но вот функция, которая возвращает массив выбранных файлов из диалогового окна 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

Answer 2

Делай так.

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