[VBA] Enregistrement et création de répertoire

Version imprimable

12/03/2008, 15h59
etorria

1 pièce(s) jointe(s)

[VBA] Enregistrement et création de répertoire

Bonjour au Forum !

Dans un userform, je saisie des données dans des TextBox. On y
renseigne la date du jour, une catégorie et des valeurs.
Ces données sont enregistrées quotidiennement dans un onglet portant
le nom de la date du jour.
Mon souhait serait, à l'aide d'un code VBA, de créer automatiquement
dans C:\ par exemple, un premier répertoire dénommé "MARS" puis un
sous-répertoire dénommé "12-03-2008" (pour la date du jour) et enfin
un autre sous répertoire dénommé "Alpha" (pour la catégorie). Dans ce
dernier seront enregistrées mes données saisies dans l'userform.

Est-ce réalisable sous VBA ou dois-je faire la "manip" manuellement ?

Cordialement,

Etorria
12/03/2008, 17h07
ML0808
C'est faisable sous VBA. Tu auras besoins des infos suivante :

MkDir "Chemin/NomDossier" => Créer un dossier
SaveAs "Chemin/NomFichier" => Sauvegarde ton fichier

Ce code te rentre dans la variable ProjectPath le chemin de ton classeur actuel :
Code:

1 2 3 4 5 6 7 ' Associe le classeur de recherche au nom RECH Dim WBK As Workbook Set WBK = ActiveWorkbook ' Mémorise le chemin du fichier Dim ProjectPath$ ProjectPath = ActiveWorkbook.Path
Date() => te donne la date

A+

Soir Bon,à adapter au contexte

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 
Option Explicit
 
Sub TstCreationDossier()
Dim Dossier As String
 
    Dossier = "C:\Essai1\Essai2\Essai3\Essai4\Essai5"
    If CreationDossier(Dossier) Then
        MsgBox "Dossier : " & Dossier & " créé"
    Else
        MsgBox "Chemin d'Accès introuvable"
    End If
End Sub
 
Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
    If InStr(sChemin, ":") = 0 Then
        Ar = Split(CurDir & "\" & sChemin, "\")
    Else
        Ar = Split(sChemin, "\")
    End If
 
    sTmp = Ar(0)
    ChDrive sTmp
 
    For i = LBound(Ar) + 1 To UBound(Ar)
        If Ar(i) <> "" Then
            sTmp = sTmp & "\" & Ar(i)
            On Error Resume Next
            MkDir sTmp
            On Error GoTo 0
        End If
    Next i
 
    If Dir(sChemin, vbDirectory) = vbNullString Then
        CreationDossier = False
    Else
        CreationDossier = True
    End If
End Function

Bonjour,

Moi, je te propose ceci, à analyser et à adapter à ton appli

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Sub Command1_Click()
  Dim mois As String, racine As String, fichier As String, repertoire As String
  mois = UCase(Format(Date, "mmmm"))
  ladate = Format(Date, "dd-mm-yyyy")
  repertoire = "D:\" & mois
  If Not deja(repertoire, vbDirectory) Then
    MkDir repertoire
  Else
    alerte repertoire, "répertoire"
  End If
  repertoire = repertoire & "\" & ladate
  If Not deja(repertoire, vbDirectory) Then
    MkDir repertoire
  Else
    alerte repertoire, "répertoire"
  End If
  fichier = repertoire & "\coucou.txt"
  If Not deja(fichier, 0) Then
    '=======>>> ICI  tes instruction de sauvegarde du fichier coucou
  Else
    alerte fichier, "fichier"
  End If
End Sub
 
Private Function deja(acreer As String, att As Integer) As Boolean
  deja = False
  If Dir(acreer, att) <> "" Then deja = True
End Function
 
Private Sub alerte(acreer As String, quoi As String)
  MsgBox "Le " & quoi & " " & acreer & " existe déjà !"
End Sub

Citation:

Envoyé par ucfoutu

Bonjour,

Moi, je te propose ceci, à analyser et à adapter à ton appli

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Private Sub Command1_Click()
  Dim mois As String, racine As String, fichier As String, repertoire As String
  mois = UCase(Format(Date, "mmmm"))
  ladate = Format(Date, "dd-mm-yyyy")
  repertoire = "D:\" & mois
  If Not deja(repertoire, vbDirectory) Then
    MkDir repertoire
  Else
    alerte repertoire, "répertoire"
  End If
  repertoire = repertoire & "\" & ladate
  If Not deja(repertoire, vbDirectory) Then
    MkDir repertoire
  Else
    alerte repertoire, "répertoire"
  End If
  fichier = repertoire & "\coucou.txt"
  If Not deja(fichier, 0) Then
    '=======>>> ICI  tes instruction de sauvegarde du fichier coucou
  Else
    alerte fichier, "fichier"
  End If
End Sub
 
Private Function deja(acreer As String, att As Integer) As Boolean
  deja = False
  If Dir(acreer, att) <> "" Then deja = True
End Function
 
Private Sub alerte(acreer As String, quoi As String)
  MsgBox "Le " & quoi & " " & acreer & " existe déjà !"
End Sub

Merci à vous tous !

Etorria

Bon...

Puisque je vois que tu as passé cette première étape...

Nous allons maintenant voir ensemble la puissance et l'agilité de l'Api de Windows, dont la fonction SHCreateDirectoryEx est, elle, capable de ne créer un répertoire QUE S'IL N'EXISTE PAS (et le tout en silence).
Nous n'aurons donc à prendre une précaution (et un message si besoin) que pour le fichier de sauvegarde.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _ (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long Private Sub Command1_Click() Dim mois As String, racine As String, fichier As String, repertoire As String, coucou As Long mois = UCase(Format(Date, "mmmm")) ladate = Format(Date, "dd-mm-yyyy") repertoire = "D:\" & mois & "\" & ladate fichier = repertoire & "\coucou.txt" coucou = SHCreateDirectoryEx(0&, repertoire, 0&) If Dir(fichier, 0) = "" Then 'ici tes instructions de sauvegarde Else MsgBox "le fichier " & fichier & " existe déjà !" End If End Sub
Important : cette fonction nécessite toutefois Win 2000 ou au dessus.... (mais qui se sert encore de Win 9x ??? :lol:)