Cautare fisier

[ccirtina]

Word 2007.
Salutari tuturor.
Codul de mai jos l-am gasit pe google si l-am finisat pentru word.
Acesta cauta intr-un folder o anumita extensie si daca il gaseste deschide fisierul respectiv.
Intrebarea mea este cum fac sa-mi caute si in subfoldere?

Cod: Selectaţi tot

Public Function CautaDeschideFisier()
    'aceste linii de comanda cauta in sPath daca exista fisiere ce trebuie prelucrate
            Dim Ci As Long
            Dim MyDocuments As Documents
            Dim sPath As String
            Dim sFil As String
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
             'opening every time a file is opened and closed.
             
             Set MyDocuments = Application.Documents
             
            Ci = 2 'initial value for Ci, the first file's
             
            sPath = "C:\Users\Costi\Desktop\bpi\" 'here's where to look for
            
            ChDrive sPath 'change drive to whatever has been specified above and by user input - look in here, and only in here!
            ChDir sPath 'same as above, change directory to look here and only here (probably unecessary)
             
            sFil = Dir("*.doc?") 'open all .doc and .docx files in this directory
            If sFil <> "" Then
            Do While sFil <> "" 'loop through the following while the file name is not nothing, i.e. for all files in the directory
                 
                Documents.Open FileName:=sPath & "\" & sFil 'actual command to open each file
              msgbox "Fisier deschis"
                ActiveDocument.Close
                sFil = Dir 'continue to keep looking in the specified directory, as above
                Ci = Ci + 1 
            Loop
             Else
             MsgBox "Nu exista nici un fisier in vederea prelucrarii."
            End If
            Application.ScreenUpdating = True
            Application.DisplayAlerts = True
End Function

[ccirtina]

Am facut urmatoarele doua coduri care ce fac?
Cauta in folderul sPath daca exista fisiere .doc, daca exista atunci cauta in strNumeFisierExistent daca exista acest fisier aici, daca da atunci inchide documentul activ daca nu atunci ruleaza un mesaj sau o alta procedura.
Problema este ca primul fisier il duce la capat iar cand vrea sa fac acelasi lucru cu urmatoarele imi apare acest mesaj de eroare atasat.

Cod: Selectaţi tot

Option Explicit

Dim fso
Dim Ci As Long
Dim strRezDirPath As String
Dim msg As String

Dim strANRezDirPath As String
Dim strLunaRezDirPath As String
Dim strZiRezDirPath As String
Dim strNumeFisierActivPath As String
Dim strNumeFisierExistent As String
Dim path12 As String
Dim path1 As String
Dim path2 As String
Dim path3 As String
Dim path4 As String
Dim path5 As String
Dim path6 As String

Dim DataIns As String
Dim DataInsLuna As String
Dim DataInsZi As String
Dim DataInsNumFisier As String
Dim sFil As String
Dim w As Integer

Const NumeFisier1 As String = "decizie.docx"
Const NumeFisier2 As String = "sentinta.docx"
Const NumeFisier3 As String = "comunicare.docx"
Const NumeFisier4 As String = "citatie.docx"
Const NumeFisier5 As String = "notificare.docx"
Const NumeFisier6 As String = "convocare.docx"

Dim sPath As String
Const strDirPath As String = "C:\Users\Costi\Desktop\Prelucrate\"
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub CautaDeschideFisier()
    'aceste linii de comanda cauta in sPath daca exista fisiere ce trebuiesc prelucrate
            'On Error GoTo eroare
            '''Application.ScreenUpdating = False
            Application.DisplayAlerts = False
             'opening every time a file is opened and closed.
             
            Ci = 0 'initial value for Ci
             
            sPath = "C:\Users\Costi\Desktop\bpi\" 'here's where to look for
            
            ChDrive "C" 'change drive to whatever has been specified above and by user input - look in here, and only in here!
            ChDir sPath 'same as above, change directory to look here and only here (probably unecessary)
             
            sFil = Dir("*.doc?") 'open all .doc and .docx files in this directory
            If sFil <> "" Then
            Do While sFil <> "" 'loop through the following while the file name is not nothing, i.e. for all files in the directory
                 
                Documents.Open FileName:=sPath & sFil 'actual command to open each file
               Call TipDoc
                'MsgBox "gata"
                'ActiveDocument.Close
                sFil = Dir 'continue to keep looking in the specified directory, as above
                Ci = Ci + 1 'when the next paste occurs, put it in column Ci+1, i.e. Row 4:Column 3, then Row 4:Column 4...etc
'                Call TipDoc
            Loop
             Else
             MsgBox "Nu exista nici un fisier in vederea prelucrarii."
            End If
            'Application.ScreenUpdating = True
            Application.DisplayAlerts = True
            
'For w = 1 To Ci
'    Call TipDoc
'Next
'eroare:
 '   Exit Function
End Sub
Public Function TipDoc()

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 DataIns = Format(Date, "yyyy")
 DataInsLuna = Format(Date, "mmmm")
 DataInsZi = Format(Date, "ddmmyyyy")
 DataInsNumFisier = ActiveDocument.Name
'creaza in directorul principal directorul AN iar in acest director creaza un alt director ce are numele lunii curente

 strANRezDirPath = strDirPath & DataIns & "\"
 strLunaRezDirPath = strANRezDirPath & DataInsLuna & "\"
 strZiRezDirPath = strLunaRezDirPath & DataInsZi & "\"
 strNumeFisierActivPath = strZiRezDirPath & DataInsNumFisier & "\"
 strNumeFisierExistent = strNumeFisierActivPath & DataInsNumFisier

''''''''''''''''''''''''''''''''''''''
'cauta folderul care sa aiba numele fisierului activ
If Dir(strNumeFisierActivPath, vbDirectory) <> "" Then
strRezDirPath = strNumeFisierActivPath
MsgBox ("Acest Director " + Chr(13) + strRezDirPath + Chr(13) + " exista.")
Else
'MsgBox ("Acest Director " + strRezDirPath + " nu exista.")

            Application.Run MacroName:="DirExist_create_path"
            Application.Run MacroName:="DirExist_createPath_Luna"
            Application.Run MacroName:="DirExist_createPath_Zi"
            Application.Run MacroName:="dir_name_fisier"

End If
Set fso = CreateObject("Scripting.FileSystemObject")
'Set fso = CreateObject("Word.Application")
path12 = fso.GetAbsolutePathName(strNumeFisierExistent)
path1 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier1)
path2 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier2)
path3 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier3)
path4 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier4)
path5 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier5)
path6 = fso.GetAbsolutePathName(strNumeFisierActivPath & NumeFisier6)


If (fso.FileExists(path12)) Then
'If (fso.FileExists(strNumeFisierExistent)) Then
'msg = MsgBox("Fisierul: " + Chr(13) + DataInsNumFisier & vbCr & " a fost salvat, verifica editarea.")
    'ActiveDocument.Close
 Else
'MsgBox ("Acest Fisier: " + DataInsNumFisier + " nu exista.")
Application.Run MacroName:="Save_name_fisier"
End If
If (fso.FileExists(path1)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier1 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
    Else
'MsgBox ("Acest Fisier: " + NumeFisier1 + " nu exista.")
If (fso.FileExists(path2)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier2 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
    Else
'MsgBox ("Acest Fisier: " + NumeFisier2 + " nu exista.")
If (fso.FileExists(path3)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier3 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
    Else
'MsgBox ("Acest Fisier: " + NumeFisier3 + " nu exista.")
If (fso.FileExists(path4)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier4 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
    Else
'MsgBox ("Acest Fisier: " + NumeFisier4 + " nu exista.")
If (fso.FileExists(path5)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier5 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
    Else
'MsgBox ("Acest Fisier: " + NumeFisier5 + " nu exista.")
If (fso.FileExists(path6)) Then
msg = MsgBox("Fisierul: " + Chr(13) + NumeFisier6 & vbCr & " a fost salvat, verifica editarea.")
    ActiveDocument.Close
Else
'MsgBox ("Acest Fisier: " + NumeFisier6 + " nu exista.")
Sleep 200
Application.Run MacroName:="TipFisier"
'ActiveDocument.Close
    End If
    End If
    End If
    End If
    End If
    End If
End Function

si mai am o problema.
Cum fac sa ruleze mai rapid in special macroul CautaDeschideFisier.
Va multumesc

[ccirtina]

Am gasit in forum (Inserare automata a unui numar intr-un fisier) codul de mai jos care il inlocuieste pe CautaDeschideFisier()
Acesta functioneaza destul de satisfacator fara erori, poate va dati seama ce era gresit in primul cod de imi dadea eroarea aceea si postati sa vedem si noi pentru a nu mai repeta greselile.
Cum pot personaliza, in sensul ca vreau sa-mi deschida doar fisierele cu extensia doc si docx.
Va multumesc.

Cod: Selectaţi tot

Function GetFileList()
Dim fold
Dim file
Dim intCount As Integer
Const folder As String = "C:\Users\Costi\Desktop\bpi2\"
intCount = 0
    Dim FileArray() As Variant 
   
    Set fso = CreateObject("Scripting.fileSystemObject")
    Set fold = fso.getFolder(folder)
     
    For Each file In fold.Files
        ReDim Preserve FileArray(intCount)
       
        FileArray(intCount) = file.Name
        intCount = intCount + 1
        Documents.Open (file)
        Sleep 200
        Call TipDoc
   
    Next
    Set fold = Nothing: Set fso = Nothing
End Function