1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
| Function GetAllFilesInDir(ByVal strDirPath As String) As Variant
' Parcoure le dossier strDirPath et renvoie un tableau contenant
' Le nom de tout les fichers dans le répertoire
Dim strTempName As String
Dim varFiles() As Variant
Dim lngFileCount As Long
On Error GoTo GetAllFiles_Err
' Vérifie que le caractère de fin est bien un '\'
If Right$(strDirPath, 1) <> "\" Then
strDirPath = strDirPath & "\"
End If
' Vérifie que c'est bien un dossier
If GetAttr(strDirPath) = vbDirectory Then
strTempName = Dir(strDirPath, vbDirectory)
Do Until Len(strTempName) = 0
' Exclu ".", "..".
If (strTempName <> ".") And (strTempName <> "..") Then
' Vérifie que ce n'est pas un sous répertoire
If (GetAttr(strDirPath & strTempName) _
And vbDirectory) <> vbDirectory Then
' Redimensionne le tableau
ReDim Preserve varFiles(lngFileCount)
varFiles(lngFileCount) = strTempName
lngFileCount = lngFileCount + 1
End If
End If
' Utilise Dir pour trouver le fichier suivant
strTempName = Dir()
Loop
' Renvoie le tableau contenant les ficheirs trouvés
GetAllFilesInDir = varFiles
End If
GetAllFiles_End:
Exit Function
GetAllFiles_Err:
GetAllFilesInDir = False
Resume GetAllFiles_End
End Function
Private Sub StartImport_Click()
Dim WordApp As New Word.Application
Dim WordDoc As New Word.Document
Dim Bmk As Word.Bookmark
Dim DocPath As String
Dim varFiles As Variant
Dim IndexFichier As Long
Const NO_FILES_IN_DIR As Long = 9
Const INVALID_DIR As Long = 13
On Error GoTo Test_Err
'Prend la valeur du répertoire ou sont stockés les documents
DocPath = Main.Range("PathSource").Value
'Peu etre a améliorer pour déterminer la premiere ligne ou écrire les valeurs
i = 2
'Récupere la liste des documents du répertoire
varFiles = GetAllFilesInDir(DocPath)
For IndexFichier = 0 To UBound(varFiles)
' Vérifie que l'on a bien affaire a un document Word
If Right(varFiles(IndexFichier), 4) = ".doc" Then
'Ouvre le fichier Word
Set WordDoc = WordApp.Documents.Open(DocPath & varFiles(IndexFichier))
'j es l'index de colonne
j = 0
'Parcoure tout les signets du document
Dim f As FormField
For Each Bmk In WordDoc.Bookmarks
'Met la valeur du Signet dans la cellule
If Bmk.Range.FormFields.Count = 0 Then
j = j + 1
Data.Cells(i, j) = Bmk.Range.Text
Else
For Each f In Bmk.Range.FormFields
j = j + 1
Data.Cells(i, j) = f.Name & " .. : " & f.Result
Next
End If
Next
'Ferme le fichier Word
WordDoc.Close
End If
Next IndexFichier
'Ferme Word
WordApp.Quit
Exit Sub
Test_Err:
Select Case Err.Number
Case NO_FILES_IN_DIR
MsgBox "Le répertoire '" & strDirName _
& "' ne contient aucun fichier."
Case INVALID_DIR
MsgBox "'" & DocPath & "' n'es pas un répertoire valide."
Case 0
Case Else
MsgBox "Error #" & Err.Number & " - " & Err.Description
End Select
WordDoc.Close
WordApp.Quit
End Sub |
Partager