hurtig VBA på extension

Der er et eksempel til download på nedenstående hjemmeside

http://www.makeiteasy.dk/pages/Download.aspx

den kan jeg ikke se på Thomas' hjemmeside...

Indsæt filnavne i tabel

nå den ja, men jeg ledte efter den kodelinie der kan måle på et extension på et filnavn :-)

jeg er ved at have den nu, men jeg mangler blot at koden på thoam side medtager underbiblioteker.. kan en sætte dette ind i scriptet ?

Public Sub ListFiler(stDir As String)
Dim stName As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

    On Error GoTo err_FindFiler
    Set cn = CurrentProject.Connection
    Set rs = New ADODB.Recordset
    rs.Open "tblFiler", cn, adOpenKeyset, adLockOptimistic
   
    stName = Dir(stDir & "\*.*")
    Do While stName <> ""
        On Error Resume Next
        If (GetAttr(stDir & stName) And vbDirectory) <> vbDirectory Then
            'Er filen allerede åben opstår en fejl 5
            If Err.Number = 5 Then Err.Clear
           
            If stName <> "." Or stName <> ".." Then
                'placer filnavn et eller andet sted
                'her skrives til recordsettet
                rs.AddNew
                rs!Mappenavn = stDir
                rs!Filnavn = stName
                rs.Update
            End If
        End If
        stName = Dir
    Loop
   
exit_FindFiler:
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    Exit Sub
err_FindFiler:
    If Err.Number = 71 Then
        MsgBox AccessError(Err.Number) _
                    & "  Prøv venligst igen.  ", vbCritical + vbOKOnly, _
                    "Fejl ved læsning af drev " & stDir
    End If
    Resume exit_FindFiler
End Sub

Der findes et alternativ til FileSearch som blev fjernet fra og med Office 2007.

Firmaet her har lavet en kommerciel version af classen der kan gøre det http://www.codematic.net/docs/afs/codesummary.pdf

(der findes også nogen der er gratis ved jeg - jeg bruger selv en)

Andre metoder:
http://allenbrowne.com/ser-59.html
http://www.excelforum.com/excel-2007-help/697333-application-filesearch-in-2007-replacement.html
http://www.thecodecage.com/forumz/members-access-database-functions/100678-new-class-module-replacement-office-filesearch-object.html

har lige fundet et ældre script som jeg muligvis kan omskrive, med smid et svar og vi får dette spørgsmål lukket...

Jeg kan godt lige finde den class fil og så muligvis et eksempel på hvordan den bruges.

Gem nedenstående som clsFileSearch.cls og importer i dit projekt


VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsFileSearch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' -----------------------------------------------------------------------------------
' Dette classmodul indeholder funktioner til filsøgning
' Erstatning for Application.FileSearch
' -----------------------------------------------------------------------------------
Option Compare Database
Option Explicit

' Are we debugging - 3=full, 2=some 1=a little, 0=no
#Const SHOWDEBUG = 0

' -------------------------------------------------------------------------
' Object model:
'
' Methods:
'
' Execute - actually run search (returns Boolean which is always true
'          unless deletes were requested which failed). If deletes
'          were requested, the list returned from the actual search
'          has no members.
' NewSearch - clear it
'
' Properties:
'
' Lookin (string) - directory to search from
' Sort (boolean) - whether or not to sort results
' IncludeDirs (boolean) - include directories with results (not just files)
' FoundFiles (collection) - the results
' SearchSubFolders (boolean) - recurse?
' DeleteFiles (boolean) - delete files as search progresses
' DeleteFolders (boolean) - delete folders as search progresses
' -------------------------------------------------------------------------

' The directory to look in. Set using the procedures. CLR, 13/5/99.
Private priLookIn As String

' The directory to copy to. Set using the procedures. CLR, 13/5/99.
Private priCopyTo As String

' Whether or not to sort the results. CLR, 13/5/99.
Public Sort As Boolean

' Whether or not to include directories in the results. CLR, 17/5/99.
Public IncludeDirs As Boolean

' The filename (well, spec) to look for. CLR, 17/5/99.
Public FileName As String

' Whether or not to search through subdirectories. CLR, 17/5/99.
Public SearchSubFolders As Boolean

' The list of results.
Public FoundFiles As New Collection

' Whether or not to delete the files. CLR, 5/7/99.
Public DeleteFiles As Boolean

' Whether or not to delete the directories. CLR, 5/7/99.
Public DeleteFolders As Boolean

' Whether everything was in fact deleted okay.
Private DeletedOkay As Boolean

Property Let LookIn(ToDir As String)
    ' Set the directory to look in. Tidies up
    ' trailing slashes. CLR, 5/7/99.

    ' Giving a base directory with a trailing slash doesn't work.
    ' This poses a little of a problem because you can't pass something
    ' like "C:\" to it. So we just chop the slash. This, however, means
    ' that you can't give it "C:" to mean the current working directory
    ' on drive C - tough. You shouldn't write code like that anyways.
  If Right(ToDir, 1) = "\" Then
    ToDir = Left(ToDir, Len(ToDir) - 1)
    SDebug "Cutting trailing slash on directory name", 2
  End If

  priLookIn = ToDir
 
End Property
Property Get LookIn() As String
    ' Get the directory to look in. CLR, 5/7/99.
  LookIn = priLookIn
 
End Property

Property Let CopyTo(ToDir As String)
    ' Set the directory to copy to. Tidies up
    ' trailing slashes. CLR, 5/7/99.
   
  If Right(ToDir, 1) = "\" Then
    ToDir = Left(ToDir, Len(ToDir) - 1)
    SDebug "Cutting trailing slash on directory name", 2
  End If
   
  priCopyTo = ToDir
 
End Property

Property Get CopyTo() As String
    ' Get the directory to copy to. CLR, 5/7/99.
  CopyTo = priCopyTo
 
End Property

' The routine to display debugging information. 24/5/99.
Private Sub SDebug(DBInfo As String, DebugLevel As Integer)
 
  #If SHOWDEBUG = 1 Then
    If DebugLevel <= 1 Then Debug.Print "(CLRFileSearch) L" & DebugLevel & " -> " & DBInfo
  #ElseIf SHOWDEBUG = 2 Then
    If DebugLevel <= 2 Then Debug.Print "(CLRFileSearch) L" & DebugLevel & " -> " & DBInfo
  #ElseIf SHOWDEBUG = 3 Then
    If DebugLevel <= 3 Then Debug.Print "(CLRFileSearch) L" & DebugLevel & " -> " & DBInfo
  #End If
 
End Sub

' Run when an instance of the class is started - just
' runs the clear procedure. CLR, 14/5/99.
Private Sub Class_Initialize()
 
  SDebug "New class instance", 1
  NewSearch
 
End Sub

' Clear the search. CLR, 17/5/99.
Public Sub NewSearch()
  Dim lngX As Long
 
  LookIn = "c:\"
  Sort = False
  IncludeDirs = False
  SearchSubFolders = True
  SDebug "Cleared search criteria", 1
  DeleteFiles = False
  DeleteFolders = False
  CopyTo = ""
 
  For lngX = 1 To FoundFiles.count
    FoundFiles.Remove (1)
  Next lngX
 
End Sub

' Run when the instance of the class is closed. I'm not
' 100% sure about this part.
Private Sub Class_Terminate()
    ' Kill off our results list.
  Set FoundFiles = Nothing
  SDebug "Class terminated, memory released", 1
 
End Sub

' The main run procedure. CLR, 13/5/99.
Public Function Execute() As Boolean
    ' Start recursing from the top dir.
  SDebug "Executing search", 1
  DeletedOkay = True
  RunDown priLookIn
  Execute = DeletedOkay
 
End Function

' The recursive bit. Stolen from various other programs
' I wrote with similar ends in mind. CLR, 13/5/99.
Private Sub RunDown(BaseDirectory As String)
    ' All of the files which match in the directory
  Dim FilesHere() As String
    ' And the directories
  Dim DirsHere() As String
     
    ' The count of how many files there are
  Dim FileCount As Integer
    ' And the directories
  Dim DirCount As Integer

    ' The string each filename is temporarily stored in
  Dim ThisFile As String
    ' The loop to go through each entry and perform what
    ' is necessary
  Dim AddItem As Integer
    ' The loop to recurse through each directory entry
  Dim RecurseDirs As Integer
   
    ' The flag to say whether any actual changes were made
    ' during the bubblesort
  Dim AnyChanges As Boolean
    ' The sort loop
  Dim BubbleSort As Integer
    ' The temporary swapping variable
  Dim SwapFH As String
    ' Whether or not the file is
    ' a directory
  Dim ItIsDir As Integer
   
    ' If a copy failed then don't bother trying the delete
    ' in case we lose stuff.
  Dim CopyFailed As Boolean
   
  SDebug "Searching: """ & BaseDirectory & """", 2
   
    ' Find the directories in here
  DirCount = 0
  ThisFile = Dir(BaseDirectory & "\*.*", vbDirectory)
  While ThisFile <> ""
    If ThisFile <> ".." And ThisFile <> "." Then
            ' This trap will catch if the file doesn't
            ' exist at all (occasional problem with
            ' NetWare volumes)
      On Error GoTo FileNotThere
            ' Check if it's a directory
      ItIsDir = GetAttr(BaseDirectory & "\" & ThisFile)
      If (ItIsDir And vbDirectory) Then
        SDebug "Adding dir: " & ThisFile, 3
        DirCount = DirCount + 1
        ReDim Preserve DirsHere(1 To DirCount)
        DirsHere(DirCount) = ThisFile
      End If
      GoTo SkipFNT
FileNotThere:
            ' File wouldn't read - in this case it doesn't
            ' really matter because we're just finding the
            ' directories. However, make sure it doesn't
            ' think it's a directory.
      ItIsDir = 0
      SDebug "Skipping (error): """ & BaseDirectory & "\" & ThisFile & """", 1
      On Error GoTo 0
      Resume Next
SkipFNT:
      On Error GoTo 0
    End If
    ThisFile = Dir
  Wend
   
    ' Go ahead and read all of the filenames matching the
    ' given spec into the array. Similar code to above
    ' but there ain't much we can do.
  FileCount = 0
'  ThisFile = Dir(BaseDirectory & "\" & Filename, 32 + 16 + 8 + 4 + 2 + 1)
  ThisFile = Dir(BaseDirectory & "\" & FileName, vbArchive + vbDirectory + vbVolume + vbSystem + vbHidden + vbReadOnly)
  While ThisFile <> ""
        ' Check if it's a directory. Need to force the result of
        ' the GetAttr to a boolean because otherwise it isn't and
        ' the "Not" function gets all confused. Don't ask how
        ' *!&"^£%^! long this took me to work out.
    If IncludeDirs Or Not (CBool(GetAttr(BaseDirectory & "\" & ThisFile) And vbDirectory)) Then
      FileCount = FileCount + 1
      ReDim Preserve FilesHere(1 To FileCount)
      FilesHere(FileCount) = ThisFile
    End If
    ThisFile = Dir
  Wend
   
    ' Sort the names into alphabetical order. Using a bubblesort, which
    ' seems to be fast enough at least for the moment.
  If (FileCount > 1) And Sort Then
    Do
      AnyChanges = False
      For BubbleSort = 1 To FileCount - 1
        If FilesHere(BubbleSort) > FilesHere(BubbleSort + 1) Then
                    ' These two need to be swapped
          SwapFH = FilesHere(BubbleSort)
          FilesHere(BubbleSort) = FilesHere(BubbleSort + 1)
          FilesHere(BubbleSort + 1) = SwapFH
          AnyChanges = True
        End If
      Next BubbleSort
    Loop Until Not AnyChanges
  End If

    ' Create any directories necessary. This bit has to go
    ' before the file-handling section because, if directories need to be
    ' created, they need to be created before we start trying to copy files
    ' into them. Note the big lack of error-handling - the usual reason
    ' for directories not being created is because they're already there.
    ' What really matters is the file copies - if they fail, we have to
    ' be careful.
   
    ' If we're copying stuff then make the directory
  If priCopyTo <> "" Then
    SDebug "Creating dir " & priCopyTo & Mid(BaseDirectory, Len(priLookIn) + 1), 2
    On Error Resume Next
    MkDir priCopyTo & Mid(BaseDirectory, Len(priLookIn) + 1)
    On Error GoTo 0
  End If
   
  For AddItem = 1 To FileCount
        ' Presume pleasantly that the copy (if one happens) worked
    CopyFailed = False
        ' If we're copying the files then do that before the delete
    If priCopyTo <> "" Then
      SDebug "Writing file " & priCopyTo & Mid(BaseDirectory & "\" & FilesHere(AddItem), Len(priLookIn) + 1), 2
      On Error GoTo CopyFailedErr
      FileCopy BaseDirectory & "\" & FilesHere(AddItem), priCopyTo & Mid(BaseDirectory & "\" & FilesHere(AddItem), Len(priLookIn) + 1)
      GoTo SkipCopyFailed
CopyFailedErr:
      SDebug "Failed copy to " & priCopyTo & Mid(BaseDirectory & "\" & FilesHere(AddItem), Len(priLookIn) + 1), 1
      CopyFailed = True
      Resume SkipCopyFailed
SkipCopyFailed:
      On Error GoTo 0
    End If
        ' If we're deleting them all then go ahead
    If DeleteFiles And Not CopyFailed Then
      SDebug "Removing file " & BaseDirectory & "\" & FilesHere(AddItem), 2
      SDebug "Clearing attributes", 3
      On Error GoTo FileNotDeleted
      SetAttr BaseDirectory & "\" & FilesHere(AddItem), 0
      SDebug "Deleting", 3
      Kill BaseDirectory & "\" & FilesHere(AddItem)
      GoTo SkipFileNotDeleted
FileNotDeleted:
      SDebug "Failed delete on " & BaseDirectory & "\" & FilesHere(AddItem), 1
      DeletedOkay = False
      Resume SkipFileNotDeleted
SkipFileNotDeleted:
      On Error GoTo 0
    Else
            ' As we're not wiping the whole thing, just
            ' add the files to the list
      FoundFiles.Add BaseDirectory & "\" & FilesHere(AddItem)
    End If
  Next AddItem
   
    ' Okay, here's the recursive bit. We now have an array full
    ' of the directory names from this particular path and we must
    ' cycle through these.
  If SearchSubFolders Then
    For RecurseDirs = 1 To DirCount
      RunDown BaseDirectory & "\" & DirsHere(RecurseDirs)
    Next RecurseDirs
  End If

    ' If we're deleting stuff then zap the directory. Remember that
    ' some files in it may have failed copies but that's okay -
    ' if they failed the copy then the file hasn't been deleted
    ' so the rmdir won't work anyway.
  If DeleteFolders Then
    SDebug "Deleting directory " & BaseDirectory, 2
    On Error GoTo DirNotDeleted
    RmDir BaseDirectory
    GoTo SkipDirNotDeleted
DirNotDeleted:
    SDebug "Failed remove on " & BaseDirectory, 1
    DeletedOkay = False
    Resume SkipDirNotDeleted
SkipDirNotDeleted:
    On Error GoTo 0
  End If

End Sub

Nedenstående skulle gerne søge i C:\Temp og undermapper og finde alle jpg filer

  Dim objFileSearch As New clsFileSearch
  Dim lngX As Long

  With objFileSearch
    .NewSearch
    .LookIn = "C:\Temp"
    .SearchSubFolders = True
    .FileName = "*.jpg"
    .Sort = True
    .Execute
    If .FoundFiles.count > 0 Then
      For lngX = 1 To .FoundFiles.count
      MsgBox Trim(.FoundFiles(lngX))
      Next lngX
    End If
  End With

hvor importerer jeg det i projektet ?
som en slass modul eller ?

I din VBA editor. Den skulle gerne selv finde ud af at gemme det som en class når du trykker på gem efterfølgende - måske kommer den og spørger efter navnet.

Jeg ved ikke helt hvad der er for et script og det der skulle ligges i class modulet, men efter at have lukket databasen ned og åbnet den igen hang den...
så lukkede jeg denne og startede den op igen, og nu er alt vi VBA kode i hele databasen væk, pånær dette class code..

det er fandme noget L.O.R.T :-((

jeg tror hellere jeg må slette den class igen og så starte det forfra, da jeg ikke ved hvad den gør...

Ja det skal jeg ikke kunne sige hvad der er sket. Jeg bruge den kode i næsten alle mine databaser og der fungerer det helt som det skal.

Har du en mailadresse så har jeg et lille eksempel der kun lige indeholder den class og en form hvor du kan se hvordan den virker.

nto at solar punktum dk