probleem 2003 / 2010 compabiliteit

[cadtools@gmail.com]

Ik heb ooit een Excel gemaakt of verbasteld van een ander lid die scripts kom maken. Was wel handig. Nu is het probleem dat er een oude code in zit, Application.FileSearch, die niet meer ondersteund wordt. Kan iemand mij hierbij helpen. Ik zou niet weten hoe je dit moet herschrijven.
Muchias gracias

[winnes]

Een (zeer snelle) scan door de code doet me denken dat je wat hebt aan de Dir() functie

[sschevers]

Hans,

Check bijgaande link
http://www.mrexcel.com/forum/excel-questions/268046-application-filesearch-gone-excel-2007-alternatives.html

Zie net dat die link alleen maar dode links oplevert. Ga even verder voor je kijken

edit: Zie bijgande link
http://www.vbaexpress.com/forum/archive/index.php/t-35129.html

Hier staat hoe je het kan doen met het FSO object.

Code Selecteer Uitklappen


Dim FSO As Object

Set FSO = CreateObject("Scripting.FileSystemobject")
Call ProcessFolder(FSO, "C:\test", LookingFor, ThisBook)

Set FSO = Nothing
End Sub

Private Function ProcessFolder( _
ByRef FSO As Object, _
ByVal Foldername As String, _
ByVal LookingFor As String, _
ByRef ThisBook As Workbook)
Dim fldr As Object
Dim subFldr As Object
Dim file As Object
Dim cell As Range
Dim FirstAddress As String
Dim i As Long

Set fldr = FSO.GetFolder(Foldername)
For Each subFldr In fldr.SubFolders

Call ProcessFolder(FSO, subFldr.Path, LookingFor, ThisBook)
Next subFldr

For Each file In fldr.Files

Application.Workbooks.Open file.Path

'search all the sheets in the current book
For i = 1 To Sheets.Count

With Sheets(i).Range("A1:D500")

Set cell = .Find(LookingFor, LookIn:=xlValues, searchorder:=xlByRows, _
LookAt:=xlPart, MatchCase:=False)
If cell Is Nothing Then '<< there's nothing on this sheet

GoTo Finish2
Else

FirstAddress = cell.Address '<< (bookmark)

Do

'add this item to the search results
ThisBook.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0) = ActiveWorkbook.Name
ThisBook.Sheets(1).Range("B65536").End(xlUp).Offset(1, 0) = Sheets(i).Name
ThisBook.Sheets(1).Range("C65536").End(xlUp).Offset(1, 0) = cell.Address
ThisBook.Sheets(1).Range("D65536").End(xlUp).Offset(1, 0) = "(" & cell.Value & ")"

'look for any others
Set cell = .FindNext(cell)
Loop Until cell Is Nothing Or cell.Address = FirstAddress
End If
End With
Finish2:
Next i

ActiveWorkbook.Close savechanges:=False

'search finished in current book, search the next book
Next file

Set file = Nothing
Set subFldr = Nothing
Set fldr = Nothing
End Function


Overigens kun je met het FSO object ook makkelijk files schrijven en benaderen, Folders aanmaken enz..
Bij extra--> verwijzingen --> een verwijzigen toevoegen naar Microsoft Scripting Runtime

Hoef je niet met late binding te werken zoals in bovenstaande voorbeeld

groeten stephan

[sschevers]

Hans,

Misschien moet je hier ook eens naar kijken
http://adndevblog.typepad.com/autocad/2012/04/batch-purging-of-drawing-files-using-scriptpro-20.html

Hiermee kun je aan batch scripts uit voeren op je tekeningen. Scheelt weer in eigen ontwikkelingen voor het maken van bach scripting files

groeten

stephan

[cadtools@gmail.com]

Super! bedankt!