[ACCESS/VB] Mettre un cartouche

Pourquoi tu n'ajoute pas simplement un champ de texte ?

Par exemple quand une personne créer un fichier, elle insère son nom que tu met dans ta bdd et tu n'as plus qu'à le récupérer.
Et la date tu l'insère en auto dans ta base.

Et voici donc la solution, ça peut toujours servir...

Rappel: Il s'agit de créer un fichier excel avec les résultats d'une requete qui comporte en haut un cartouche avec le nom, la date...

Private Sub Extraire_Click()
On Error GoTo Err_Extraire_Click

Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t0 As Long, t1 As Long
Dim rec As Recordset
Dim sql As String

MsgBox ("début de la création")


sql = "SELECT table.* FROM table Where table!number <> 0 "

If Not Me.chk_champ1 Then
sql = sql & "And table.champ1 like '*" & Me.cmb_champ1 & "*' "
End If
If Not Me.chk_champ2 Then
sql = sql & "And table.champ2 like '*" & Me.cmb_champ2 & "*' "
End If
If Not Me.chk_champ3 Then
sql = sql & "And table.champ3 like '*" & Me.cmb_champ3 & "*' "
End If

sql = sql & ";"


'on créé la requête rec
Set rec = CurrentDb.OpenRecordset(sql, dbOpenSnapshot)

'on exporte la requete rec vers un nouveau fichier Excel

'Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add

'Ajouter une feuille de calcul
Set xlSheet = xlBook.Worksheets.Add
xlSheet.Name = "Tutoriel2"

' le titre
xlSheet.Cells(1, 4) = "EXTRACTION DEPUIS LA BASE"
For J = 1 To 7
With xlSheet.Cells(1, J)
.Interior.ColorIndex = 8 (on met du bleu clair)
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J

' écriture dans la cellule de ligne 2 et de colonne 1
xlSheet.Cells(2, 1) = "Nom :"
xlSheet.Cells(2, 2) = Me.txt_Nom.Value
' écriture dans la cellule de ligne 3 et de colonne 1
xlSheet.Cells(3, 1) = "Date :"
xlSheet.Cells(3, 2) = Date
' écriture dans la cellule de ligne 4 et de colonne 1
xlSheet.Cells(4, 1) = "Commentaire :"
xlSheet.Cells(4, 2) = Me.txt_commentaire.Value

' Nous appliquons des enrichissements de format aux cellules de titre
For I = 2 To 4
For J = 1 To 2
With xlSheet.Cells(I, J)
.Interior.ColorIndex = 6 (on met du jaune)
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J
Next I


' les entetes
' .Fields(Index).Name renvoie le nom du champ
For J = 0 To rec.Fields.Count - 1
xlSheet.Cells(5, J + 1) = rec.Fields(J).Name
' Nous appliquons des enrichissements de format aux cellules d'en tete
With xlSheet.Cells(5, J + 1)
.Interior.ColorIndex = 15 (on met du gris)
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeBottom).ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
End With
Next J

' recopie des données à partir de la ligne 3
I = 6
Do While Not rec.EOF
For J = 0 To rec.Fields.Count - 1
' .Fields(Index).Type renvoie le type du champ
' si c'est un Texte (dbText) nous insérons "'" pour
' qu'il soit reconnu par Excel comme du Texte
If rec.Fields(J).Type = dbText Then
xlSheet.Cells(I, J + 1) = "'" & rec.Fields(J)
Else
xlSheet.Cells(I, J + 1) = rec.Fields(J)
End If
Next J
I = I + 1
rec.MoveNext
Loop


'enregistrement du fichier (on ouvre une boite windows "enregistrer sous" et il faut taper un nom du type .xls)
Do
fName = xlApp.GetSaveAsFilename
Loop Until fName <> False
xlBook.SaveAs Filename:=fName

MsgBox ("Le fichier a été créé avec succès!")

' code de fermeture
xlApp.Quit
rec.Close

'libération des objets
Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing


Exit_Extraire_Click:
Exit Sub

Err_Extraire_Click:
MsgBox Err.Description
DoCmd.DeleteObject acQuery, "NomRequete"
Resume Exit_Extraire_Click

End Sub


Et voilà! Merci beaucoup à MrSlave et à lermite222 (pour la fonction GetSaveAsFilename)