Problème pour renommer un fichier avant de l'envoyer par mail

mistermail
Messages postés
2
Date d'inscription
jeudi 16 juillet 2009
Statut
Membre
Dernière intervention
4 août 2009
- 31 juil. 2009 à 16:38
mistermail
Messages postés
2
Date d'inscription
jeudi 16 juillet 2009
Statut
Membre
Dernière intervention
4 août 2009
- 4 août 2009 à 09:37
Bonjour,

Voila j'aimerais renommer les fichiers présents dans un répertoire avant de les envoyer par mail.

Je ne vois pas où se trouve le problème, Pouvez-vous m'aider ?

C'est juste la partie renommage qui va pas car le reste fonctionne seul mais si vous voyez des optimisations, n'hésitez pas à me donner.

Voici ma source :

'***************************************************************
'Recherche d'un fichier texte
'Si le fichier est présent envoi par mail
'Trace dans un fichier de log
'Ce script est à lancé à l'ouverture d'une session
'***************************************************************


'***************************************************************
'Liste des paramètres pouvant être modifiés

'Répertoire de recherche
RepSearch="C:\recherche"
'Répertoire d'écriture du log
RepLog="C:\log"
'Répertoire de stockage
RepStk="C:\stockage"

'Nom du fichier de trace
FichierTrace="Log.txt"

'Paramétrage des attributs du mail (expéditeur, destinataires, copie, sujet, corps, serveur smtp)
Expediteur="<toto@toto.com>"
Destinataire="<tata@tata.com>
DestinataireCopie="<toto@toto.com>"
SujetMail="XML"
CorpsMail="Text

"
ServeurSMTP="smtp.toto.com"

'***************************************************************


Dim log,fichier,fs1,fs2,objfso,fs3,fichier1

FichierLog=RepLog&FichierTrace

Set fs2 = CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFiles = objFSO.GetFolder(RepSearch).Files
Set log = fs2.opentextfile(FichierLog,8,True)

For each file in objfiles

set fs3 = CreateObject("Scripting.FileSystemObject")
set fichier1 = fs3.GetFileName(file)
Set ftxt1 = fs3.GetFile(file)

'ftxt1.MoveFile RepStk&""&fichier1 , RepStk&""&fichier1&".xml"

Next


For each file in objfiles

With CreateObject("CDO.Message")
.From=Expediteur
.To=Destinataire
.Cc=DestinataireCopie
.Subject=SujetMail
.HTMLBody=CorpsMail
.AddAttachment(file)
.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = ServeurSMTP
.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Configuration.Fields.Update

On Error Resume Next
.Send

If Err Then
log.write(Now&" Le fichier "&file&" n'a pas pu être expédié."&VbCrLf)
On Error GoTo 0
Else
Set FS1 = CreateObject("Scripting.FileSystemObject")
set Fichier = fs1.GetFileName(file)
Set Ftxt = fs1.GetFile(file)
log.write(Now&" Le fichier "&file&" a été envoyé avec Succès et a été copié à l'emplacement "&RepStk&"."&VbCrLf)
Ftxt.copy(RepStk&""&fichier)
if Ftxt.FileExists(RepStk&""&fichier) then
Ftxt.delete
End if
End If



End With

Next

stop


Merci d'avance

2 réponses

cs_JMO
Messages postés
1854
Date d'inscription
jeudi 23 mai 2002
Statut
Membre
Dernière intervention
24 juin 2018
26
2 août 2009 à 23:27
 Bonsoir à tous,

"Petites retouches" sur ton script, mistermail.

- parcours du folder "RepSearch";
a) si extension du fichier <> xml, rename du fichier dans le même folder avec extension .xml;
- envoi du mail:
si ok, move du fichier dans "RepStk" + write log;
si not ok, write log.

b) si extension du fichier = xml, envoi du mail;
- envoi du mail:
si ok, move du fichier dans "RepStk" + write log;
si not ok, write log.

Test mail non effectué

'***************************************************************
'Liste des paramètres pouvant être modifiés
Option Explicit
Const ForAppending = 8
Dim RepSearch, RepLog, RepStk, FichierTrace
'Répertoire de recherche
RepSearch="c:\recherche"
'Répertoire d'écriture du log
RepLog="c\log"
'Répertoire de stockage
RepStk="c:\stockage"

'Nom du fichier de trace
FichierTrace="Log.txt"
'***************************************************************
Dim objFso, objFile
Dim strFile, strLog, strNewFile
Dim FichierLog
FichierLog = RepLog & FichierTrace

Set objFso = CreateObject("Scripting.FileSystemObject")

For each objFile in objFso.GetFolder(RepSearch).Files
    Select Case LCase(objFso.GetExtensionName(objFile))
       Case "xml"
          WriteLog Now & vbTab & "Le fichier """ & objFile.Path & """ existait déjà..." & _ 
                                 "Tentative d'envoi du mail"
          SendingMail(objFile.Path)
       Case Else
          strNewFile = RepSearch & Mid(objFile.Name, 1, InStrRev(objFile.Name, ".")) & "xml"
          objFso.MoveFile objFile.Path, strNewFile
          SendingMail(strNewFile)
    End Select
Next
Set objFso = Nothing
'***************************************************************
Sub WriteLog(ArgLog)
    Dim objLog
    Set objLog = objFso.OpenTextFile(FichierLog, ForAppending, True)
    objLog.Write ArgLog & vbcrlf
    objLog.Close
    Set objLog = Nothing
End Sub
'***************************************************************
Sub SendingMail(ArgFile)
    Dim Emetteur, Destinataire, DestinataireCopie, SujetMail, CorpsMail, ServeurSMTP
    'Paramétrage des attributs du mail (expéditeur, destinataires, copie, sujet, corps, serveur smtp)
    Emetteur="<toto@toto.com>"
    Destinataire="<tata@tata.com>
    DestinataireCopie="<toto@toto.com>"
    SujetMail="XML"
    CorpsMail="Text

"
    ServeurSMTP="smtp.toto.com" 

    Dim iMsg, iConf
    'Create the message object.
    Set iMsg = CreateObject("CDO.Message")
    'Create the configuration object.
    Set iConf = iMsg.Configuration
    'Set the fields of the configuration object to send by using SMTP through port 25.
    With iConf.Fields
         .item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
         .item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = ServeurSMTP
         .Update
    End With
    'Set the To, From, Subject, and Body properties of the message.
    With iMsg
         .To=Destinataire
         .CC=DestinataireCopie
         .From=Emetteur
         .Subject=SujetMail
         .HTMLBody=CorpsMail
         .AddAttachment(ArgFile) 
         On Error Resume Next 
         .Send
         If Err Then
            WriteLog Now & vbTab & "Le fichier """ & objFile.Path & """ n'a pu être expédie." 
            On Error GoTo 0
         Else
            objFso.MoveFile ArgFile, RepStk
            WriteLog Now & vbTab & "Le fichier """ & objFile.Path & _ 
                     """ a été envoyé avec Succès et a été copié à l'emplacement """ & _ 
                     RepStk & """." & vbCrLf 
         End If 
    End With
    Set iMsg = Nothing
    Set iConf = Nothing
End Sub
'***************************************************************




jean-marc
0
mistermail
Messages postés
2
Date d'inscription
jeudi 16 juillet 2009
Statut
Membre
Dernière intervention
4 août 2009

4 août 2009 à 09:37
Merci c'est nikel. Ca fonctionne bien.

Dominique.
0