Dim Liste As String
Dim Derligne As Integer
'Nouveau champ pour l'expéditeur. On récupère le nom du propriétaire, et son adresses Email.
Dim Exped As String
Sheets("Données").Activate
Range([H2], [H65536].End(xlUp)).Select
Derligne = Selection.Rows.Count
Derligne = Derligne + 1
For i = 2 To Derligne
If i = 2 Then ' Attention 1èr remplissage pour éviter le ";" en tête de liste
Liste = Sheets("Données").Cells(i, 8)
Else
Liste = Liste & "; " & Sheets("Données").Cells(i, 8)
End If
Next i
' Ajout d'une chaine pour gérer l'email du proprio
Exped = """&[A1].Value &" < " & [B1].Value &" > "&"
' 1) Ouverture du fichier membres.xls dervant de modèle pour le nouveau classeur docssmcbaammjj.xls
' avec un seul onglet nommé "Documentations" dans le dossier SMCBDOCS du disque D
' Le fichier Version00.xls DOIT être dans le dossier SMCBDOCS/Membres
Dim Rep As String
Dim Fich As String
Dim Lastlig As Integer
Sheets("NOUVEAUX").Activate
Range([A2], [A65536].End(xlUp)).Select
Lastlig = Selection.Rows.Count
Rep = ActiveWorkbook.Path
Fich = ActiveWorkbook.Name
Workbooks.Open (Rep & "\nvxfav.xls")
'
Windows(Fich).Activate
Range("A2:N" & Lastlig).Select
Selection.Copy
Windows("nvxfav.xls").Activate
Range("A2").Select
ActiveSheet.Paste
' 2) Renomage du classeur en "favoris_aammjj_hhmmss.xls"
' avec un seul onglet nommé "Nouveaux-Favoris" dans le dossier du fichier Membres
'On formate repertoire
'repertoire = "D:\smcbdocs"
'On formate le nom du fichier composé de : docssmcb + Date aammjj et Heure hhmmss
nomfich = "favoris_" & Format(Date, "yymmdd") & "_" & Format(Time, "hhmmss") & ".xls"
'On affecte un nom aux l'onglets
ActiveSheet.Name = "Nouveaux_Favoris"
'
' 3) Sauvegarde du nouveau classeur sous son nom attribué en 1)
'
'On Sauvegarde le classeur avec le nom formaté
ActiveWorkbook.SaveAs Filename:=Rep & "\" & nomfich, FileFormat:=xlExcel8
'On ferme le classeur sans sauvegarde
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
'
' 4) Appel de la procédure de préparation de l'Email, et envoi via Thunderbird
'
'
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
' Configuration des valeurs pour l'envoi du mail
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "smtp.orange.fr"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
strbody = "Salut Jeff ;" & vbNewLine & vbNewLine & _
"Voici quelques favoris supplémentaires à intégrer dans la base." & vbNewLine & _
"Sur ce bonne journée et A+."
With iMsg
Set .Configuration = iConf
.To = Liste
.CC = ""
.BCC = ""
' .From = """Jeff"" <jeff@tutu.fr>"
.From = Exped
.Subject = "Nouveaux favoris à intégrer"
.TextBody = strbody
.AddAttachment Rep & "\" & nomfich
.Send
End With
'
' 5) Remise en forme de la feuille NOUVEUAX d'origine
'On sélectionne les cellules remplies et on efface le tout
Sheets("NOUVEAUX").Range("A2:N" & Lastlig).ClearContents
