Votre avis sur un code VBA envoi automatique
Bonjour amis VBA
Un collègue m'a fourni un code VBA envoi mail que j’ai adapté à mes besoins. J’ai créé un fichier Excel qui a l’option faire suivre par email.
Il fonctionne bien, mais je me demande quand même s’il ne comporterait pas d’erreurs ou s’il n’y aurait lieu de l’améliorer.
En postant ce code, il pourrait être aussi utile à d'autres!
Je suis en excel 2003, et Lotus Note
Merci de me donner votre avis.
Public CalendrierOK As Boolean
Public CommOK As Boolean
Public CatOK As Boolean
Public HrsMinsOK As Boolean
Sub Bouton50_QuandClick()
SendMail
End Sub
Sub SendMail()
Dim Maildb As Object 'The mail database
Dim session As Object 'The notes session
Dim MailDoc As Object 'The mail document itself
Dim attachME As Object
Dim EmbedObj As Object
Dim Recipient As String
Dim Subject As String
Dim lefichier As String
Dim filepath As String
Dim WasOpen As Integer
Dim NouveauWorkbook As String
Dim WorkbookActuel As String
Dim nomsanscarspec As String
Dim A As String
Dim B As String
Dim i As Integer
Dim dd As DropDown
Dim objetdemande As String
Dim extension As String
For Each dd In ActiveSheet.DropDowns
objetdemande = dd.List(dd.ListIndex)
Next
If Range("B09") = "" Then
MsgBox ("Vous devez inscrire votre installation avant d'envoyer votre demande")
Exit Sub
End If
If Range("B11") = "" Then
MsgBox ("Vous devez inscrire le type de comblement avant d'envoyer votre demande")
Exit Sub
End If
If Range("G09") = "" Then
MsgBox ("Vous devez inscrire un requérant avant d'envoyer votre demande")
Exit Sub
End If
If Range("G11") = "" Then
MsgBox ("Vous devez inscrire un numéro de téléphone du demandeur avant d'envoyer votre demande")
Exit Sub
End If
If Range("B32") = "" Then
MsgBox ("Vous devez préciser à qui l'employé doit se rapporter avant d'envoyer votre demande")
Exit Sub
End If
Set session = CreateObject("Notes.NOTESSESSION")
Set Maildb = session.GETDATABASE("", "")
On Error GoTo ErrorHandler
Maildb.OPENMAIL
On Error GoTo 0
Rows("1:36").Select
Application.CutCopyMode = False
Selection.Copy
WorkbookActuel = ActiveWorkbook.Name
Workbooks.Add
NouveauWorkbook = ActiveWorkbook.Name
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.Zoom = 100
Application.CutCopyMode = False
With ActiveWorkbook
.PrecisionAsDisplayed = False
.Date1904 = True
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Set objfolders = CreateObject("WScript.Shell").SpecialFolders
filepath = objfolders("mydocuments")
If Right(filepath, 1) = "\" Then filepath = filepath & "Besoin_ponctuel\" Else filepath = filepath & "\Besoin_ponctuel\"
For i = 1 To Len(Range("B09").Value)
B = Mid(Range("B09").Value, i, 1)
If B Like "[A-Za-z]" Then
A = A & B
End If
Next i
For Each dd In ActiveSheet.DropDowns
dd.Visible = False
Next
Range("B2").Value = "REQUISITION - BESOIN PONCTUEL"
Range("A1:I36").Select
Application.CutCopyMode = False
Selection.Locked = False
Selection.FormulaHidden = False
Rows("37:" & Rows.Count).Select
Selection.EntireRow.Hidden = True
ActiveSheet.Protect Password:="xxxx", Contents:=True, AllowFormattingCells:=True
If Val(Application.Version) < 12 Then
extension = ".xls"
Else
extension = ".xlsx"
End If
ActiveWorkbook.SaveAs (filepath & A & "_" & Range("B11").Value & "_" & Format(Now, "yymmdd") & "_" & Format(Now, "HHnnss") & Right(Format(Timer, "#0.00"), 2) & extension)
' If MsgBox("Voulez-vous imprimer une copie de la demande pour vos dossiers?", vbYesNo) = vbYes Then ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
lefichier = ActiveWorkbook.FullName
lefichiernom = Split(lefichier, "\")(UBound(Split(lefichier, "\")))
ActiveWorkbook.Close
Recipient = Sheets("Formulaire").Range("A38").Value
Subject = "BP " & besoinponctuel & " - " & Range("B09").Value & " - " & Range("B11").Value
MsgBox ("Envoie du courriel par " & Maildb.Title & " sur le serveur " & Maildb.SERVER)
Set MailDoc = Maildb.CreateDocument
Set attachME = MailDoc.CreateRichTextItem("Attachment")
Set EmbedObj = attachME.EmbedObject(1454, "", lefichier, "Attachment")
MailDoc.Form = "Memo"
MailDoc.sendto = Recipient
MailDoc.Subject = Subject
MailDoc.body = "Bonjour, pour traitement, svp. Merci!"
MailDoc.ReturnReceipt = "1"
MailDoc.SaveMessageOnSend = True
'MailDoc.PostedDate = Now()
MailDoc.SEND 0, Recipient
SaveSetting "Mes parametres", "NomDemandeur", "NomDemandeur", Range("G09").Value
SaveSetting "Mes parametres", "TelDemandeur", "TelDemandeur", Range("G11").Value
MessageCourriel.Label1.Caption = "- Votre demande a été envoyée par courriel à l'adresse: " & Recipient
MessageCourriel.Label3.Caption = "- Une copie du formulaire a été enregistrée dans vos documents à l'emplacement: " & filepath & vbLf & "Le nom du fichier est:" & vbLf & lefichiernom
MessageCourriel.Show
CalendrierOK = True
CommOK = True
CatOK = True
HrsMinsOK = True
Range("B09").Value = ""
Range("B11").Value = ""
Range("G09").Value = ""
Range("G11").Value = ""
Range("A16:A25").Value = ""
Range("B16:E25").Value = ""
Range("B27:H30").Value = ""
Range("B32").Value = ""
For Each dd In ActiveSheet.DropDowns
dd.ListIndex = 1
Next
CalendrierOK = False
CommOK = False
CatOK = False
HrsMinsOK = False
Set session = Nothing
Set Maildb = Nothing
Set MailDoc = Nothing
Set attachME = Nothing
Set EmbedObj = Nothing
Exit Sub
ErrorHandler:
MsgBox ("Vous devez être connecté dans votre session Lotus Notes pour utilisé cette fonctionnalité, une fois connecté à Lotus Notes appuyez sur OK et votre demande sera envoyée")
Set Maildb = session.GETDATABASE("", "")
Resume
End Sub
Sub enregistrer()
Dim lefichier As String
Dim filepath As String
Dim WasOpen As Integer
Dim NouveauWorkbook As String
Dim WorkbookActuel As String
Dim nomsanscarspec As String
Dim A As String
Dim B As String
Dim i As Integer
Dim dd As DropDown
Dim objetdemande As String
Dim extension As String
For Each dd In ActiveSheet.DropDowns
objetdemande = dd.List(dd.ListIndex)
Next
If Range("B09") = "" Then
MsgBox ("Vous devez inscrire votre installation avant d'envoyer votre demande")
Exit Sub
End If
If Range("B11") = "" Then
MsgBox ("Vous devez inscrire le type de comblement avant d'envoyer votre demande")
Exit Sub
End If
If Range("G09") = "" Then
MsgBox ("Vous devez inscrire un requérant avant d'envoyer votre demande")
Exit Sub
End If
If Range("G11") = "" Then
MsgBox ("Vous devez inscrire un numéro de téléphone du demandeur avant d'envoyer votre demande")
Exit Sub
End If
If Range("B32") = "" Then
MsgBox ("Vous devez préciser à qui l'employé doit se rapporter avant d'envoyer votre demande")
Exit Sub
End If
Rows("1:36").Select
Application.CutCopyMode = False
Selection.Copy
WorkbookActuel = ActiveWorkbook.Name
Workbooks.Add
NouveauWorkbook = ActiveWorkbook.Name
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.Zoom = 100
Application.CutCopyMode = False
With ActiveWorkbook
.PrecisionAsDisplayed = False
.Date1904 = True
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.PaperSize = xlPaperLetter
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Set objfolders = CreateObject("WScript.Shell").SpecialFolders
filepath = objfolders("mydocuments")
If Right(filepath, 1) = "\" Then filepath = filepath & "Besoin_ponctuel\" Else filepath = filepath & "\Besoin_ponctuel\"
Range("B09").Value = StripAccent(Range("B09").Value)
For i = 1 To Len(Range("B09").Value)
B = Mid(Range("B09").Value, i, 1)
If B Like "[A-Za-z]" Then
A = A & B
End If
Next i
For Each dd In ActiveSheet.DropDowns
dd.Visible = False
Next
Range("B2").Value = "REQUISITION - BESOIN PONCTUEL"
Range("A1:I36").Select
Application.CutCopyMode = False
Selection.Locked = True
Selection.FormulaHidden = False
Rows("37:" & Rows.Count).Select
Selection.EntireRow.Hidden = True
ActiveSheet.Protect Password:="xxxx", Contents:=True, AllowFormattingCells:=True
If Val(Application.Version) < 12 Then
extension = ".xls"
Else
extension = ".xlsx"
End If
ActiveWorkbook.SaveAs (filepath & A & "_" & Range("B09").Value & "_" & Format(Now, "yymmdd") & "_" & Format(Now, "HHnnss") & Right(Format(Timer, "#0.00"), 2) & extension)
lefichier = ActiveWorkbook.FullName
lefichiernom = Split(lefichier, "\")(UBound(Split(lefichier, "\")))
ActiveWorkbook.Close
SaveSetting "Mes parametres", "NomDemandeur", "NomDemandeur", Range("G09").Value
SaveSetting "Mes parametres", "TelDemandeur", "TelDemandeur", Range("G11").Value
MsgBox ("Le fichier a été enregistré à cet emplacement: " & lefichier & vbLf & "Vous devez maintenant l'envoyer par courriel pour qu'il soit traité.")
CalendrierOK = True
CommOK = True
CatOK = True
HrsMinsOK = True
Range("B09").Value = ""
Range("B11").Value = ""
Range("G09").Value = ""
Range("G11").Value = ""
Range("A16:A25").Value = ""
Range("B16:E25").Value = ""
Range("B27:H30").Value = ""
Range("B32").Value = ""
For Each dd In ActiveSheet.DropDowns
dd.ListIndex = 1
Next
CalendrierOK = False
CommOK = False
CatOK = False
HrsMinsOK = False
End Sub
Bonjour
Merci de me donner votre avisEt bien voila...
C'est bien, bien long et...
Penses-tu sérieusement que ce soit faisable sans fichier?
Cordialement
merci pour votre intérêt!
Bonjour amis VBA
petit UP! pour l'évaluation de ce code.
Le fichier a été joint suivant le conseil d'Amadéus.
Merci de me donner votre avis.