Accepter ou non ecrasement fichier

[coolman53]

Bonjour a tous,

J'ai crée un programme me permettant d'envoyer une feuille excel par mail via lotus et de l'enregistrer dans un repertoire precis. Cela fonctionne tres bien.

Cependant j'ai un souci si je demande de renvoyer la meme feuille.

Il me met "Un fichier nommé C:/........ existe déja à cet emplacement. Voulez vous le remplacer?
Si je met Oui il ecrase et envoi le mail mais si je fais Non ou Annuler sa bug

Moi ce que je voudrai c'est que si le fichier existe deja, il demande à la place s'il veut ouvrir le fichier deja crée
Si Oui, il ouvre le fichier dans le repertoire
Si Non ferme le classeur sans enregistrer

Je mets en dessous tous mes codes car car j'ai 2 systeme d'enregistrement ( temporaire et fixe ) qui fonctionne l'un a la suite de l'autre. Et le probleme c'est que je vois pas dans lequel je dois modifier

Merci d'avance

Option Explicit

Const EMBED_ATTACHMENT As Long = 1454

Const stPath As String = "C:\XXX"

Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf & "Cordialement"

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

'Copy the active sheet to a new temporarily workbook.
With ActiveSheet
.Copy
stFileName = .Range("G7").Value
End With

stAttachment = stPath & "\" & stFileName & ".xls"

'Save and close the temporarily workbook.
With ActiveWorkbook
.SaveAs stAttachment
.Close
End With

'Create the list of recipients.
vaRecipients = VBA.Array("XX@XX.fr")

'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GetDatabase("", "")

'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL

'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)

'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
.Subject = stFileName
.Body = vaMsg
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipients
End With

'Delete the temporarily workbook.
Kill stAttachment

'Release objects from memory.
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()
Call Archiver
Call Send_Active_Sheet
End Sub



Sub Archiver()

Dim extension As String
Dim chemin As String, nomfichier As String
Dim style As Integer
Application.ScreenUpdating = False
ThisWorkbook.ActiveSheet.Copy
extension = ".xls"
chemin = "C:\XXX"
nomfichier = ActiveSheet.Range("G7") & extension
With ActiveWorkbook
.SaveAs Filename:=chemin & nomfichier
.Close
End With
End Sub

 

[tototiti2008]

Re : Accepter ou non ecrasement fichier

Bonjour coolman,

En effet, tu as 2 procédures d'enregistrement
je suppose que le chemin "c:\XXX" de la macro Send_Active_Sheet n'est pas le même que le chemin "c:\XXX" de la macro Archiver ? Peux-tu confirmer ?
Comme la macro Send_Active_Sheet supprime le fichier temporaire après l'avoir envoyé, je suppose que ce n'est pas elle qui crée les conflits
Donc si j'ai compris, il faudrait modifier Archiver comme ça

Sub Archiver()

Dim extension As String
Dim chemin As String, nomfichier As String
Dim style As Integer, bEcrase As Boolean
    Application.ScreenUpdating = False
    ThisWorkbook.ActiveSheet.Copy
    extension = ".xls"
    chemin = "C:\XXX"
    nomfichier = ActiveSheet.Range("G7") & extension
    bEcrase = True
    If Dir(chemin & nomfichier) <> "" Then
        bEcrase = (MsgBox(Prompt:="un fichier de ce nom existe déjà, l'écraser ?", Buttons:=vbYesNo) = vbYes)
    End If
    If bEcrase Then
        Application.DisplayAlerts = False
        With ActiveWorkbook
            .SaveAs Filename:=chemin & nomfichier
            .Close
        End With
        Application.DisplayAlerts = True
    End If
End Sub

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Oui le repertoire de Send_Active n'est pas le meme que celui d'Archiver

Par contre comme je les marqué, je veux pas qu'il ecrase le fichier deja existant.
Je voudrais que si on met Oui il ouvre le fichier deja crée et si on met Non il ferme le classeur ouvert sans enregistrer

 

[tototiti2008]

Re : Accepter ou non ecrasement fichier

Re,

Je voudrais que si on met Oui il ouvre le fichier deja crée et si on met Non il ferme le classeur ouvert sans enregistrer

-Si le fichier existe déjà :
si on met Oui, il ferme sans enregistrer le classeur en cours et ouvre l'existant
si on met non, il ferme sans enregistrer le classeur en cours
-S'il n'existe pas
on enregistre le classeur en cours

c'est ça ?

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Oui c'est exactement sa

 

[tototiti2008]

Re : Accepter ou non ecrasement fichier

Re,

Comprend pas bien la logique mais si tu dis que c'est ça...

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 = ".xls"
    chemin = "C:\XXX"
    nomfichier = ActiveSheet.Range("G7") & extension
    If Dir(chemin & nomfichier) <> "" 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

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Moi aussi je comprend pas trop mais c'est pour le taf donc j'ai pas trop le choix

Je vais essayé d'expliquer au mieux :

Le formulaire est crée et s'affiche via un autre programme dans un autre classeur Excel

Quand on veut enregistrer le formulaire via le bouton, il est enregistrer sous le nom qu'il y a en G7 ex: si G7 = "TATA" alors le formulaire sera enregistrer en TATA.xls dans un repertoire defini et le fichier TATA.xls est envoyé par mail.

Si une personne recrée un formulaire avec la meme donnée en G7 et veux l'envoyer par mail, il faut que le programme dise que "le fichier existe deja voulez vous l'ouvrir" et que s'il choisi :
Oui :Ouvre le fichier deja crée dans le repertoire, ferme celui qui vient d'etre crée et n'envoie pas le mail
Non: N'ouvre pas le fichier dans le repertoire, ferme celui qui vient d'etre crée et n'envoie pas le mail

Par contre s'il n'existe pas le programme enregistre le fichier sous le nom en G7 et l'envoi par mail

J'espere que tu comprend mieux le principe

Donc le souci de ce que tu m'a envoyer est qu'il envoi un mail quand tu mets OUI ou NON alors qu'il devrai pas avoir de mail envoyer

En tout cas merci de bien vouloir m'aider

 

[tototiti2008]

Re : Accepter ou non ecrasement fichier

Re,

et comme ça ?

Option Explicit
 
Const EMBED_ATTACHMENT As Long = 1454

Const stPath As String = "C:\XXX"

Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf &  vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf &  "Cordialement"
                                                                             
Dim bExist as boolean

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
 
  'Copy the active sheet to a new temporarily workbook.
  With ActiveSheet
    .Copy
    stFileName = .Range("G7").Value
  End With
 
  stAttachment = stPath & "\" & stFileName & ".xls"
 
  'Save and close the temporarily workbook.
   With ActiveWorkbook
    .SaveAs stAttachment
    .Close
  End With
 
  'Create the list of recipients.
  vaRecipients = VBA.Array("XX@XX.fr")
  
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GetDatabase("", "")
 
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
 
  'Create the e-mail and the attachment.
  Set noDocument = noDatabase.CreateDocument
  Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
 
  'Add values to the created e-mail main properties.
  With noDocument
    .Form = "Memo"
    .SendTo = vaRecipients
    .Subject = stFileName
    .Body = vaMsg
    .SaveMessageOnSend = True
    .PostedDate = Now()
    .Send 0, vaRecipients
  End With
 
  'Delete the temporarily workbook.
  Kill stAttachment
 
  'Release objects from memory.
  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()
Call Archiver
if not bExist then Call Send_Active_Sheet
End Sub

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 = ".xls"
    chemin = "C:\XXX"
    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

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Quand je mets Oui, il me mets "qu'il est impossible d'enregistrer sous le meme nom qu'un autre classeur ou macro complementaire ouvert"
Si je mets Non il m'envoie encore le mail

 

[tototiti2008]

Re : Accepter ou non ecrasement fichier

Re,

Tu as mis tous le code que je t'ai proposé ?

J'ai fait des modifs là :

...
Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf & "Cordialement"

Dim bExist as boolean

Sub Send_Active_Sheet()

...

Private Sub EnvoyerMail_Click()
Call Archiver
if not bExist then Call Send_Active_Sheet
End Sub
...

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
...

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Bonjour tototiti2008 et le forum

Je viens de retester en faisant un copier coller de ton code et je te confirme que :

- si le fichier existe pas l'enregistrement et l'envoi par mail : OK

- si le fichier existe deja et que je choisi Oui pour l'ouvrir : Il ouvre le classeur dans le repertoire defini mais cree un nouveau classeur temporaire (je suppose) puis bug en me mettant le message "impossible d'enregistrer sous le meme nom qu'un autre classeur ou macro complementaire ouvert". Par contre il n'envoi pas le mail donc pour sa OK

- si le fichier existe deja et que je choisi Non pour l'ouvrir : N'ouvre pas le fichier dans le repertoire et ferme le fichier qui vient d'etre crée : OK Par contre il envoi le mail quand meme

Merci d'avance pour ton aide

 

[coolman53]

Re : Accepter ou non ecrasement fichier

Bonjour a tous

J'ai fais des modif et maintenant mon pb est au niveau des mails pour les 2 dernieres conditions

Je voudrais que si une des 2 dernieres conditions est choisi le mail ne s'envoie pas

Je remets le code modifié

Merci d'avance

Option Explicit
 
Const EMBED_ATTACHMENT As Long = 1454

Const stPath As String = "C:\Documents and Settings\TECHNICI\Bureau"

Const vaMsg As Variant = "Bonjour," & vbCrLf & vbCrLf & vbCrLf & "Voici le formulaire" & vbCrLf & vbCrLf & "Cordialement"
                                                                             
Dim bExist As Boolean

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
 
  'Copy the active sheet to a new temporarily workbook.
  With ActiveSheet
    .Copy
    stFileName = .Range("G7").Value
  End With
 
  stAttachment = stPath & "\" & stFileName & ".xls"
 
  'Save and close the temporarily workbook.
   With ActiveWorkbook
    .SaveAs stAttachment
    .Close
  End With
 
  'Create the list of recipients.
  vaRecipients = VBA.Array("XX@XX.fr")
  
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GetDatabase("", "")
 
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
 
  'Create the e-mail and the attachment.
  Set noDocument = noDatabase.CreateDocument
  Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
 
  'Add values to the created e-mail main properties.
  With noDocument
    .Form = "Memo"
    .SendTo = vaRecipients
    .Subject = stFileName
    .Body = vaMsg
    .SaveMessageOnSend = True
    .PostedDate = Now()
    .Send 0, vaRecipients
  End With
 
  'Delete the temporarily workbook.
  Kill stAttachment
 
  'Release objects from memory.
  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()
Call Archiver
If bExist = False Then Call Send_Active_Sheet
End Sub

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 = ".xls"
    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