Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Tester si répertoire existe et le créer si non


Sujet :

Macros et VBA Excel

  1. #1
    Futur Membre du Club
    Tester si répertoire existe et le créer si non
    Hello tlm,

    J'ai un bouton dans un formulaire qui à pour fonction:
    1. Contrôler si le dossier destination existe
    2. S'il n'existe pas le créer
    3. faire une copie de mon fichier et le sauver sous un chemin x
    4. renommer et sauver le fichier ouvert dans le répertoire existant ou créé
    5. S'il existe déjà, juste faire la copie et la sauvegarde
    6. Envoi du fichier par mail

    Voici mon code:
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    Sub Button269_Click()
    'Check dir and created if necessary, Save & Send the renamed file by email '
     
     
    If (Dir("C:\Windows\Temp\repertoir_stockage")) <> "repertoir_stockage" Then
    MkDir ("C:\Windows\Temp\repertoir_stockage")
     
    ActiveWorkbook.SaveCopyAs filename:="C:\Windows\Temp\" & Range("B7").Value & "_" & Range("I8").Value & "_eShell_order.xls"
    ActiveWorkbook.SaveAs filename:="C:\Windows\Temp\Phonak_eShell\" & Range("B7").Value & "_" & Range("I8").Value & "_eShell_order.xls"
    Else
    End If
     
    Dim ol As Object, myItem As Object
    Set ol = CreateObject("outlook.application")
    Set myItem = ol.CreateItem(olMailItem)
    myItem.to = "moi@mail.com"
    myItem.Subject = "German acoustician order form"
    myItem.Body = "voici le fichier de stockage"
    'fichier en cours d'utilisation envoyé en attaché:
    myItem.Attachments.Add ActiveWorkbook.FullName
    myItem.Send
    Set ol = Nothing
     
    End Sub

    Cela fonctionne très bine à la première execution mais si je l'execute à nouveau ça plante sur: MkDir ("C:\Windows\Temp\repertoir_stockage") car il existe déjà du coup.

    Comme lui dire s'il existe déja juste faire:

    La copie, renommage et sauvegarde
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    ActiveWorkbook.SaveCopyAs filename:="C:\Windows\Temp\" & Range("B7").Value & "_" & Range("I8").Value & "_eShell_order.xls"
    ActiveWorkbook.SaveAs filename:="C:\Windows\Temp\Phonak_eShell\" & Range("B7").Value & "_" & Range("I8").Value & "_eShell_order.xls"


    Et l'envoi par mail en attachment:
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    Dim ol As Object, myItem As Object
    Set ol = CreateObject("outlook.application")
    Set myItem = ol.CreateItem(olMailItem)
    myItem.to = "moi@mail.com"
    myItem.Subject = "German acoustician order form"
    myItem.Body = "voici le fichier de stockage"
    'fichier en cours d'utilisation envoyé en attaché:
    myItem.Attachments.Add ActiveWorkbook.FullName
    myItem.Send
    Set ol = Nothing

    Merci d'avanc epour votre aide!

  2. #2
    Membre confirmé
    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
     
    If Dir("U:\Toto", vbDirectory) <> "" Then 
                   'Ton fichier U:\Toto existe donc pas la peine de le créer

  3. #3
    Inactif  
    Bonjour,

    ceci te créera le répertoire c:\toto\titi\tata\, y compris ses sous-répertoires, que s'il le faut (que ce qu'il faut) , sans la moindre faille :

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
     
    Private Sub Command1_Click()
     SHCreateDirectoryEx 0, "c:\toto\titi\tata\", ByVal 0&
    End Sub

  4. #4
    Membre confirmé
    Interessant comme solution.. je ne connaissais pas

    Pas sur que cette fonction soit forcément présente sur toutes les installations ==> attention à ce genre de truc....

  5. #5
    Membre actif
    bonjour a tous,

    j'apporte encore une autre solution, juste pour la forme:

    Code :Sélectionner tout -Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    Sub tt()
    'Il ne faut pas oublier de rajouter la réference
    'Miscrosoft Scripting runtime
     
    Dim fso As FileSystemObject
    Dim fsoMonDossier As Folder
    Dim stMonChemin As String
     
    stMonChemin = "c:\temp\monchemin"
     
    Set fso = New FileSystemObject
     
    If Not fso.FolderExists(stMonChemin) Then
      Set fsoMonDossier = fso.CreateFolder(stMonChemin)
    End If
     
    End Sub