ricotumb
Mar 15, 2010, updated at 17:21:12 (UTC)
view9415
view6
0
Goto Top

Gibt es Ersatz für Application.FileSearch in Access 2007

GermansolvedQuestionVB for ApplicationsDevelopment

Application.FileSearch funktioniert in Access 2007 nicht mehr.

Hallo zusammen,

ich habe hier einen VBA Code vorliegen, der unter Office 2003 wunderbar funktioniert hat, jedoch unter Office 2007 nicht mehr funktioniert, weil einige Befehle in 2007 nicht mehr übernommen worden sind. Mein Problem liegt bei Application.FileSearch. Das gibt es leider in 2007 nicht mehr. Ich habe schon einmal gelesen, dass man es mit Dir() oder ObjectFileSearch ersetzen könnte, jedoch habe ich keine Ahnung, wie ich dies auf meinen Vorliegenden Code anwenden soll. Ich poste auch gleich den Code (der ein wenig lang ist). Wichtig ist jedoch nur der Teil, wo fs vorkommt, da fs folgendermaßen deklariert worden ist:

Set fs = Application.FileSearch´

Wäre super wenn jemand einmal drüberschauen und mir eine Lösung vorschlagen könnte. Was ich auch versucht habe, es hat nicht viel gebracht.

Beste Grüße,
Rico


Private Sub Butt_OK_Click()
Dim FileName As String
Dim lPlanung As String
Dim dPlanung As String
Dim lPlanName As String
Dim lPlanungslösung As String
Dim ldatetime As Date
Dim lRec As Integer
Dim lRecCount As Integer

Set fs = Application.FileSearch


dPlannung = "Planungssheets\"  

lPlanName = Get_Planung_Aktuell("Planung")  
lPlannung = "Plannung_" + lPlanName + "_"  
ldatetime = Date + Time

If LB_Planer.ItemsSelected.Count > 0 Then


    If MsgBox("Planungsfiles für " & LB_Planer.ItemsSelected.Count & " markierte Planungslösungen importieren?", vbYesNo) = vbYes Then  
        
        DoCmd.Hourglass (True)
        T1.Caption = " Planungssheets werden importiert. Bitte warten!!!"  
        T1.Visible = True
        Me.Repaint
        lRecCount = LB_Planer.ItemsSelected.Count * 7
        lRec = 0
        For Each varItm In LB_Planer.ItemsSelected
            
            go_on = True
            'Sucht und importiert Planungstemplate  
            delete_ignore = True
            'löscht Termine falls erneut importiert  
            'Schalter für Schweiz und Austria bei getrenntem import auf true setzen  
            If delete_ignore = False Then
                If Len(LB_Planer.Column(4, varItm)) > 0 Then
                    'Wenn schon importiert dann Suche nach Events mit bereits geplanten Räumen  
                    lIs_Raum = Proof_Raumvergeben(lPlanName, LB_Planer.Column(1, varItm))
                    If lIs_Raum Then
                        MsgBox ("Planung für Lösung " + LB_Planer.Column(1, varItm) + " wurde bereits importiert und Räume wurden bereits zugewiesen. Planung kann nicht überschrieben werden!!!")  
                        go_on = False
                    Else
                        If MsgBox("Planung für Lösung " & LB_Planer.Column(1, varItm) & " wurde bereits importiert!" & Chr(13) & Chr(13) & "Überschreiben?", vbYesNo) = vbYes Then  
                            
                            lsql = "DELETE KursePlanungChanges.*, KursePlanung.Planung"  
                            lsql = lsql + " FROM KursePlanung RIGHT JOIN KursePlanungChanges ON KursePlanung.ID = KursePlanungChanges.ID"  
                            lsql = lsql + " WHERE [Planung]='" + Get_Planung_Aktuell("PLanung") + "'"  
                            lstr = lstr + " AND [Planungslösung]='" + LB_Planer.Column(1, varItm) + "'"  
                            DoCmd.RunSQL (lsql)
                            
                            lstr = "DELETE * FROM KursePlanung "  
                            lstr = lstr + " WHERE [Planung]='" + lPlanName + "'"  
                            lstr = lstr + " AND [Planungslösung]='" + LB_Planer.Column(1, varItm) + "'"  
                            DoCmd.RunSQL (lstr)
                        Else
                            go_on = False
                            
                        End If
                    End If
                End If
            End If
            If Not go_on Then
                lRec = lRec + 7
            Else
                
With fs
                    .LookIn = GetAppPath(True) + dPlannung
                    .FileName = lPlannung + LB_Planer.Column(1, varItm) + ".xls"  
                    If .Execute = 0 Then
                        DoCmd.Hourglass False
                        MsgBox ("Planungsfile " & fs.LookIn & "\" & fs.FileName & "  nicht gefunden!" + Chr(13) + "Planung für Lösung " + LB_Planer.Column(1, varItm) + " kann nicht importiert werden!")  
                        DoCmd.Hourglass (True)
                    Else
                        'Datei in eine Temporäre EXCEL Kopieren  
                        Set fso = CreateObject("Scripting.FileSystemObject")  
                        Set f = fso.GetFile(fs.LookIn & "\" & fs.FileName)  
                        zieldatei = GetAppPath(True) + "Plannungtemp.xls"  
                        S = f.copy(zieldatei)
                        lRec = Schreibe_Zeiger(lRec, lRecCount)
                        
                        'Arbeitsblatt der Temporärendatei anpassen  
                        Set oApp = CreateObject("excel.application")  
                        oApp.Visible = False
                        oApp.Workbooks.Open FileName:=zieldatei
                        lPlanName = oApp.Sheets("Einleitung").Cells(1, 2).Value  
                        lPlaner = oApp.Sheets("Einleitung").Cells(4, 2).Value  
                        lPlanungslösung = oApp.Sheets("Einleitung").Cells(3, 2).Value  
                        oApp.Sheets("Termine").UnProtect Password:="lgd"  
                        oApp.Sheets("Termine").RowS("1:1").Select  
                        oApp.Sheets("Termine").RowS("1:1").Delete Shift:=xlUp  
                        oApp.ActiveWorkbook.Close SaveChanges:=True
                        oApp.Quit
                        lRec = Schreibe_Zeiger(lRec, lRecCount)
                        
                        
                        'Daten in Temporäre Accesstabelle lesen  
                        lDatei = "TEMPPlanung"  
                        DoCmd.DeleteObject acTable, lDatei
                        DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
                            lDatei, zieldatei, True, "Termine!A1:J2000"  
                        lRec = Schreibe_Zeiger(lRec, lRecCount)
                            
                            
                        'Schreibt alle Kurse in Kursdatei  
                        lstr = "INSERT INTO KursePlanung ( [Kurs-Nr], Coll, S, Beginn, Ende, Ort, [Ort fix], Referent, Anmerkungen )"  
                        lstr = lstr + "SELECT TEMPPlanung.[Kurs-Nr], TEMPPlanung.Coll, TEMPPlanung.S, TEMPPlanung.Beginn, TEMPPlanung.Ende, TEMPPlanung.Ort, TEMPPlanung.[Ort fix], TEMPPlanung.Referent, TEMPPlanung.Anmerkungen FROM TEMPPlanung"  
                        lstr = lstr + " WHERE [Kurs-Nr] <> ''"  
                        DoCmd.RunSQL (lstr)
                        lRec = Schreibe_Zeiger(lRec, lRecCount)
                        
                        'Schreibt Planung, Planer und Lösung in Kursdatei  
                        lstr = "UPDATE KursePlanung SET"  
                        lstr = lstr + " KursePlanung.Planung = '" + lPlanName + "'"  
                        lstr = lstr + ", KursePlanung.Planer = '" + lPlaner + "'"  
                        lstr = lstr + ", KursePlanung.Planungslösung = '" + lPlanungslösung + "'"  
                        lstr = lstr + " WHERE (((KursePlanung.Planung) = '' Or (KursePlanung.Planung) Is Null))"  
                        DoCmd.RunSQL (lstr)
                        lRec = Schreibe_Zeiger(lRec, lRecCount)
                        
                        'Erstellt Referenteneinträge  
                        Call Erstelle_Referenten(lPlanName, lPlanungslösung)
                        
                        
                        'Setze Import Zeitstempel  
                        Call Schreibe_Import_Loesung(lPlanName, LB_Planer.Column(0, varItm), ldatetime)
                    End If
                
                End With
            End If
            lRec = Schreibe_Zeiger(lRec, lRecCount)
        Next varItm

        LB_Planer.Requery
        T1.Caption = "Import erfolgreich durchgeführt!"  
        DoCmd.Hourglass (False)
    
    End If
Else
    MsgBox ("Keine Planungslösung/Planungsverantwortlichen markiert!!!")  

End If


End Sub

[Edit Biber] Codetags++ [/Biber]
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 138276

Url: https://administrator.de/contentid/138276

Printed on: April 23, 2024 at 15:04 o'clock

6 Comments
Latest comment
Goto Top
Member: Biber
Biber Mar 15, 2010 at 19:30:26 (UTC)
Goto Top
Moin RicoTumb,

Was ich auch versucht habe, es hat nicht viel gebracht.
Was war das denn?
Ich meine, du nutzt die das FileSearch-Object ja nun nicht gerade exzessiv, wenn ich nicht mit den Augen habe.

In Zeile 70 bastelst du dir für das fs-Objekt einen Pfad-String zusammen
.LookIn = GetAppPath(True) + dPlannung
---> den kannst du auch direkt in eine Stringvariable schreiben
In Zeile 71 brätst du dir ebenfalls für das fs-Objekt wiederum einen String zusammen....
.FileName = lPlannung + LB_Planer.Column(1, varItm) + ".xls"
---> den kannst du ebensogut in eine zweite Stringvariable schreiben 8die kosten ja heutzutage kaum noch was)
Statt des "If .Execute = 0 Then" kannst du ebensogut die banale Existenz der gesuchten Datei (= string1 & "\" & string2) prüfen

... und die anderen fs.method-Aufrufe sind doch alle durch die beiden string1/string2-Klamotten ersetzbar.

Wo genau siehst du das Problem? Nostalgie?
Das FileSearch-Gelumpe ist doch als rekursiv aufgemotztes Kompakt-FileSystemObject schon immer nur sinnvoll gewesen in Verzeichnis-Zweigarmen.
Und eher überdimensioniert in "flachen" Strukturen/einzelnen Pfaden.
Also brauchst du das doch eh nicht und hast es noch nie gebraucht.

Grüße
Biber
Member: RicoTumb
RicoTumb Mar 22, 2010 at 09:29:27 (UTC)
Goto Top
Hallo Biber,

vielen herzlichen Dank! War wohl wirklich um einiges einfacher als ich dachte. Application.FileSearch benötige ich hier wirklich nicht...

Beste Grüße,
Rico
Member: RicoTumb
RicoTumb Mar 22, 2010 at 15:49:37 (UTC)
Goto Top
Hallo Biber,

das Problem mit dem obigen Code ist gelöst...Nochmals danke! Jetzt habe ich ein sehr ähnliches Problem und weiß nicht weiter. Bei folgendem Code hätte ich Application.FileSearch genauso ersetzt, wie du mir empfohlen hast. Dies funktioniert diesmal leider nicht, da sonst die For-Schleife nicht funktioniert. Ich denke es hängt mit dem .Execute zusammen. Der Fehler taucht bei .FoundFiles.Count auf, wenn ich die Pfade als String festlege. Könntest Du mir bitte hierzu nochmals eine Empfehlung geben?

Sub Change_Auswertung_Database()
Dim lPfad As String
Dim lDatei As String

Set fs = Application.FileSearch

dAuswertung = "Auswertungen\"
lPfad = GetAppPath(False)
lDatei = "\" + GetAppName() + ".mdb"

With fs
.LookIn = GetAppPath(True) + dAuswertung
.FileName = "*.xls"
.Execute

For i = 1 To .FoundFiles.Count
zieldatei = .FoundFiles(i)
Set oApp = CreateObject("excel.application")
oApp.Visible = True
oApp.Workbooks.Open FileName:=zieldatei
oApp.Run "Change_Pivot_Database", lPfad, lDatei
oApp.ActiveWorkbook.Close SaveChanges:=True
oApp.Quit
Next i
End With

End Sub


Vielen herzlichen Dank!!
Rico
Member: Biber
Biber Mar 22, 2010 at 19:16:19 (UTC)
Goto Top
Moin Rico,

Ich bin momentan auch etwas knapp mit (Forums-) Zeit.

Die Lösung geht jedenfalls in die Richtung: Ersetze das Application.Filesearch-Object durch ein "einfaches" FileSystemObject.
Und einige hundert oder tausend andere Access 2007-Umsteiger hatten/haben das gleiche Problem, eben weil es dieses FileSearch-Object nicht mehr gibt.
Kannst ja schon mal über eine Suchmaschine vortesten -- das Netz ist voll davon.

Andernfalls - etwas Geduld bitte.
Grüße
Biber
Member: bastla
bastla Mar 22, 2010 at 20:33:01 (UTC)
Goto Top
Hallo RicoTumb!

Du könntest es zwischenzeitlich mit diesem (allerdings völlig ungetesteten und nur für eine Ordnerebene ausgelegten) Ansatz versuchen:
Sub Change_Auswertung_Database()

dAuswertung = "Auswertungen\"  
lPfad = GetAppPath(False)
lDatei = "\" + GetAppName() + ".mdb"  

Set fso = CreateObject("Scripting.FileSystemObject")  
For Each zieldatei In fso.GetFolder(GetAppPath(True) & dAuswertung).Files
    If LCase(fso.GetExtensionName(zieldatei.Name)) = "xls" Then  
        Set oApp = CreateObject("excel.application")  
        oApp.Visible = True
        oApp.Workbooks.Open FileName:=zieldatei
        oApp.Run "Change_Pivot_Database", lPfad, lDatei  
        oApp.ActiveWorkbook.Close SaveChanges:=True
        oApp.Quit
    End If
Next
End Sub
Grüße
bastla
Member: RicoTumb
RicoTumb Apr 01, 2010 at 14:26:08 (UTC)
Goto Top
Hallo bastla,

herzlichen Dank!!! Funktioniert wunderbar =)

Grüße,
Rico
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 CommentsAlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment