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
| ' -------------------------------------------------------------------------
' Procedure : AddAttachmentsFromFolder
' Purpose : Adds one record to an attachment field for each file in the
' : specified folder.
' Arguments : strFolder - Name of the folder
' : strTable - Name of the table containing the attachment field
' : strField - Name of the attachment field
' : strPattern - Search pattern for the directory. Defaults to
' : all files (*.*)
' : fIncludeSubfolders - Include subfolders in the specified folder
' : Defaults to False
' Comments : This routine adds a new record to the table, then one attachment.
' : It commits the changes and handles all cleanup
' -------------------------------------------------------------------------
Sub AddAttachmentsFromFolder(ByVal strFolder As String, _
ByVal strTable As String, _
ByVal strField As String, _
ByVal strFieldNameFile As String, _
Optional ByVal strPattern As String = "*.*", _
Optional ByVal fIncludeSubfolders As Boolean = False)
Dim strFile As String
Dim lngCount As Long
Dim rstParent As DAO.Recordset2
Dim rstChild As DAO.Recordset
Dim fldAttach As DAO.Field2
Dim objFso As Object ' Scripting.FileSystemObject
Dim objFolder As Object ' Scripting.Folder
Dim objFile As Object ' Scripting.File
Dim objSubFolder As Object ' Scripting.Folder
On Error GoTo ErrorHandler
' Instantiate the FileSystemObject
Set objFso = CreateObject("Scripting.FileSystemObject")
' fix up the folder
If (Right(strFolder, 1) <> "\") Then strFolder = strFolder & "\"
' make sure the folder exists
If (Dir(strFolder, vbDirectory) = "") Then
MsgBox "The specified folder does not exist: " & strFolder, vbExclamation
Exit Sub
End If
' get the folder object
Set objFolder = objFso.GetFolder(strFolder)
' open the table containing the attachment field
Set rstParent = CurrentDb().OpenRecordset(strTable)
' get the first file
strFile = Dir(strFolder & strPattern)
' get each file that meets the pattern
While (Len(strFile) > 0)
' add a record to the parent table
Debug.Print strFolder & strFile
rstParent.AddNew
' get the attachment recordset and FileData field to contain the file
Set rstChild = rstParent.Fields(strField).Value
Set fldAttach = rstChild.Fields("FileData")
' add the attachment to the attachment field
rstChild.AddNew
fldAttach.LoadFromFile strFolder & strFile
rstChild.Fields(strFieldNameFile) = strFile
rstChild.Update
rstParent.Update
' get the next file
strFile = Dir
Wend
' recurse subfolders?
If (fIncludeSubfolders) Then
For Each objSubFolder In objFolder.SubFolders
AddAttachmentsFromFolder objSubFolder.Path, strTable, strField, _
strPattern, fIncludeSubfolders
Next
End If
Cleanup:
rstParent.Close
Set rstParent = Nothing
Exit Sub
ErrorHandler:
Debug.Print "Error " & Err.Number & " - " & Err.Description
MsgBox Err.Description & vbCrLf & _
Err.Number & vbCrLf & _
Err.Source, VbMsgBoxStyle.vbCritical, "AddAttachmentsFromFolder Failed"
GoTo Cleanup
End Sub
Sub TestAddAttachmentsFromFolder()
Const strRootFolder As String = "C:\Documents and Settings\User\My Documents\TEST\"
AddAttachmentsFromFolder strRootFolder, "Table1", "Attachments", "nomfichier", _
"*.doc", True
MsgBox "Done adding files from: " & vbCrLf & strRootFolder, _
vbInformation, "File Import Process Completed"
End Sub |
Ajout automatique du nom d'une piece jointe
Répondre avec citation
Partager