Aide finalisation projet

[Lone-wolf]

Bonsoir à tous,

je suis entrain de finaliser le projet de mon ancien post "Copier-Coller avec temporisation" et j'aimerais votre aide pour ceci.

Il reste 4 choses à faire. La première est celle-ci:

Lister les sous-dossiers et fichiers, non pas dans la feuille Excel, mais du un fichier texte. Là, la ListBox devra afficher que les fichiers, comme dans l'exemple du projet.

Sub Ouverture()
Dim Fso As Object, Source As String, Destination As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Source = ThisWorkbook.Path & "\Win Remix"
Destination = "C:\Program Files\Win Remix"
Fso.CopyFolder Source, Destination, False
End Sub

Ce code viens de pierrot, sauf que lui avait mis dans "Source" le chemin complet;
et moi j'ai changé par TisWorkbook.Path.

Maintenant, il faudrait que "Destination" soit choisi par l'utilisateur; c'est à dire:
lui laisser le choix de la destination.

Là, il y a déjà la fenêtre "Créer un dossier" qui s'affiche lorsqu'on clique sur le bouton avec des pointillés.

Dans cette fenêtre et sur OK, la déstination s'affiche dans la ComboBox.

Sur le clique du bouton Installer, faire apparaître une barre de progression qui suit l'installation des fichiers et dossiers.

Vu la taille conséquante du dossier, je l'ai mis à cette adresse:

Ce lien n'existe plus


Merci d'avance pour votre aide



A+

 

[Pierrot93]

Re : Aide finalisation projet

Bonjour,

pour choisir la destination :

Sub test()
Dim Fso As Object, Source As String, Destination As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Source = ThisWorkbook.Path & "\Win Remix"
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    If .SelectedItems.Count > 0 Then Fso.CopyFolder Source, .SelectedItems(1), False
End With
End Sub

bonne journée
@+

 

[Lone-wolf]

Re : Aide finalisation projet

Bonjour Pierrot,

merci d'avoir répondu. Il y a un petit problème avec le code.

Sub Ouverture()
Dim Fso As Object, Source As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Source = ThisWorkbook.Path & "\Win Remix"
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    If .SelectedItems.Count > 0 Then Fso.CopyFolder Source, .SelectedItems(1), False
End With
Installateur.Ch_Disque.Value = fs.GetFolder(repertoire).Files
End Sub

Sub Installer()
Dim fs  As Object, t As Double
Dim repertoire As String, f As Object, x As Integer
Dim f1 As Object, f2 As Object

Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
repertoire = ThisWorkbook.Path & "\Win Remix"
x = 1
Application.Cursor = xlNorthwestArrow
Installateur.Lbl.Caption = "Copie des fichiers en cours... Veuillez patienter."


For Each f In fs.GetFolder(repertoire).Files
    Cells(x, 1).Value = f.Name
    x = x + 1
Next f
x = 1

For Each f1 In fs.GetFolder(repertoire).SubFolders
    Cells(x, 2).Value = f1.Name
    x = x + 1
For Each f2 In f1.Files
        Cells(x - 1, 3).Value = f2.Name
        x = x + 1
        t = Timer + 0.5: Do Until Timer > t: DoEvents: Loop
Next f2
x = x - 1
Next f1

Installateur.Lbl.Caption = "Installation de Win Remix..."
t = Timer + 1: Do Until Timer > t: DoEvents: Loop

Installateur.Lbl.Caption = "Vous pouvez maintenant quitter l'assistant d'installation..."
Application.ScreenUpdating = True
End Sub

Ici j'ai déjà la fenêtre "Rechercher un dossier" qui s'affiche. Ensuite je vais sur le Disque "D", clic sur OK, la comboBox n'affiche rien. Je clique sur Installer, il copie les fichiers une fois que c'est fait et commence l'nstallation, la fenêtre "Parcourir" s'affiche.

Cette fenêtre est inutile, vu qu'en allant dur "D", j'ai créer le chemin de déstination.
Il faudrait combiné les deux Sub peut-être.

En enlevant Destination, le dossier n'est pas copier.

A+

 

[Lone-wolf]

Re : Aide finalisation projet

Pour les interéssés voici le code au complet mais sans (pour l'instant) la barre de progression.

Module 1

Sub Afficher()
Installateur.Show vbModeless
End Sub

Sub Installer()
Dim fs  As Object, t As Double
Dim repertoire As String, f As Object, x As Integer
Dim f1 As Object, f2 As Object

Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
repertoire = ThisWorkbook.Path & "\Win Remix XP"
x = 1
Application.Cursor = xlNorthwestArrow
Installateur.Lbl.Caption = "Copie des fichiers en cours... Veuillez patienter."


For Each f In fs.GetFolder(repertoire).Files
    Cells(x, 1).Value = f.Name
    x = x + 1
Next f
x = 1

For Each f1 In fs.GetFolder(repertoire).SubFolders
    Cells(x, 2).Value = f1.Name
    x = x + 1
For Each f2 In f1.Files
        Cells(x - 1, 3).Value = f2.Name
        x = x + 1
        t = Timer + 0.5: Do Until Timer > t: DoEvents: Loop
Next f2
x = x - 1
Next f1
Installateur.Lbl.Caption = "Installation de Win Remix..."
t = Timer + 1: Do Until Timer > t: DoEvents: Loop
Copie
Installateur.Lbl.Caption = "Vous pouvez maintenant quitter l'assistant d'installation..."
Application.ScreenUpdating = True
End Sub

Sub Effacer()
Application.Cursor = xlNorthwestArrow
Installateur.ListBox1.RowSource = ""
Sheets("Feuil1").Range("C1:C606").ClearContents
End
End Sub

Module 2

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Public Declare Function SendMessageA Lib "user32" _
      (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, _
      ByVal lParam As Long) As Long
 
Public Declare Function ExtractIconA Lib "shell32.dll" _
      (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
 
Public chemin As String


Sub Dossier()

activedir = "D:\" & "C:\"

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Dossier de destination:" & choix, &H1&, activedir)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path
If objFolder.Title <> "" Then: chemin = chemin
j = InStr(objFolder.Title, ":")

If x > 0 Then chemin = Mid(objFolder.Title, j - 1, 2) & ""
If Not Len(chemin) = 0 Then Range(R) = chemin
Installateur.Ch_Disque.Value = chemin
End Sub
Sub Copie()
Dim Fso As Object, Source As String, Destination As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Source = ThisWorkbook.Path & "\Win Remix XP"
Destination = chemin & "\"
Fso.CopyFolder Source, Destination, False
End Sub

Code du Formulaire

Private Declare Function FindWindowA& Lib "user32" _
    (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function EnableWindow& Lib "user32" _
    (ByVal hwnd&, ByVal bEnable&)
Private Declare Function GetWindowLongA& Lib "user32" _
    (ByVal hwnd&, ByVal nIndex&)
Private Declare Function SetWindowLongA& Lib "user32" _
    (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)

Private Sub Annul_Click()
 Effacer
 Unload Installateur
End Sub

Private Sub Rech_Click()
Dossier
End Sub

Private Sub UserForm_Activate()
Me.ListBox1.RowSource = "Feuil1!C1:C606"
 
 Dim hwnd As Long
    
    hwnd = FindWindowA("XLMAIN", Application.Caption)
    EnableWindow hwnd, 1
End Sub

Private Sub UserForm_Initialize()
Me.ListBox1.RowSource = ""
Sheets("Feuil1").Range("A1:C606").ClearContents

 Dim hwnd As Long
    
    hwnd = FindWindowA(vbNullString, Me.Caption)
    SetWindowLongA hwnd, -16, GetWindowLongA(hwnd, -16) Or &H20000
    
    Dim Fichier As String
    Dim x As Long
    
    Fichier = "D:\Dossiers Excel\Formulaires\Installateur\sfx.ico"
    x = Len(Dir(Fichier))
    If x = 0 Then Exit Sub
    
    x = ExtractIconA(0, Fichier, 0)
    SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, x
End Sub

Private Sub Install_Click()
Installer
End Sub

Vous pouvez soit créer un nouveau dossier (Le DpD sera créé dedans), soit laisser le dossier par défaut.

Si quelqu'un pourrait m'aider pour la Progressbar...

A+