Bonjour à tous
J'ai crée plusieurs programmes pour mon taf grace à votre aide precieuse sur Excel 2003
Or quand je veux le mettre sur un poste avec excel 2007 soit le programme bug soit il y a un pb avec les macros
J'ai changé l'extension du fichier de xls en xlsm et fait pareil dans la programmation mais toujours pareil
Pouvez vous m'aider svp
Merci d'avance
Ci joint le programme defectueux
J'ai crée plusieurs programmes pour mon taf grace à votre aide precieuse sur Excel 2003
Or quand je veux le mettre sur un poste avec excel 2007 soit le programme bug soit il y a un pb avec les macros
J'ai changé l'extension du fichier de xls en xlsm et fait pareil dans la programmation mais toujours pareil
Pouvez vous m'aider svp
Merci d'avance
Ci joint le programme defectueux
Code:
Option Explicit
Const EMBED_ATTACHMENT As Long = 1454
'Chemin d'enregistrement du fichier temporaire'
Const stPath As String = "C:\Documents and Settings\TECHNICI\Bureau"
'Message dans le mail'
Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf & "Cordialement"
Dim bExist As Boolean
'Rajoute mail en copie
Const vaCopyTo As Variant = ""
Sub Send_Active_Sheet()
Dim stFileName As String
Dim vaRecipients As Variant
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
'Copie la feuille active dans un classeur temporaire'
With ActiveSheet
.Copy
stFileName = .Range("G7").Value
End With
stAttachment = stPath & "\" & stFileName & ".xlsx"
'Sauvegarde et ferme le classeur temporaire
With ActiveWorkbook
.SaveAs stAttachment
.Close
End With
'Création de la liste des destinataires
'Pour envoi a plusieurs personnes,mettre l'ensemble des mails entre parentheses separé par ,'
'Ex : ("toto@mail.com","tata@mail.com".....)'
vaRecipients = VBA.Array("XX@XX.fr")
'Preparation de Lotus Notes
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GetDatabase("", "")
'Ouverture de la fenetre d'identification de Lotus si pas ouvert.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Creation du mail et de la piece jointe.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Ajout de propriétés au mail crée.
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
'.CopyTo = vaCopyTo
.Subject = stFileName
.Body = vaMsg
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipients
End With
'supprime le classeur temporaire.
Kill stAttachment
'Supprime objet de la memoire.
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
MsgBox "Email crée et envoyé avec succès", vbInformation
End Sub
Private Sub EnvoyerMail_Click()
Dim extension As String
Dim chemin As String, nomfichier As String
extension = ".xlsx"
chemin = "C:\Documents and Settings\TECHNICI\Bureau\Fichier\"
nomfichier = ActiveSheet.Range("G7") & extension
bExist = (Dir(chemin & nomfichier) <> "")
If bExist = False Then
Call Send_Active_Sheet
Call Archiver
Else
Call Archiver
End If
End Sub
Code:
Sub Archiver()
Dim extension As String
Dim chemin As String, nomfichier As String
Dim style As Integer, bOuvre As Boolean
Application.ScreenUpdating = False
ThisWorkbook.ActiveSheet.Copy
extension = ".xlsx"
'chemin d'enregistrement du fichier
chemin = "C:\Documents and Settings\TECHNICI\Bureau\Fichier\"
nomfichier = ActiveSheet.Range("G7") & extension
bExist = (Dir(chemin & nomfichier) <> "")
If bExist Then
bOuvre = (MsgBox(PROMPT:="un fichier de ce nom existe déjà, l'ouvrir ?", Buttons:=vbYesNo) = vbYes)
ActiveWorkbook.Close False
If bOuvre Then Workbooks.Open Filename:=chemin & nomfichier
Else
With ActiveWorkbook
.SaveAs Filename:=chemin & nomfichier
.Close
End With
End If
End Sub