[ACCESS/VB] Mettre un cartouche Fermé

Question

Bonjour,

Je suis débutante dans le langage vb et je suis actuellement en stage. Dans ce cadre, je fais 
une petite base de donnée Access et je dois à l'aide d'un bouton faire des extractions de 
certaines données vers Excel. Le problème est que mon tuteur souhaite qu'en haut de la feuille 
Excel créée, il soit mis un cartouche avec par exemple : le nom de la personne qui a créé le fichier, 
la date de création... Comment puis je coder cela? J'ai vraiment besoin d'aide!!!!

Merci beaucoup d'avance!

PS: Je vous joints le début de mon code:

Private Sub Extraire_Click()
On Error GoTo Err_Extraire_Click

    Dim sql As String
    Dim req As DAO.Recordset

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 "NomRequete"
CurrentDb.CreateQueryDef "NomRequete", sql

'on exporte la requete "NomRequete" vers le fichier Excel
DoCmd.OutputTo acOutputQuery, "NomRequete", acFormatXLS, , True

'on libère (=supprimer) la requete "NomRequete"
DoCmd.DeleteObject acQuery, "NomRequete"

Exit_Extraire_Click:
    Exit Sub

Err_Extraire_Click:
    MsgBox Err.Description
    DoCmd.DeleteObject acQuery, "NomRequete"
    Resume Exit_Extraire_Click
    
End Sub


Encore merci d'avance.

MrSlave · Answer

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.

ciracus · Answer

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)

[ACCESS/VB] Mettre un cartouche

2 réponses

Discussions similaires