Génération de fichier excel et ajout de pièce jointe !

Soyez le premier à donner votre avis sur cette source.

Snippet vu 9 688 fois - Téléchargée 42 fois

Contenu du snippet

Voici une source que vous ne pourrez pas executer mais qui vous permettra je l'espère de découvrir qq fonctions Excel et Outlook. Ce code, via une requête, génère un fichier excel, l'enregistre sur le disque dur, prépare un mail avec le fichier excel en pièce jointe et efface le fichier excel. Pensez à mettre qq commentaires !

Source / Exemple :


Private Sub Mail_Click()

'On Error GoTo Errman

Dim req As String
Dim LigneExcel, ColExcel As Integer
Dim compt, comptcol, I As Integer
Dim rs, rs2 As ADODB.recordset
Dim fsO As Object
Dim OLObj As Object
Dim Mail As Outlook.MailItem
Dim c As Range

Me.MousePointer = 11

req = Req_Export_Competences((Split(ListCollaborateur.SelectedItem.key, "_")(1)))

Set rs = New ADODB.recordset
    rs.CursorType = adOpenStatic
    rs.CursorLocation = adUseClient
    rs.Open req, Conn1, , , adCmdText
  
    Set Appli_Excel = New excel.Application
    
    'Rendre visible EXCEL
    Appli_Excel.Visible = False
    
    'Créer un nouveau classeur EXCEL initialisé à la ligne 1
    Appli_Excel.Workbooks.Add.Activate
    DoEvents
    LigneExcel = 3
    ColExcel = 1
    
    With Appli_Excel.ActiveWorkbook.Worksheets("Feuil1")
    
    For comptcol = 0 To rs.Fields.count - 2
            'Insere le nom des entetes de colonnes
            .Cells(LigneExcel, ColExcel) = Replace(rs.Fields(comptcol).Name, "LIB_", "")
            ColExcel = ColExcel + 1
            rs.MoveNext
    Next comptcol
    
    req = "select cd_niveau, lib_niveau from niveau_competence"
    
    Set rs2 = New ADODB.recordset
    rs2.CursorType = adOpenStatic
    rs2.CursorLocation = adUseClient
    rs2.Open req, Conn1, , , adCmdText
    
    'On alimente les libellés de niveau de compétence
    For I = 1 To rs2.RecordCount
        .Cells(LigneExcel, ColExcel) = rs2.Fields("lib_niveau")
        ColExcel = ColExcel + 1
        rs2.MoveNext
    Next I
    
    ColExcel = 1
    LigneExcel = LigneExcel + 1
    
    'On charge les compétences
    rs.MoveFirst
    For compt = 0 To rs.RecordCount - 1
        'On boucle sur les colonnes
        For comptcol = 0 To rs.Fields.count - 1
            
            If comptcol = rs.Fields.count - 1 And Not IsNull(rs.Fields(comptcol)) Then
                'On met une croix ds colonne Formé
                If rs.Fields(rs.Fields.count - 1) = 1 Then
                    .Cells(LigneExcel, rs.Fields.count - 1 + 1) = "X"
                'On met une croix ds colonne Opérationnel
                ElseIf rs.Fields(rs.Fields.count - 1) = 2 Then
                    .Cells(LigneExcel, rs.Fields.count - 1 + 2) = "X"
                'On met une croix ds colonne Expert
                Else
                    .Cells(LigneExcel, rs.Fields.count - 1 + 3) = "X"
                End If
                ColExcel = ColExcel + 1
                
                'Surligne la ligne en jaune que le collab a un niveau sur une compétence
                Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A" & LigneExcel & ":" & Chr(65 + rs.Fields.count + 3 - 2) & LigneExcel).Interior.ColorIndex = 6
                Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A" & LigneExcel & ":" & Chr(65 + rs.Fields.count + 3 - 2) & LigneExcel).Font.Bold = True

            Else
                .Cells(LigneExcel, ColExcel) = rs.Fields(comptcol)
                ColExcel = ColExcel + 1
            End If
            
        Next comptcol
        
        ColExcel = 1
        LigneExcel = LigneExcel + 1
        rs.MoveNext
    Next compt

    End With

    'Pour ajuster les colonnes
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A:" & Chr(65 + rs.Fields.count + 3 - 2)).Columns.AutoFit
    'Pour centrer le texte dans les cellules
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A:" & Chr(65 + rs.Fields.count + 3 - 2)).HorizontalAlignment = xlCenter
    
    'Pour mettre l'entête des colonnes en gras
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A1:" & Chr(65 + rs.Fields.count + 3 - 2) & "1").Font.Bold = True
            
    'Pour les lignes de competences
    'On met une bordure
    With Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A3:" & Chr(65 + rs.Fields.count + 3 - 2) & rs.RecordCount + 1 + 2)
        .Borders.Weight = xlThin
        'Taille de la police
        .Font.Size = 8
        'Type de la police
        .Font.Name = "Comic Sans MS"
    End With
        
    'Libelle de Lignes des compétences
    'Police en blanc
    With Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A3:" & Chr(65 + rs.Fields.count + 3 - 2) & "3")
        .Font.ColorIndex = 2
        'Fond en noir
        .Interior.ColorIndex = 1
        'On met en gras
        .Font.Bold = True
        'Taille Police
        .Font.Size = 8
        'Police
        .Font.Name = "Comic Sans MS"
    End With
        
        
    'On fusionne la première ligne
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A1:" & Chr(65 + rs.Fields.count + 3 - 2) & "1").MergeCells = True
    'On fusionne la seconde ligne
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A2:" & Chr(65 + rs.Fields.count + 3 - 2) & "2").MergeCells = True

    
    'Ligne du collaborateur
    With Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Range("A1:" & Chr(65 + rs.Fields.count + 3 - 2) & "1")
        'Police en blanc
        .Font.ColorIndex = 2
        'Fond en noir
        .Interior.ColorIndex = 3
        'On met en gras
        .Font.Bold = True
        'Taille Police
        .Font.Size = 10
        'Police
        .Font.Name = "Comic Sans MS"
    End With
    
    req = "select nom_collab||' '||prenom_collab name, email from collaborateur where cd_collab = " & Split(ListCollaborateur.SelectedItem.key, "_")(1)
      
    Set rs = New ADODB.recordset
    rs.CursorType = adOpenStatic
    rs.CursorLocation = adUseClient
    rs.Open req, Conn1, , , adCmdText
    
    'On renseigne sur la première lignes les infos liées au collab
    Appli_Excel.ActiveWorkbook.Worksheets("Feuil1").Cells(1, 1) = "Compétences de " & UCase(rs.Fields("name")) & " au " & Format(Now, "dd/mm/yyyy")
    
    Set fsO = CreateObject("Scripting.filesystemObject")
        
        'Au cas ou le rep existe deja, on l'efface
        If fsO.FolderExists("C:\Temp_Export") Then
            fsO.deletefolder ("C:\Temp_Export")
            DoEvents
        End If
        
        'On cree le rep temporaire
        fsO.createfolder ("C:\Temp_Export")
        DoEvents
        'On sauvegarde le classeur Excel
        Appli_Excel.ActiveWorkbook.SaveAs ("C:\Temp_Export\Competences de " & rs.Fields("name"))
        DoEvents
        
        Set OLObj = CreateObject("Outlook.Application")
        'Set OLObj = New Outlook.Application
        Set Mail = OLObj.CreateItem(olMailItem)
            
            'On prépare l'envoi de Mail
            With Mail
                .To = "pim@pim.com"
                .Subject = "Compétences"
                .Body = "test"
                .Attachments.Add ("C:\Temp_Export\Competences de " & rs.Fields("name") & ".xls")
                .display
            End With
        
        Appli_Excel.ActiveWorkbook.Close SaveChanges:=False
        DoEvents
        Set Appli_Excel = Nothing
        DoEvents
        'On efface le repertoire temporaire
        fsO.deletefolder ("C:\Temp_Export")
        DoEvents
    Set fsO = Nothing
    
    Set Appli_Excel = Nothing

    Me.MousePointer = 1

Exit Sub

'Errman:
'   Set Appli_Excel = Nothing
'Appli_Excel.ActiveWorkbook.Close SaveChanges:=False
'DoEvents
'Set Appli_Excel = Nothing
'DoEvents
''On efface le repertoire temporaire
'fsO.deletefolder ("C:\Temp_Export")
'DoEvents
'Set fsO = Nothing
'
'Set Appli_Excel = Nothing

End Sub

A voir également

Ajouter un commentaire

Commentaires

cs_dchrist
Messages postés
39
Date d'inscription
vendredi 21 mars 2003
Statut
Membre
Dernière intervention
21 mai 2015
-
Code très clair avec un nombre d'éléments suffisant pour faire mon fichier XLS. J'y ai trouvé deux ou trois renseignements qui me bloquaient pour finir mon développement.
EPS32HAY
Messages postés
100
Date d'inscription
vendredi 20 décembre 2002
Statut
Membre
Dernière intervention
1 février 2009
-
Ton code est super intéressant, étant débutant en VBA.

Je vais essayer de l'utiliser au mieux.


Merci beaucoup
metalchurch
Messages postés
3
Date d'inscription
vendredi 9 avril 2004
Statut
Membre
Dernière intervention
19 avril 2004
-
Vraiment bien ton code, j'y ai pris deux ou trois renseignements tres interessant. J'ai une petite question pour toi, est ce que tu sais si sous vb il est possible de renommer le nom des colonnes(A,B,...) et si oui comment, je n'ai pas trouvé de fonction pour faire cela et étant débutant, je ne sais meme pas si cela existe!
Merci d'avance
KC62
Messages postés
229
Date d'inscription
mardi 3 juin 2003
Statut
Membre
Dernière intervention
20 juin 2007
-
Merci ca m'a aider. Avant je savais gerer un fichier Excel que si il était déja créer. now ya mm plus besoin !
Merci a toi pimousse75, ton code aiderais tous ce qui prenne le temps de le lire...


KC62
cs_tiboos
Messages postés
4
Date d'inscription
mercredi 28 mai 2003
Statut
Membre
Dernière intervention
18 juin 2003
-
tres interessant je vais m en servir ! :)

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.