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

Commenter

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

S'inscrire maintenant

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.

Du même auteur (cs_pimousse75)