Bonjour,
j'avais mis au point,pour un club de basket, avec excel 2003 sous xp et outlook une macro pour l'envoi de mail avec fichier joint (horaires des matchs)
le club a changé d'ordi et fonctionne avec win 7. la macro le fonctionne plus, out look semble avoir été remplacé par windows live mail
comment modifier ma macro (les touches d'envoi ont changé)
Option Explicit
Dim Adresse As String
Dim Objet As String
Dim repert As String
Dim Corps As String
Dim compt2 As Integer
Dim lclub As Integer
Dim PJ As String
Dim TouchesPJ(5) As String, TouchesEnvoi(5) As String
Sub EnvoiEmail_clubs()
repert = VBAProject.ThisWorkbook.Path
Dim HyperLien As String
Dim i As Integer
Dim Client As Integer
Windows("horclubs.xls").Activate
Columns("A:F").Select
Selection.ColumnWidth = 25
Windows("horclubs.xls").Activate
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With 'feuille hor
Windows("MBCa.XLS").Activate
Sheets("HOR").Select
'clubs
lclub = 21
deb:
Windows("MBCa.XLS").Activate
Sheets("HOR").Select
Adresse = ""
PJ = ""
Adresse = Range("l" & lclub).Value
If Adresse <> "" And Adresse <> "0" Then
Objet = "Horaires weekend du " & Range("e6").Value
Corps = "Veuillez trouver en pièce jointe les horaires des matchs de nos équipes"
PJ = repert & "\horclubs.xls"
HyperLien = "mailto:" & Adresse & "?"
HyperLien = HyperLien & "Subject=" & Objet & " (à " & Time() & ")"
HyperLien = HyperLien & "&Body=" & Corps
ActiveWorkbook.FollowHyperlink HyperLien
Attendre 5
OutLookExpress
If PJ <> "" Then
For i = 1 To TouchesPJ(0)
SendKeys TouchesPJ(i)
Attendre 5
Next i
SendKeys PJ, True
Attendre 1
SendKeys "{ENTER}", True
Attendre 5
End If
For i = 1 To TouchesEnvoi(0)
SendKeys TouchesEnvoi(i), True
Next i
End If
Attendre 5
lclub = lclub + 1
If lclub < 50 Then GoTo deb
'impression liste clubs messages
Windows("MBCa.XLS").Activate
Range("E6").Select
Selection.Copy
Range("K20").Select
ActiveSheet.Paste
Columns("K:K").ColumnWidth = 15.83
Columns("l:l").ColumnWidth = 35
Range("K20:l50").Select
Application.CutCopyMode = False
Selection.PrintOut Copies:=1, Collate:=True
End Sub
Sub Attendre(Secondes As Integer)
Dim Début As Long, Fin As Long, Chrono As Long
Début = Timer
Fin = Début + Secondes
Do Until Timer >= Fin
DoEvents
Loop
End Sub
Sub OutLookExpress()
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "p" ' appel du sous-menu pièce par la touche p
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%s" ' Envoi du message avec Alt-s
End Sub
merci de vos réponses
Moge
j'avais mis au point,pour un club de basket, avec excel 2003 sous xp et outlook une macro pour l'envoi de mail avec fichier joint (horaires des matchs)
le club a changé d'ordi et fonctionne avec win 7. la macro le fonctionne plus, out look semble avoir été remplacé par windows live mail
comment modifier ma macro (les touches d'envoi ont changé)
Option Explicit
Dim Adresse As String
Dim Objet As String
Dim repert As String
Dim Corps As String
Dim compt2 As Integer
Dim lclub As Integer
Dim PJ As String
Dim TouchesPJ(5) As String, TouchesEnvoi(5) As String
Sub EnvoiEmail_clubs()
repert = VBAProject.ThisWorkbook.Path
Dim HyperLien As String
Dim i As Integer
Dim Client As Integer
Windows("horclubs.xls").Activate
Columns("A:F").Select
Selection.ColumnWidth = 25
Windows("horclubs.xls").Activate
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.Orientation = xlPortrait
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With 'feuille hor
Windows("MBCa.XLS").Activate
Sheets("HOR").Select
'clubs
lclub = 21
deb:
Windows("MBCa.XLS").Activate
Sheets("HOR").Select
Adresse = ""
PJ = ""
Adresse = Range("l" & lclub).Value
If Adresse <> "" And Adresse <> "0" Then
Objet = "Horaires weekend du " & Range("e6").Value
Corps = "Veuillez trouver en pièce jointe les horaires des matchs de nos équipes"
PJ = repert & "\horclubs.xls"
HyperLien = "mailto:" & Adresse & "?"
HyperLien = HyperLien & "Subject=" & Objet & " (à " & Time() & ")"
HyperLien = HyperLien & "&Body=" & Corps
ActiveWorkbook.FollowHyperlink HyperLien
Attendre 5
OutLookExpress
If PJ <> "" Then
For i = 1 To TouchesPJ(0)
SendKeys TouchesPJ(i)
Attendre 5
Next i
SendKeys PJ, True
Attendre 1
SendKeys "{ENTER}", True
Attendre 5
End If
For i = 1 To TouchesEnvoi(0)
SendKeys TouchesEnvoi(i), True
Next i
End If
Attendre 5
lclub = lclub + 1
If lclub < 50 Then GoTo deb
'impression liste clubs messages
Windows("MBCa.XLS").Activate
Range("E6").Select
Selection.Copy
Range("K20").Select
ActiveSheet.Paste
Columns("K:K").ColumnWidth = 15.83
Columns("l:l").ColumnWidth = 35
Range("K20:l50").Select
Application.CutCopyMode = False
Selection.PrintOut Copies:=1, Collate:=True
End Sub
Sub Attendre(Secondes As Integer)
Dim Début As Long, Fin As Long, Chrono As Long
Début = Timer
Fin = Début + Secondes
Do Until Timer >= Fin
DoEvents
Loop
End Sub
Sub OutLookExpress()
TouchesPJ(0) = 2 ' Nombre de touches nécessaires
TouchesPJ(1) = "%i" ' Appel du menu Insertion par la touche Alt-i
TouchesPJ(2) = "p" ' appel du sous-menu pièce par la touche p
' Pour l'envoi du mail
TouchesEnvoi(0) = 1 ' Nombre de touches nécessaires
TouchesEnvoi(1) = "%s" ' Envoi du message avec Alt-s
End Sub
merci de vos réponses
Moge
Dernière édition: