Bonjour,
je suis actuellemnt en stage et je dois créer un petit outils codé en vba.
N'étant pas trés douée, je suis face à un petit probléme.
Je veux coder un petit explorateur de fichier qui me remplisse une liste.
J'ai codé quelque chose en m'aidant de codes deja existants, or j aimerais ne pas avoir à parcourir toute l'arborescence en se placant directement dans un répertoire prédéfini, or je n y arrive pas.
Mon deuxieme probleme est qu une fois le fichier sélectionné dans ma liste, je n'arrive pas à l'ouvrir.
Je vous joins mon code, pourriez vous m'aider.
Merci d'avance.
Sub Label1_click()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
Arret = False
Application.ScreenUpdating = False
Sheets.Add
Do
LeChemin = ChoisirDossier
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher", _
LeTitre, "*.*")
Call Remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
With ActiveSheet
Columns("A:B").AutoFit
'.UsedRange.Sort Range("A1")
.Columns.Range.Sort Range("A1")
End With
ActiveSheet.Select
'active.Worksheets
'Worksheets("feuil1").Select
' on definit la taille de la liste
i = 1
While Cells(i, 2).Value <> ""
i = i + 1
Wend
'on remplit la liste avec les valeurs issues de l feuille excel
For j = 1 To i
If Cells(j, 2).Value <> "" Then
modifiercoef.ListBox1.AddItem ActiveSheet.Cells(j, 2).Value
Else: MsgBox ("liste remplie")
End If
Next j
End Sub
Sub Fichiers_Chemins()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
Arret = False
Application.ScreenUpdating = False
Sheets.Add
Do
LeChemin = ChoisirDossier
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher", _
LeTitre, "*.*")
Call Remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
With ActiveSheet
Columns("A:B").AutoFit
.UsedRange.Sort Range("A1")
End With
End Sub
Private Sub Remplir(RepertParent, ExtFichier)
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String
ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If
Do While Len(LeFichier) <> 0
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LeFichier
ActiveCell.Offset(1, -1).Select
LeFichier = Dir
Loop
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) _
And vbDirectory) = vbDirectory Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." _
And LeDossierLocal(Compteur) <> ".." Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) _
And vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
Call Remplir(ParentLocal, ExtLocale)
Next
End Sub
Function ChoisirDossier()
Dim objShell, objFolder, SecuriteSlash ', chemin
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
Chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
Chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = Chemin
MsgBox (ChoisirDossier)
End Function
Sub test()
fileToOpen1 = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
fileToOpen2 = Application _
.GetOpenFilename("documents word (*.doc),*.doc")
fileToOpen3 = Application _
.GetOpenFilename("documents excel (*.xls),*.xls")
If fileToOpen1 <> False Then
MsgBox "Open " & fileToOpen1
ElseIf fileToOpen2 <> False Then
MsgBox "Open " & fileToOpen2
ElseIf fileToOpen3 <> False Then
MsgBox "Open " & fileToOpen3
End If
End Sub
Private Sub OptionButton2_Click()
End Sub
Sub valider_Click()
'Call ChoisirDossier
'ChoisirDossier = chemin
'MsgBox ("le dossier" & ChoisirDossier)
'MsgBox (chemin & "\")
'Workbooks.Open "chemin & " \ " "
ActiveSheet.Delete
'Workbooks.Open "T:\DI\Mefp\Essais\Exterieurs\Sabrina Metche\testvba\classeur_test_interdependance.xls"
i = ListBox1.ListIndex
If i <> -1 Then
MsgBox (ChoisirDossier & "\" & ListBox1.List(i))
Workbooks.Open ChoisirDossier & "\" & ListBox1.List(i)
Else: MsgBox ("Veuillez sélectionné le champs que vous désirez supprimer")
End If
End Sub
''''''--> initialisation du formulaire
Private Sub UserForm_Initialize()
Label1.ControlTipText = "Afin d'actualiser la liste "
End Sub
je suis actuellemnt en stage et je dois créer un petit outils codé en vba.
N'étant pas trés douée, je suis face à un petit probléme.
Je veux coder un petit explorateur de fichier qui me remplisse une liste.
J'ai codé quelque chose en m'aidant de codes deja existants, or j aimerais ne pas avoir à parcourir toute l'arborescence en se placant directement dans un répertoire prédéfini, or je n y arrive pas.
Mon deuxieme probleme est qu une fois le fichier sélectionné dans ma liste, je n'arrive pas à l'ouvrir.
Je vous joins mon code, pourriez vous m'aider.
Merci d'avance.
Sub Label1_click()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
Arret = False
Application.ScreenUpdating = False
Sheets.Add
Do
LeChemin = ChoisirDossier
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher", _
LeTitre, "*.*")
Call Remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
With ActiveSheet
Columns("A:B").AutoFit
'.UsedRange.Sort Range("A1")
.Columns.Range.Sort Range("A1")
End With
ActiveSheet.Select
'active.Worksheets
'Worksheets("feuil1").Select
' on definit la taille de la liste
i = 1
While Cells(i, 2).Value <> ""
i = i + 1
Wend
'on remplit la liste avec les valeurs issues de l feuille excel
For j = 1 To i
If Cells(j, 2).Value <> "" Then
modifiercoef.ListBox1.AddItem ActiveSheet.Cells(j, 2).Value
Else: MsgBox ("liste remplie")
End If
Next j
End Sub
Sub Fichiers_Chemins()
Dim LeChemin As String
Dim Lextension As String
Dim LeTitre As String
Dim Arret As Boolean
LeTitre = "Répertoires et sous-répertoires"
Arret = False
Application.ScreenUpdating = False
Sheets.Add
Do
LeChemin = ChoisirDossier
If Len(LeChemin) = 0 Then
Arret = True
Else
If Mid(LeChemin, Len(LeChemin), 1) <> "\" Then
LeChemin = LeChemin + "\"
End If
If Len(Dir(LeChemin, vbDirectory)) <> 0 Then
Lextension = InputBox("Taper le type de fichier à afficher", _
LeTitre, "*.*")
Call Remplir(LeChemin, Lextension)
Arret = True
Else
LeMessage = "Répertoire introuvable...Recommencer ?"
End If
End If
Loop Until Arret
With ActiveSheet
Columns("A:B").AutoFit
.UsedRange.Sort Range("A1")
End With
End Sub
Private Sub Remplir(RepertParent, ExtFichier)
Dim Compteur As Integer
Dim NbreRepert As Integer
Dim LeFichier As String
Dim LeDossier As String
Dim ExtLocale As String
Dim ParentLocal As String
Dim LeDossierLocal() As String
ExtLocale = ExtFichier
LeFichier = Dir(RepertParent & ExtFichier)
If Len(LeFichier) = 0 Then
ActiveCell.Value = RepertParent
ActiveCell.Offset(1, 0).Select
End If
Do While Len(LeFichier) <> 0
ActiveCell.Value = RepertParent
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = LeFichier
ActiveCell.Offset(1, -1).Select
LeFichier = Dir
Loop
'Compter le nombre de sous-répertoires
NbreRepert = 0
LeDossier = Dir(RepertParent, vbDirectory)
Do While LeDossier <> ""
If LeDossier <> "." And LeDossier <> ".." Then
If (GetAttr(RepertParent & LeDossier) _
And vbDirectory) = vbDirectory Then
NbreRepert = NbreRepert + 1
End If
End If
LeDossier = Dir
Loop
ReDim LeDossierLocal(NbreRepert + 1)
Compteur = 1
LeDossierLocal(Compteur) = Dir(RepertParent, vbDirectory)
Do While LeDossierLocal(Compteur) <> ""
If LeDossierLocal(Compteur) <> "." _
And LeDossierLocal(Compteur) <> ".." Then
If (GetAttr(RepertParent & LeDossierLocal(Compteur)) _
And vbDirectory) = vbDirectory Then
Compteur = Compteur + 1
End If
End If
LeDossierLocal(Compteur) = Dir
Loop
For Compteur = 1 To UBound(LeDossierLocal()) - 1
ParentLocal = RepertParent & LeDossierLocal(Compteur) & "\"
Call Remplir(ParentLocal, ExtLocale)
Next
End Sub
Function ChoisirDossier()
Dim objShell, objFolder, SecuriteSlash ', chemin
Set objShell = CreateObject("Shell.Application")
Set objFolder = _
objShell.BrowseForFolder(&H0&, "Choisisser un répertoire", &H1&)
On Error Resume Next
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
If objFolder.Title = "Bureau" Then
Chemin = "C:\Windows\Bureau"
End If
If objFolder.Title = "" Then
Chemin = ""
End If
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
Chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = Chemin
MsgBox (ChoisirDossier)
End Function
Sub test()
fileToOpen1 = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
fileToOpen2 = Application _
.GetOpenFilename("documents word (*.doc),*.doc")
fileToOpen3 = Application _
.GetOpenFilename("documents excel (*.xls),*.xls")
If fileToOpen1 <> False Then
MsgBox "Open " & fileToOpen1
ElseIf fileToOpen2 <> False Then
MsgBox "Open " & fileToOpen2
ElseIf fileToOpen3 <> False Then
MsgBox "Open " & fileToOpen3
End If
End Sub
Private Sub OptionButton2_Click()
End Sub
Sub valider_Click()
'Call ChoisirDossier
'ChoisirDossier = chemin
'MsgBox ("le dossier" & ChoisirDossier)
'MsgBox (chemin & "\")
'Workbooks.Open "chemin & " \ " "
ActiveSheet.Delete
'Workbooks.Open "T:\DI\Mefp\Essais\Exterieurs\Sabrina Metche\testvba\classeur_test_interdependance.xls"
i = ListBox1.ListIndex
If i <> -1 Then
MsgBox (ChoisirDossier & "\" & ListBox1.List(i))
Workbooks.Open ChoisirDossier & "\" & ListBox1.List(i)
Else: MsgBox ("Veuillez sélectionné le champs que vous désirez supprimer")
End If
End Sub
''''''--> initialisation du formulaire
Private Sub UserForm_Initialize()
Label1.ControlTipText = "Afin d'actualiser la liste "
End Sub
