Reset funkcie vyhladavania Vyřešeno

[mirek443_za]

Zdravím..
Používam macro na vyhľadávanie súboru na disku v Excel 2007 priradené k tlačidlu na forme, po dokončení vyhľadávania by som potreboval nejako zresetovať premenné aby po opätovnom stlačení tlačidla zapisalo do listboxu na userform1 nové výsledky vyhľadania, takto mi zapíše len začiatok vyhľadávania a koniec vzhľadávania.
Za akúkoľvek pomoc ďakujem..

Kód: Vybrat vše

'Find a File on a Drive-Directory

'To search a directory or drive for a specified file or pattern use the following routine. Note, a test routine can be found at the bottom of the post.

Option Explicit

'Purpose     :  Performs a recursive search starting from the specified directory
'               to find the next matching file (uses the file scripting object)
'Inputs      :  sInitialDirectory                   The directory to begin the seach from
'               sFilePattern                        The file pattern to seach for eg. "*.xls"
'Outputs     :  Returns the full path and name of the next matching file
'Notes       :  Can be called recursively to find all instances of the specified file pattern
'               Requires a Reference to SCRRUN.DLL ("Microsoft Scripting Runtime")


Function FileFindFirst(ByVal sInitialDirectory As String, ByVal sFilePattern As String, Optional Reset As Boolean) As String
    Static FSO As Scripting.FileSystemObject, oDirectory As Scripting.Folder, oThisDir As Scripting.Folder
    Static ssLastPattern As String, ssLastFiles As String
    Dim sThisPath As String, sResString As String, sTestFile As String
   
    If (FSO Is Nothing) = True Then
        Set FSO = New Scripting.FileSystemObject
    End If

    If Right$(sInitialDirectory, 1) <> "\" Then
        sInitialDirectory = sInitialDirectory & "\"
    End If
   
   
    'Seach current directory

    sThisPath = sInitialDirectory
    sTestFile = Dir$(sThisPath & sFilePattern)
    Do
        If FileExists(sThisPath & sTestFile) Then
            If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                'Found next matching file
                sResString = sThisPath & sTestFile
                Exit Do
            End If
        Else
            'No more matching files in this directory
            Exit Do
        End If
        'Get next matching file
        sTestFile = Dir$
   
    Loop
   
    If Len(sResString) = 0 Then
        'File not found in sInitialDirectory, search sub directories...
        Set oDirectory = FSO.GetFolder(sInitialDirectory)
        For Each oThisDir In oDirectory.SubFolders
            sThisPath = oThisDir.Path
            If Right$(sThisPath, 1) <> "\" Then
                sThisPath = sThisPath & "\"
            End If
            On Error Resume Next
            sTestFile = Dir$(sThisPath & sFilePattern)
           
        Do
                If FileExists(sTestFile) Then
                   
                    If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                        'Found next matching file
                        sResString = sInitialDirectory & sTestFile
                    End If
                Else
                    'No more matching files in this directory, check it's subfolders
                    sTestFile = FileFindFirst(sThisPath, sFilePattern)
                    If FileExists(sTestFile) Then
                        If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                            'Found next matching file
                            sResString = sTestFile
                            Exit Do
                        End If
                    Else
                        'File not found in sub folder
                        Exit Do
                    End If
                End If
                sTestFile = Dir$
            Loop
            If Len(sResString) Then
                'Found next matching file
                Exit For
            End If
        Next
    End If
   
    If Len(sResString) Then
        'Store search parameters
        If sFilePattern = ssLastPattern Then
            'Routine has been called with same parameters, store all previously matching files
            ssLastFiles = ssLastFiles & "|" & sResString
        Else
            'Store matching file
            ssLastFiles = "|" & sResString
        End If
        ssLastPattern = sFilePattern
        'Return result
        FileFindFirst = sResString
        End If
End Function


'Purpose     :  Checks if a file exists
'Inputs      :  sFilePathName                   The path and file name e.g. "C:\Autoexec.bat"
'Outputs     :  Returns True if the file exists


Function FileExists(sFilePathName As String) As Boolean
    On Error GoTo ExitFunction
    If Len(sFilePathName) Then
        If (GetAttr(sFilePathName) And vbDirectory) < 1 Then
            'File Exists
            FileExists = True
        End If
    End If
ExitFunction:
End Function

'Demonstration Routine
Sub Test1(Optional Reset As Boolean)
    Dim sFile As String
    Dim Hfile As String
   
    UserForm1.ListBox1.Clear
   
    Hfile = InputBox("Zadajte hladaný výraz.", "NÁZOV SÚBORU:")
    If Hfile = vbNullString Then Exit Sub
   
    'Find all instances
    UserForm1.ListBox1.AddItem "Vyhľadávam ----------"
    Debug.Print "Vyhľadávam ----------"
    Do
        sFile = FileFindFirst("c:\", Hfile)
        If Len(sFile) Then
            'Debug.Print sFile
        UserForm1.ListBox1.AddItem (sFile)
        UserForm1.Repaint
        Else
            Debug.Print "--------END OF SEARCH"
            UserForm1.ListBox1.AddItem "Koniec vyhľadávania--------"
            sFile = vbNullString
            Exit Do
        End If
    Loop

End Sub

[Reklama]

[cmuch]

Pro ty co by jim to makro nechtělo fungovat.
Musíte přes Alt+F11 -- Tools -- References... --- povolit Microsoft Scripting Runtime

Jinak když zadám pokaždé jiný soubor tak to zobrazuje jak má, ale jak mile zadám ten samý tak to už nic nevyhledá.
Teď jsem na to chvíli koukal, a v té fci to najde ten soubor i podruhé, ale již ho v listboxu nezobrazí.
O víkendu na to kouknu, pokud na to někdo nepřijde dříve.

[mirek443_za]

vyhľadal som obdobnú, no zdá sa,že ešte rýchlejšiu funkciu..v tejto to už problémy nerobí... zatial testujem no vsetko facha ako ma..

Kód: Vybrat vše

Public cesta As String

Public Function RecursiveDir(colFiles As Collection, _
                              strFolder As String, _
                              strFileSpec As String, _
                              bIncludeSubfolders As Boolean)

     
  Dim blick As Long
  With Application
  blick = .ScreenUpdating
  .ScreenUpdating = False
  End With
 
     Dim strTemp As String
     Dim colFolders As New Collection
     Dim vFolderName As Variant

     'Add files in strFolder matching strFileSpec to colFiles
     strFolder = TrailingSlash(strFolder)
     
     On Error Resume Next ' potrebne pre pokracovanie ak je problem s prehladavanou zlozkou
     
     strTemp = Dir(strFolder & strFileSpec)
     Do While strTemp <> vbNullString
         colFiles.Add strFolder & strTemp
         strTemp = Dir
     Loop

     If bIncludeSubfolders Then
         'Fill colFolders with list of subdirectories of strFolder
         strTemp = Dir(strFolder, vbDirectory)
         Do While strTemp <> vbNullString
             If (strTemp <> ".") And (strTemp <> "..") Then
                 If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
                     colFolders.Add strTemp
                 End If
             End If
             strTemp = Dir
         Loop

         'Call RecursiveDir for each subfolder in colFolders
         For Each vFolderName In colFolders
             Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
         
         With VolbaMoznosti
         .Label10.Caption = "PREHĽADÁVAM:" & vbNewLine & " " & strFolder & vFolderName
         .Repaint
         End With
         
         Next vFolderName
     End If

VolbaMoznosti.Label10.Caption = vbNullString
Application.ScreenUpdating = blick

End Function

Public Function TrailingSlash(strFolder As String) As String
     If Len(strFolder) > 0 Then
         If Right(strFolder, 1) = "\" Then
             TrailingSlash = strFolder
         Else
             TrailingSlash = strFolder & "\"
         End If
     End If
End Function

Public Function MyFolderExists(Path As String) As Boolean
     
     '---------------------------------------------------------------------------
     ' Desc      : When given a path to a folder, this function returns TRUE if
     '             the folder exists and FALSE if it doesn't.
     '
     ' Argument  : The File System Object supports both mapped drive and UNC
     '             paths.
     '
     '             The trailing slash does not matter.  "C:\temp" and
     '             "C:\temp\" are equally valid:  both return TRUE.
     '
     ' Required  : Microsoft Scripting Runtime (scrrun.dll)
     '
     ' Remarks   : The name of this function mirrors the FSO method used.
     '---------------------------------------------------------------------------
     
    Dim objFSO As Object
     
     ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     
    Set objFSO = CreateObject("Scripting.FileSystemObject")
     
    Select Case objFSO.FolderExists(cesta)
    Case True
        MyFolderExists = True
    Case False
        MyFolderExists = False
    End Select
     
     ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
     
    Set objFSO = Nothing
     
End Function
Sub HladajSubor()

Dim blick As Long
With Application
blick = .ScreenUpdating
.ScreenUpdating = False
End With

IncrementalProgress.Increment 10, "Hľadám súbory na disku..."


Dim fso As FileSystemObject
cesta = "f:\"
Set fso = New FileSystemObject
 
 ''check if the folder actually exists or not
 If (Not MyFolderExists(cesta)) Then
 'the folder path is invalid. Exiting.
 Call FolderSelection
 'MsgBox "Základná zložka pre vyhľadávanie neexistuje.", vbInformation
'opakuj:
cesta = fso.GetFolder(NovaCesta)
Else
cesta = fso.GetFolder(cesta)
End If
 
 
' Dim sfile As String
 'sfile = InputBox("Zadaj hľadaný výraz", "VYHĽADÁVANIE")
 'If sfile = vbNullString Then Exit Sub
 
 Dim colFiles As New Collection
     
     RecursiveDir colFiles, cesta, Hladany_Subor, True
     
     'RecursiveDir colFiles, "C:\", "*.xl*", True
     
     Dim vFile As Variant
     For Each vFile In colFiles
         Debug.Print vFile
 
     IncrementalProgress.Increment 20, "Vytváram zoznam.."
     With VolbaMoznosti
     .ListBox1.AddItem vFile
     .ListBox2.AddItem fso.GetFile(vFile).DateLastModified
     .Repaint
     End With
     
     Next vFile
Application.ScreenUpdating = blick
End Sub

[cmuch]

Tak to druhé se mi nepodařilo vůbec rozjet, nějaké makra chybí.

A to první jsem trochu upravil.

Kód: Vybrat vše

Option Explicit

Dim ssLastFiles As String


Private Sub CommandButton1_Click()

 Dim sFile As String
 Dim Hfile As String
   
    UserForm1.ListBox1.Clear
   
    Hfile = InputBox("Zadajte hladaný výraz.", "NÁZOV SÚBORU:")
    If Hfile = vbNullString Then Exit Sub
   
    'Find all instances
    UserForm1.ListBox1.AddItem "Vyhľadávam ----------"
    Debug.Print "Vyhľadávam ----------"
    Do
        sFile = FileFindFirst("c:\", Hfile)
        If Len(sFile) Then
            'Debug.Print sFile
        UserForm1.ListBox1.AddItem (sFile)
        UserForm1.Repaint
        Else
            Debug.Print "--------END OF SEARCH"
            UserForm1.ListBox1.AddItem "Koniec vyhľadávania--------"
            sFile = vbNullString
            Exit Do
        End If
    Loop

ssLastFiles = vbNullString
End Sub

'Find a File on a Drive-Directory

'To search a directory or drive for a specified file or pattern use the following routine. Note, a test routine can be found at the bottom of the post.


'Purpose     :  Performs a recursive search starting from the specified directory
'               to find the next matching file (uses the file scripting object)
'Inputs      :  sInitialDirectory                   The directory to begin the seach from
'               sFilePattern                        The file pattern to seach for eg. "*.xls"
'Outputs     :  Returns the full path and name of the next matching file
'Notes       :  Can be called recursively to find all instances of the specified file pattern
'               Requires a Reference to SCRRUN.DLL ("Microsoft Scripting Runtime")

Function FileFindFirst(ByVal sInitialDirectory As String, ByVal sFilePattern As String, Optional Reset As Boolean) As String
    Static fso As Scripting.FileSystemObject, oDirectory As Scripting.Folder, oThisDir As Scripting.Folder
    Static ssLastPattern As String
    Dim sThisPath As String, sResString As String, sTestFile As String
   
    If (fso Is Nothing) = True Then
        Set fso = New Scripting.FileSystemObject
    End If

    If Right$(sInitialDirectory, 1) <> "\" Then
        sInitialDirectory = sInitialDirectory & "\"
    End If
       
    'Seach current directory
    sThisPath = sInitialDirectory
    sTestFile = Dir$(sThisPath & sFilePattern)
    Do
        If FileExists(sThisPath & sTestFile) Then
            If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                'Found next matching file
                sResString = sThisPath & sTestFile
                Exit Do
            End If
        Else
            'No more matching files in this directory
            Exit Do
        End If
        'Get next matching file
        sTestFile = Dir$
    Loop
   
    If Len(sResString) = 0 Then
        'File not found in sInitialDirectory, search sub directories...
        Set oDirectory = fso.GetFolder(sInitialDirectory)
        For Each oThisDir In oDirectory.SubFolders
            sThisPath = oThisDir.Path
            If Right$(sThisPath, 1) <> "\" Then
                sThisPath = sThisPath & "\"
            End If
            On Error Resume Next
            sTestFile = Dir$(sThisPath & sFilePattern)
           
            Do
                If FileExists(sTestFile) Then
                   
                    If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                        'Found next matching file
                        sResString = sInitialDirectory & sTestFile
                    End If
                Else
                    'No more matching files in this directory, check it's subfolders
                    sTestFile = FileFindFirst(sThisPath, sFilePattern)
                    If FileExists(sTestFile) Then
                        If InStr(1, ssLastFiles, "|" & sThisPath & sTestFile) = 0 Then
                            'Found next matching file
                            sResString = sTestFile
                            Exit Do
                        End If
                    Else
                        'File not found in sub folder
                        Exit Do
                    End If
                End If
                sTestFile = Dir$
            Loop
            If Len(sResString) Then
                'Found next matching file
                Exit For
            End If
        Next
    End If
   
    If Len(sResString) Then
        'Store search parameters
        If sFilePattern = ssLastPattern Then
            'Routine has been called with same parameters, store all previously matching files
            ssLastFiles = ssLastFiles & "|" & sResString
          Else
            'Store matching file
            ssLastFiles = "|" & sResString
        End If
        ssLastPattern = sFilePattern
        'Return result
        FileFindFirst = sResString
    End If
         
    Set fso = Nothing
    Set oDirectory = Nothing
End Function


'Purpose     :  Checks if a file exists
'Inputs      :  sFilePathName                   The path and file name e.g. "C:\Autoexec.bat"
'Outputs     :  Returns True if the file exists

Function FileExists(sFilePathName As String) As Boolean
    On Error GoTo ExitFunction
    If Len(sFilePathName) Then
        If (GetAttr(sFilePathName) And vbDirectory) < 1 Then
            'File Exists
            FileExists = True
        End If
    End If
ExitFunction:
End Function

[mirek443_za]

Máš pravdu som nepripol macro pre modul výberu zložky ak neexistuje cesta f:\

Kód: Vybrat vše

Public NovaCesta As String

Sub FolderSelection()
    Dim MyPath As String
    MyPath = SelectFolder("Výber zlozky", "")
    If Len(MyPath) Then
        NovaCesta = MyPath
    Else
        MsgBox "Cancel was pressed"
    End If
End Sub

a ešte treba declarovať premennú hladany_subor....ja ju declarujem zas v inom module tak som to trosku pozabudol..