Re : Email piece jointe
la je suis perdu ça marche avec .display mais je n'ai pas le champ destinataire de rempli. voila l'ensemble du code
Option Explicit
Dim lig As Integer, cel As Range, tot
Private Sub CmbRech_Change()
With Feuil6.Range("a2:a65536")
Set cel = .Find(Me.CmbRech, , xlValues, xlWhole)
If Not cel Is Nothing Then
Me.TextBox2 = cel.Offset(0, 0) 'Nom
Me.TextBox1 = Format(cel.Offset(0, 5), "dd.mm.yyyy") 'Date de paiement
Me.TextBox3 = cel.Offset(0, 1) 'Adresse mail
Me.ComboBox1 = cel.Offset(0, 3) 'N° de parking
Me.ComboBox2 = cel.Offset(0, 4) 'Mode de paiement
Me.TextBox4 = Replace(Me.TextBox4, ",", ".") 'Montant HT
Me.TextBox4 = Format(cel.Offset(0, 6), "0.00")
Feuil5.Range("i14") = cel.Offset(0, 6)
Feuil5.Range("i16") = cel.Offset(0, 7)
End If
End With
End Sub
Private Sub CmdModif_Click()
With Feuil6.Range("a2:a65536")
Set cel = .Find(Me.CmbRech, , xlValues, xlWhole)
If Not cel Is Nothing Then
cel.Offset(0, 0) = Me.TextBox2 'Nom
cel.Offset(0, 1) = Me.TextBox3 'Adresse mail
cel.Offset(0, 2) = Feuil5.Range("e3") 'Date d'enregistrement
cel.Offset(0, 3) = Me.ComboBox1 'N° de parking
cel.Offset(0, 4) = Me.ComboBox2 'Mode de paiement
cel.Offset(0, 5) = Me.TextBox1 'Date paiement
cel.Offset(0, 6) = Me.TextBox4 'Montant HT
cel.Offset(0, 6) = Format(Me.TextBox4, "# ##0.00\ €")
cel.Offset(0, 7) = cel.Offset(0, 6) - (Feuil5.Range("i15").Value + 1)
cel.Offset(0, 7) = Format(cel.Offset(0, 7), "# ##0.00\ €")
Feuil5.Range("f4") = Me.TextBox1
Feuil5.Range("c10") = Me.TextBox3
Feuil5.Range("f12") = Me.ComboBox1
Feuil5.Range("f14") = Me.ComboBox2
Feuil5.Range("i14") = cel.Offset(0, 6)
Feuil5.Range("i16") = cel.Offset(0, 7)
End If
End With
End Sub
Private Sub CmdQuitter_Click()
Unload Me
End Sub
Private Sub CmdValider_Click()
Application.ScreenUpdating = False
With Feuil5
.Range("c3") = .Range("c3") + 1
.Range("e3") = Date
.Range("f4") = Me.TextBox1
.Range("c8") = Me.TextBox2
If Me.TextBox3 Like "*@*.*" Then Feuil5.Range("c10") = Me.TextBox3
.Range("f12") = Me.ComboBox2
.Range("f14") = Me.ComboBox1
.Range("i14") = Format(Me.TextBox4, "# ##0.00\ €")
.Range("i16") = Me.TextBox4 - (.Range("i15").Value + 1)
.Range("i16") = Format(.Range("i16"), "# ##0.00\ €")
End With
With Feuil6
lig = .Range("a655236").End(xlUp).Row + 1
.Cells(lig, 1) = Me.TextBox2 'Nom
.Cells(lig, 2) = Me.TextBox3 'Adresse mail
.Cells(lig, 3) = Feuil5.Range("e3") 'Date d'enregistrement
.Cells(lig, 4) = Me.ComboBox1 'N° de parking
.Cells(lig, 5) = Me.ComboBox2 'Mode de paiement
.Cells(lig, 6) = Me.TextBox1 'Date paiement
.Cells(lig, 7) = Format(Me.TextBox4, "# ##0.00\ €") 'Montant HT
.Cells(lig, 8) = Format(Feuil5.Range("i16"), "# ##0.00\ €") 'Montant TTC
.Range("A:H").Columns.AutoFit
End With
Call EnvoisMail
End Sub
Private Sub TextBox1_AfterUpdate()
Me.TextBox1 = Format(Me.TextBox1, "dd.mm.yyyy")
End Sub
Private Sub TextBox3_AfterUpdate()
If Me.TextBox3 Like "*@*.*" Then
Me.TextBox3 = Me.TextBox3
Else
MsgBox "Ce n'est pas une adresse mail valide", , "PARKING"
Me.TextBox3 = ""
End If
End Sub
Private Sub UserForm_Activate()
Me.CmbRech = ""
End Sub
Private Sub UserForm_Initialize()
Dim x As Long, j As Integer
With Feuil6
For j = 2 To .Range("A65536").End(xlUp).Row
Me.CmbRech = .Range("A" & j)
If Me.CmbRech.ListIndex = -1 Then CmbRech.AddItem .Range("A" & j)
Next j
End With
With Me.ComboBox2
.AddItem "Cartes Bancaires"
.AddItem "Chèques"
.AddItem "Espèces"
End With
With Me.ComboBox1
.AddItem "P1"
.AddItem "P2"
.AddItem "P3"
.AddItem "P4"
.AddItem "p5"
.AddItem "p6"
.AddItem "p7"
.AddItem "p8"
End With
End Sub
Private Sub EnvoisMail()
Dim OutlookApp As Object
Dim Mail As Object
Dim curfile$
Dim Signature$
'Cache les événements à l'écran
Application.ScreenUpdating = False
Set OutlookApp = CreateObject("Outlook.Application")
Set Mail = OutlookApp.CreateItem(0)
'Affiche la feuille
Sheets("feuil5").Visible = True
curfile = ThisWorkbook.Path & "\" & Range("C3").Value & "_" & Range("C8").Value & ".Pdf"
Sheets("feuil5").ExportAsFixedFormat Type:=xlTypePDF, Filename:=curfile, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'Masque la feuille
Sheets("feuil5").Visible = False
'Normalement l'emplacement est dans AppData\Microsoft\Signatures\
Signature = Environ("appdata") & "\Microsoft\Signatures\adresse htm.htm"
'Vérification de la présence de la signature dans le répertoire
If Dir(Signature) <> "" Then
Signature = GetBoiler(Signature)
Else
Signature = ""
End If
With Mail
.SentOnBehalfOfName = "boitemail@tructruc.fr"
.To = ActiveSheet.Range("C10").Text
.Subject = "Duplicata De Reçu "
.Body = olFormatHTML
.HTMLBody = "<br><br>" & Signature
.Attachments.Add curfile
'.display 'Permet de visualiser avant l'envoi
.Send
End With
ActiveWorkbook.Save
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
voila le code sur le bouton pour lancer la macro de l'usf
Private Sub CommandButton5_Click()
With RECU
Range("c8, c10, f4, f12, f14,i14, i16").ClearContents
USFRECU.Show
USFRECU.Left = USFRECU.Width * 2
Cancel = True
End With
End Sub
