Discussion :

[chernirachid]

Bonjour, je veux exporter des donnés d'une base des employés avec des photos , je sais comment exporter des donnés mais pas avec des photos. merci de votre aide

[chernirachid]

Bonjour, ya quelqu'un qui a une idée. MErci

[Invité]

Bonjour

Il faudrait que tu détailles un peu plus.

Comment fais-tu actuellement ton export ? (Code, manuellement).
Tes phots sont dans ta base où n'y a t'il que le chemin ?

Donc en résumant, plus de détails.

Philippe

[chernirachid]

bonjour, j'ai trouvé un exemple pour exporter et les photos que je veux les exporter sont dans un fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
'Author: Allen Browne
Option Compare Database
Option Explicit
 
'Author and Copyright data will be used in the HTML header.
Private Const mstrcAuthor = ""                  'Insert your name inside the quotes.
Private Const mstrcCopyright = ""               'Whoever is responsible for the web page, in the quotes.
Private Const mstrcCSS = "AccessOutput.css"     'Include the path if the CSS is not in the same folder.
 
Private Const mstrcDateFormat = "General Date"  'How to format Date/Time fields.
Private Const mstrcCurrencyFormat = "Currency"  'How to format Currency fields.
Private Const mstrcYesNoFormat = "Yes/No"       'How to format Yes/No fields.
 
Function Test1()
    'This creates a file named "MyTable.htm" in the current directory, from the records in MyTable.
    Call OutputHTML("MyTable")
End Function
Function Test2()
    'This outputs the same records to the named file, and adds the text to the table.
    Dim strMsg As String
 
    strMsg = OutputHTML("MyTable", "C:\MyFolder\MyFile.htm", "Show this in browser title bar", "Show this at top of page", _
        "This sample was generated from Access using a utility by", "That's all")
    MsgBox strMsg, vbInformation, "Results"
End Function
Function Test3()
    'This does the same, but illustrates how you can add your own HTML for the head and foot paragraphs.
    Debug.Print OutputHTML("MyTable", "C:\MyFolder\MyFile.htm", "My brower's title", "Records from MyTable", _
        "<p>G'day.</p><p>Here's <b>the data</b>.</p>", "<p align=""center"">--Dated " & Now() & "--</p>")
End Function
 
'*****************************
'This is the main function
'*****************************
Public Function OutputHTML(strTableOrQuery As String, _
    Optional ByVal strOutputFile As String, _
    Optional strTitle As String, _
    Optional strHeadingText As String, _
    Optional strHeadParagraph As String, _
    Optional strFootParagraph As String, _
    Optional strDescription As String, _
    Optional strKeywords As String, _
    Optional bShowItNow As Boolean = True) As String
On Error GoTo Err_Handler
 
    Dim db As DAO.Database      'This database
    Dim rs As DAO.Recordset     'Table/query
    Dim fld As DAO.Field        'Each field.
    Dim iFileNum As Integer     'File number for output file.
    Dim lngKt As Long           'Number of records
 
    'Open the source table/query, and start the output file.
    Set db = CurrentDb()
    Set rs = db.OpenRecordset(strTableOrQuery)
    strOutputFile = FixupFilename(strOutputFile, strTableOrQuery, "htm")
    iFileNum = FreeFile
    Open strOutputFile For Output As #iFileNum
    DoCmd.Hourglass True
 
    'Create the HTML Header
    Print #1, "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"" ""http://www.w3.org/TR/html4/loose.dtd"">"
    Print #1, "<html>"
    Print #1, "<head>"
    Print #1, "<meta http-equiv=""Content-Type"" content=""text/html; charset=windows-1252"">"
    Print #1, "<meta http-equiv=""Content-Language"" content=""en-us"">"
    If strTitle <> vbNullString Then
        Print #1, "<title>" & strTitle & "</title>"
    End If
    If strDescription <> vbNullString Then
        Print #1, "<meta name=""description"" content=""" & strDescription & """>"
    End If
    If strKeywords <> vbNullString Then
        Print #1, "<META name=""keywords"" content=""" & strKeywords & """>"
    End If
    Print #1, "<META name=""Author"" content=""" & mstrcAuthor & """>"
    Print #1, "<META name=""copyright"" content=""&copy; " & Year(Date) & " " & mstrcCopyright & """>"
    Print #1, "<base target=""_top"">"
    If mstrcCSS <> vbNullString Then
        Print #1, "<LINK rel=""stylesheet"" type=""text/css"" href=""" & mstrcCSS & """>"
    End If
    Print #1, "</head>"
 
    'Start the body with the heading and header paragraph
    Print #1, "<body>"
    If strHeadingText <> vbNullString Then
        If strHeadingText Like "<*" Then
            Print #1, strHeadingText
        Else
            Print #1, "<h1>" & strHeadingText & "</h1>"
        End If
    End If
    If strHeadParagraph <> vbNullString Then
        If strHeadParagraph Like "<*" Then
            Print #1, strHeadParagraph
        Else
            Print #1, "<p>" & strHeadParagraph & "</p>"
        End If
    End If
 
    'Start a table, with a column for each field.
    Print #1, "<table width=""100%"">"
    Print #1, "<tr>"
    For Each fld In rs.Fields
        If Not IgnoreField(fld) Then
            'If the field has a Caption, use that; otherwise its name.
            If HasProperty(fld, "Caption") Then
                Print #1, "<th>" & fld.Properties("Caption") & "</th>"
            Else
                Print #1, "<th>" & ConvertMixedCase(fld.Name) & "</th>"
            End If
        End If
    Next
    Print #1, "</tr>"
 
    'Loop through the records, adding rows to the HTML table.
    Do While Not rs.EOF
        Print #1, "<tr>"
        For Each fld In rs.Fields
            If Not IgnoreField(fld) Then
                Print #1, FormatCell(fld)
            End If
        Next
        Print #1, "</tr>"
        lngKt = lngKt + 1
        rs.MoveNext
    Loop
 
    'Close the table, add the footer paragraph, and complete the HTML.
    Print #1, "</table>"
    If strFootParagraph <> vbNullString Then
        If strFootParagraph Like "<*" Then
            Print #1, strFootParagraph
        Else
            Print #1, "<p>" & strFootParagraph & "</p>"
        End If
    End If
    Print #1, "</body>"
    Print #1, "</html>"
 
    'Return information about the HTML file.
    OutputHTML = strOutputFile & " written " & Now() & " has " & _
        IIf(lngKt = 1, "1 record", lngKt & " records") & " from " & strTableOrQuery & "."
 
Exit_Handler:
    'Clean up. (These operations must happen even after an error.)
    On Error Resume Next
    Close #iFileNum
    Set fld = Nothing
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    If bShowItNow Then
        FollowHyperlink strOutputFile
    End If
    DoCmd.Hourglass False
    Exit Function
 
Err_Handler:
    MsgBox "Error " & Err.Number & ":  " & Err.Description, vbExclamation, "OutputHTML()"
    Resume Exit_Handler
End Function
 
Private Function ConvertMixedCase(ByVal strIn As String) As String
 
    Dim lngStart As Long        'Loop through string.
    Dim strOut As String        'Output string.
    Dim bWasSpace As Boolean    'Last char. was a space.
    Dim bWasUpper As Boolean    'Last char. was upper case.
 
    strIn = Trim$(strIn)        'Remove leading/trailing spaces.
    bWasUpper = True            'Initialize for no first space.
 
    For lngStart = 1& To Len(strIn)
        Select Case Asc(Mid(strIn, lngStart, 1&))
        Case vbKeyA To vbKeyZ   'Upper case: insert a space.
            If bWasSpace Or bWasUpper Then
                strOut = strOut & Mid(strIn, lngStart, 1&)
            Else
                strOut = strOut & " " & Mid(strIn, lngStart, 1&)
            End If
            bWasSpace = False
            bWasUpper = True
 
        Case 95                 'Underscore: replace with space.
            If Not bWasSpace Then
                strOut = strOut & " "
            End If
            bWasSpace = True
            bWasUpper = False
 
        Case vbKeySpace         'Space: output and set flag.
            If Not bWasSpace Then
                strOut = strOut & " "
            End If
            bWasSpace = True
            bWasUpper = False
 
        Case Else               'Any other char: output.
            strOut = strOut & Mid(strIn, lngStart, 1&)
            bWasSpace = False
            bWasUpper = False
        End Select
    Next
 
    ConvertMixedCase = strOut
End Function
 
Private Function IgnoreField(fld As DAO.Field) As Boolean
    'Return True for OLE fields, binary fields.
    Select Case fld.Type
    Case dbLongBinary, dbBinary, dbVarBinary
        IgnoreField = True
    End Select
End Function
 
Private Function IsRichText(fld As DAO.Field) As Boolean
On Error Resume Next
    'Purpose:   Returns True if the field has its TextFormat property set to 1.
    '           False for all other cases (no such property, set to 0, or error.)
    Const btRich As Byte = 1
    IsRichText = (fld.Properties("TextFormat") = btRich)
End Function
 
Private Function HasProperty(Obj As Object, strPropName As String) As Boolean
    'Purpose: Return true if the object has the property.
    Dim varDummy As Variant
 
    On Error Resume Next
    varDummy = Obj.Properties(strPropName)
    HasProperty = (Err.Number = 0)
End Function
 
Private Function FixupFilename(ByVal strFileName As String, strDefaultName As String, strDefaultExt As String) As String
    'Use the default name if the file name is blank
    If strFileName = vbNullString Then
        strFileName = strDefaultName
    End If
    'If the file name is a path, add the default file name after a slash.
    If FolderExists(strFileName) Then
        If Right$(strFileName, 2&) <> "\" Then
            strFileName = strFileName & "\"
        End If
        strFileName = strFileName & strDefaultName
    Else
        strFileName = strFileName
    End If
    'If the file name lacks an extension, add the default extension.
    If (InStr(InStrRev(strFileName, "\") + 1&, strFileName, ".") = 0&) And (strDefaultExt <> vbNullString) Then
        If strDefaultExt Like ".*" Then
            strFileName = strFileName & strDefaultExt
        Else
            strFileName = strFileName & "." & strDefaultExt
        End If
    End If
 
    FixupFilename = strFileName
End Function
 
Private Function FolderExists(strPath As String) As Boolean
On Error Resume Next
    FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
 
Private Function FormatCell(fld As DAO.Field) As String
    'Purpose:   Return the string for the cell of a table, based on the value of the field.
    Dim rsMVF As DAO.Recordset      'To handle Multi-Valued fields.
    Dim strOut As String            'Output string
    Dim bAlignRight As Boolean      'Flag to right-align this table cell.
    Dim bIsFormatted As Boolean     'Flag if already formatted as HTML.
    Dim lngLen As Long              'Length of string.
    Const strcSep = ", "            'Separator between items in multi-valued fields.
 
    If Not IsNull(fld.Value) Then
        'If this is a Multi-Valued Field, loop the records within it.
        If VarType(fld.Value) = vbObject Then
            Set rsMVF = fld.Value
            Do While Not rsMVF.EOF
                If fld.Type = 101 Then        'dbAttachment
                    strOut = strOut & rsMVF!filename & strcSep
                Else
                    strOut = strOut & rsMVF![Value].Value & strcSep
                End If
                rsMVF.MoveNext
            Loop
            'Remove trailing separator.
            lngLen = Len(strOut) - Len(strcSep)
            If lngLen > 0& Then
                strOut = Left(strOut, lngLen)
            End If
            Set rsMVF = Nothing
 
        Else
            Select Case fld.Type
            Case dbText, dbGUID, dbChar             'Text fields: use the value.
                strOut = fld.Value
            Case dbMemo                             'Memo: handle hyperlinks and rich text.
                If (fld.Attributes And dbHyperlinkField) <> 0& Then
                    strOut = "<a href=""" & Replace(HyperlinkPart(fld.Value, acAddress), " ", "%20") & """>" & _
                        HyperlinkPart(fld.Value, acDisplayedValue) & "</a>"
                    bIsFormatted = True
                Else
                    strOut = fld.Value
                    bIsFormatted = IsRichText(fld)
                End If
            Case dbLong, dbInteger, dbDouble, dbSingle, dbByte, dbDecimal, dbFloat, dbBigInt, dbNumeric 'Numbers
                strOut = fld.Value
                bAlignRight = True
            Case dbCurrency                         'Currency fields.
                strOut = Format$(fld.Value, mstrcCurrencyFormat)
                bAlignRight = True
            Case dbDate, dbTime, dbTimeStamp        'Date/time fields
                strOut = Format$(fld.Value, mstrcDateFormat)
                bAlignRight = True
            Case dbBoolean                          'Yes/No fields.
                strOut = Format$(fld.Value, mstrcYesNoFormat)
            Case Else                               'Other types.
                strOut = fld.Value
            End Select
        End If
    End If
 
    If strOut = vbNullString Then
        'Use a non-breaking space for Null or zero-length string (to keep HTML table right.)
        strOut = "&nbsp;"
    ElseIf Not bIsFormatted Then
        'Unless formatting is embedded, handle special characters.
        strOut = Replace(strOut, "&", "&amp;")
        strOut = Replace(strOut, """", "&quot;")
        strOut = Replace(strOut, "<", "&lt;")
        strOut = Replace(strOut, ">", "&gt;")
        strOut = Replace(strOut, vbCrLf, "<br>")
        strOut = Replace(strOut, "  ", " &nbsp;")
    End If
 
    'Add the cell tag, aligned right for numbers/dates.
    If bAlignRight Then
        strOut = "<td align=""right"">" & strOut & "</td>"
    Else
        strOut = "<td>" & strOut & "</td>"
    End If
 
    FormatCell = strOut
End Function

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Compare Database
Option Explicit
 
Private Sub cmdOutputHtml_Click()
On Error GoTo Err_Handler
 
    Dim strMsg As String
    Dim strFile As String
    Dim strTitle As String
    Dim strHeading As String
    Dim strHeadPara As String
    Dim strFootPara As String
    Dim strDescrip As String
    Dim strKeywords As String
    Dim bOpenFile As Boolean
    If IsNull(Me.TableQuery) Then
        MsgBox "Select the table or query to export.", vbExclamation, "Source required"
    Else
        strFile = Nz(Me.OutputFile, vbNullString)
        strTitle = Nz(Me.BrowserTitle, vbNullString)
        strHeading = Nz(Me.HeadingText, vbNullString)
        strHeadPara = Nz(Me.HeadParagraph, vbNullString)
        strFootPara = Nz(Me.FootParagraph, vbNullString)
        strDescrip = Nz(Me.Descrip, vbNullString)
        strKeywords = Nz(Me.Keywords, vbNullString)
        bOpenFile = Nz(Me.chkShowFile.Value, False)
 
        strMsg = OutputHTML(Me.TableQuery, Me.OutputFile, strTitle, strHeading, _
            strHeadPara, strFootPara, strDescrip, strKeywords, bOpenFile)
 
        If Not bOpenFile Then
            MsgBox strMsg, vbInformation, "Results"
        End If
    End If
 
Exit_Handler:
    Exit Sub
 
Err_Handler:
    MsgBox "Error " & Err.Number & ":  " & Err.Description, vbExclamation, "cmdOutputHtml_Click"
    Resume Exit_Handler
End Sub