|
 |
Les Fichiers et Répertoires
Pour enregistrer le classeur actif avec comme nom le mois et l'année courant
Sub Saved()
Dim M As String * 3 'ne prends en compte que les 3 premiers caractères Dim An As String
M = Range("Mois") 'Définir le nom d'une plage sous Mois (idem An)
An = Right(Range("an"), 2) 'ne
prends que les 2 derniers chiffres de l'an
ChDrive "c"
ChDir "c:\corbeil" 'Changer le nom du répertoire s'il y a lieu!
ActiveWorkbook.SaveAs FileName:=(M) & (An)
End Sub
Attention !supprime le fichier du disque dur
Sub SupprimFichier()
Kill "C:\ajeter\money.txt"
End Sub
Attention !supprime les fichiers du répertoire ainsi que le répertoire
Sub SupprimRépertoire()
Kill "C:\aaa\*.*" 'si le répertoire n'est pas vide supprime tous les fichiers
RmDir "c:\aaa" ' Supprime le répertoire aaa.
End Sub
Attention! Crée un répertoire c:\aaa
Sub CreRépertoire()
MkDir "c:\aaa"
End Sub
Recherche de fichiers dont les noms commencent par "Fac"
Sub ChercheFichier()
Set fs = Application.FileSearch
With fs
.LookIn = "D:\Epuiset"
.FileName = "Fac*"
If .Execute > 0 Then
MsgBox .FoundFiles.Count & " Fichier(s) ont été trouvés."
For I = 1 To .FoundFiles.Count
MsgBox .FoundFiles(I)
Next I
Else
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
End Sub
Ferme le classeur actif sans l'enregistrer
Sub FichierFermer()
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
End Sub
Ou encore...
Sub FermeSansMessage()
Application.DisplayAlerts = False
ActiveWorkbook.Close
End Sub
Ou encore... plus condensé
Sub FermeSansMessage()
ActiveWorkBook.Close SaveChanges:=False
End Sub
Récupere les noms de fichiers d'un répertoire dans un tableau.
Option Explicit
Dim chemin As String
Sub RecupNomFichier(ByVal Chemin As String, ByRef Tableau As Variant)
Dim Fichier As String
Dim Compteur As Integer
Dim LigneCompteur As Integer
Chemin = Application.InputBox(Prompt:="Quel répertoire voulez-vous imprimer?")
Chemin = Chemin + "\*.*"
'Range("B1") = Chemin
Compteur = 1
Fichier = Dir(Chemin)
Do While (Len(Fichier) > 0)
ReDim Preserve Tableau(Compteur)
Tableau(Compteur - 1) = Fichier
LigneCompteur = Compteur + 1
ActiveSheet.Range("B" & LigneCompteur).Value = Tableau(Compteur - 1)
Compteur = Compteur + 1
Fichier = Dir()
Loop
End Sub
'...Affecter cette macro à un bouton
Sub RecupFichierTableau()
Dim Tableau() As String
Call RecupNomFichier(Chemin, Tableau)
End Sub
Recherche un fichier dans un répertoire.
Sub ChercheFichier()
Set fs = Application.FileSearch
With fs
.LookIn = "D:\Epuiset"
.FileName = "Fac*"
If .Execute > 0 Then
MsgBox .FoundFiles.Count & " Fichier(s) ont été trouvés."
For I = 1 To .FoundFiles.Count
MsgBox .FoundFiles(I)
Next I
Else
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
End Sub
Donne le nom de tous les fichiers ouverts.
Sub NbFich()
Dim Wkb As Workbook
For Each Wkb In Workbooks
MsgBox Wkb.Name
Next Wkb
End Sub
Donne le chemin complet du fichier ouvert.
Sub CheminFichier()
Range("b1").Value = ActiveWorkbook.FullName
End Sub
Ouvre un fichier texte nommé test.txt situé dans C:\ajeter
Sub OuvreTxt()
Workbooks.OpenText Filename:="C:\ajeter\test.txt", _
Origin:=xlWindows, StartRow:=1,DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote,ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False,Other:=False, FieldInfo:=Array(Array(1, 1),Array(2, 1), Array(3, 1))
End Sub
Cherche et ouvre tous les fichiers situés dans le répertoire C:\ajeter
Sub ChercheetOuvreFichier()
Set fichcherche = Application.FileSearch
With fichcherche
' .LookIn = GetDirectory 'Utilise la fonction GetDirectory voir page Exemple d'application
.LookIn = "C:\ajeter" 'Changer le chemin
.FileName = "*.xls" 'ou "*.txt"
If .Execute > 0 Then
MsgBox .FoundFiles.Count & " Fichier(s) a (ont) été trouvé(s)."
For I = 1 To .FoundFiles.Count
Workbooks.Open FileName:=.FoundFiles(I)
On Error Resume Next
Next I
Else
MsgBox "Aucun fichier n'a été trouvé."
End If
End With
End Sub
Lance la boîte de dialogue "Ouvrir"
pour sélectionner un fichier et en conserver le nom dans une variable
Sub Nomdufichier()
Dim NomFichier
NomFichier = Application.GetOpenFilename
If VarType(NomFichier) = vbBoolean Then MsgBox "Action annulée" _
Else MsgBox "Fichier sélectionné : " & NomFichier
End Sub
Ouvre le fichier Test.xls s'il n'est pas déjà ouvert
Sub OuvreSiPasOuvert()
Dim Worbk As Workbook
On Error Resume Next
Set Worbk = Workbooks("Test.xls")
On Error GoTo 0
If Worbk Is Nothing Then Workbooks.Open "C:\ajeter\Test.xls" _
Else Set Worbk = Nothing
End Sub
Copie le fichier Test.xls dans le répertoire Temp
Sub CopyFichier()
Msg = "Etes-vous sûr de vouloir copier ce fichier?"
Style = vbYesNo + vbCritical + vbDefaultButton1
Title = "COPIE DU FICHIER TEST.XLS"
Réponse = MsgBox(Msg, Style, Title, Help, Context)
If Réponse = vbYes Then
GoTo continu
Else
Exit Sub
End If
continu:
FileCopy "D:\FichXL97\Test.xls", "c:\temp\Test.xls"
End Sub
Déplace le fichier Test.xls dans le répertoire aaa
Sub deplace()
Name "c:\Test.xls" As "c:\aaa\Test.xls"
End Sub
Une page spéciale: Déplacement de fichier. 
Enregistre le classeur sous la valeur de la cellule C1 dans le répertoire c:\ajeter
Sub NomClasseur()
Dim Chr As String 'déclare la variable
Chr = Range("Essai!C1")'Feuille Essai et cellule C1
ChDrive "C" 'si C n'est pas le disque par défaut
ChDir "C:\ajeter\"
ActiveWorkbook.SaveAs Filename:=(Chr)
End Sub
Enregistre le classeur avec le mois (cellule C1) et l'année(cellule C2)
Sub NomClasseur1()
Dim Month As String * 3 'seulement les 3 premières lettres
Dim Year As String
Month = Range("Feuil1!C1")
Year = Right(Range("Feuil1!C2"), 2) 'pour ne renvoyer que 01 de 2001
ChDrive "C"
ChDir "C:\ajeter\"
ActiveWorkbook.SaveAs Filename:=(Month) & (Year)
End Sub
Inscrire automatiquement la date de modification du classeur à sa fermeture
En utilisant l’événement BeforeClose la macro suivante inscrit automatiquement
la date de la dernière modification dans la cellule A1 de la première feuille de votre classeur.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets(1).[A1] = "Dernière modification le " & Format(Date, "dd/mm/yyyy")
End Sub
Demande sous quel nom enregistrer le classeur
Sub Enregistre_Sous()
Réponse = MsgBox("Voulez-vous enregistrer ce classeur ?", vbYesNo)
If Réponse = vbYes Then
Nom = InputBox("Donnez un nom de fichier !" & Chr(13) & "Exemple: Rapport")
If Nom = "" Then
Exit Sub
Else
GoTo continu
End If
continu:
ChDrive "c"
ChDir "c:\ajeter" 'Indiquez le répertoire
ActiveWorkbook.SaveAs FileName:=(Nom)
'Application.Dialogs(xlDialogSaveAs).Show
'pour afficher la boîte Enregistrer sous
End If
End Sub
Autre méthode en testant l'entrée du nom
Sub Enregistre_Sous2()
Réponse = MsgBox("Voulez-vous enregistrer ce classeur ?", vbYesNo)
If Réponse = vbYes Then
Dim nom As String
Do While nom = ""
'Répète l'instruction tant qu'aucun nom est donné
nom = InputBox("Donnez un nom de fichier !" & Chr(13) & "Exemple: Rapport")
Loop
ChDrive "c"
ChDir "c:\ajeter" 'Indiquez le répertoire
ActiveWorkbook.SaveAs FileName:=(nom)
'Application.Dialogs(xlDialogSaveAs).Show
'pour afficher la boîte Enregistrer sous
End If
End Sub
Enregistre la feuille active en nouveau classeur
Sub Enregistre_1_Feuille()
ActiveSheet.Copy
Application.Dialogs(xlDialogSaveAs).Show
'Active la boite de dialogue Enregistrer sous
End Sub
Pour plusieurs feuilles:
Sheets(Array("Feuil1", "Feuil2")).Copy
Copie tous les fichiers du répertoire "AA" dans le répertoire "BB".
Il faut activer la référence "Microsoft Scripting Runtine"
Outils => Références...
Sub CopiRepert()
Dim FSO As New FileSystemObject
FSO.CopyFolder "C:\AA", "C:\BB"
End Sub
Quel est le dernier document que j'ai modifié hier ?
Changez le répertoire dans cette ligne:
.LookIn = "C:\mes fichiers"
Sub LastModif()
With Application.FileSearch
.NewSearch
.LookIn = "C:\mes fichiers"
.SearchSubFolders = True
.LastModified = msoLastModifiedYesterday
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles
If .Execute() > 0 Then
MsgBox "Ce dossier contient " & .FoundFiles.Count & " fichier(s) modifié(s)."
For i = 1 To .FoundFiles.Count
MsgBox .FoundFiles(i)
Next i
Else
MsgBox "Aucun fichier modifié."
End If
End With
End Sub
Quel est la taille du fichier ?
Renvoie la taille du fichier en octets
Sub Taillefile()
Dim SizeFile
SizeFile = FileLen("c:\ajeter\classeur1.xls")
MsgBox "Taille du fichier " & SizeFile & " octets"
'du classeur actif
MsgBox FileLen(ThisWorkbook.FullName) & " octets"
End Sub
Comment récupérer le chemin complet d'un répertoire et l'enregistrer dans un fichier texte?
Ce qui évite d'avoir à taper tout le chemin à la main !
surtout lorsqu'il s'agit de récuperer le chemin des dossiers d'Outlook Express
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Range("A1") = GetDirectory
Else
GetDirectory = ""
End If
End Function
Sub appel()
Range("A1").ClearContents
Msg = "Selection de la directory désirée"
ChDir GetDirectory(Msg)
Var = [A1]
FichierTXT = "C:\ajeter\path.txt" 'à modifier
If Len(Dir(FichierTXT)) > 1 Then Kill FichierTXT
Open FichierTXT For Output As 1
Print #1, Var
Close
End Sub
Récupération du chemin 2éme méthode
Sub SelDossier()
Dim objShell, objFolder, chemin
Set objShell = CreateObject("Shell.Application")
Set objFolder =objShell.BrowseForFolder(&H0&, "Sélection d'un dossier", &H1&)
On Error Resume Next
chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
MsgBox chemin
End Sub
Comment avoir la liste et les valeurs des propriétes du fichier ?
Sub lstProprieteFichier()
lg = 1
Worksheets.Add
For Each LstPro In ActiveWorkbook.BuiltinDocumentProperties
Cells(lg, 1).Value = LstPro.Name
On Error Resume Next
Cells(lg, 2).Value = ActiveWorkbook.BuiltinDocumentProperties.Item(LstPro.Name)
lg = lg + 1
Next
Columns("A:A").EntireColumn.AutoFit
Range("B10:B12").NumberFormat = "[$-F800]dddd, mmmm dd, yyyy"
End Sub
Comment créer un dossier ?
Ajouter une référence à "Microsoft Scripting Runtime"
depuis le menu Projet à Références de l'Editeur Visual Basic.
Sub CreationDossier()
Dim fso ' As Scripting.FileSystemObject
Dim fd ' As Scripting.Folder
Dim sFolderName ' As String
' Initialisation du nom du dossier
sFolderName = "C:\NewDossier"
Set fso = CreateObject("Scripting.FileSystemObject")
' Vérifier que le dossier à créer n'existe pas
If Not fso.FolderExists(sFolderName) Then
' Créer le dossier.
Set fd = fso.CreateFolder(sFolderName)
MsgBox "Le dossier " & sFolderName & " a été créé"
Else
MsgBox "Le dossier " & sFolderName & " existe déjà!"
End If
End Sub
Comment supprimer ce dossier ?
Sub SuppressioDossier()
Dim fso ' As Scripting.FileSystemObject
Dim fd ' As Scripting.Folder
Dim sFolderName ' As String
' Initialisation du nom du dossier
sFolderName = "C:\NewDossier"
Set fso = CreateObject("Scripting.FileSystemObject")
' Vérifier que le dossier à supprimer existe bien
If fso.FolderExists(sFolderName) Then
Set fd = fso.GetFolder(sFolderName)
fd.Delete
MsgBox "Le dossier " & sFolderName & " a été supprimé"
Else
MsgBox "Le dossier " & sFolderName & " n'existe pas"
End If
End Sub
Comment renommer ce dossier ?
Sub RenommerDossier()
Dim fso ' As Scripting.FileSystemObject
Dim fd ' As Scripting.Folder
Dim s ' As String
Dim sFolderName ' As String
Dim sNewName ' As String
Dim sTemp ' As String
' Initialisation des noms de dossiers
sFolderName = "C:\NewDossier"
sNewName = "LeDossier"
Set fso = CreateObject("Scripting.FileSystemObject")
' Vérifier que le dossier source existe bien.
If fso.FolderExists(sFolderName) Then
' Récupérer l'instance du dossier.
Set fd = fso.GetFolder(sFolderName)
sTemp = fd.Drive & "\" & sNewName
' Vérifier que le dossier cible n'existe pas déjà.
If fso.FolderExists(sTemp) Then
MsgBox "Ce nom de dossier existe déjà!"
Else
fd.Name = sNewName
MsgBox "Le dossier " & sFolderName & " a été renommé!"
End If
Else
MsgBox "Dossier non trouvé!"
End If
End Sub
Comment rechercher les fichiers XLB et en avoir la liste?
Valable pour toutes sortes de fichiers aussi !
Sub ChercheXLB()
typeFile = InputBox("Quel type de fichier? " & Chr(13) & "Taper l'extension ! Ex: xlB")
Worksheets.Add
ActiveSheet.Name = "Liste des fichiers" & " " & typeFile
[A1].Value = "Liste des fichiers" & " " & typeFile
Selection.Font.Bold = True
Dim LstFile As Long
With Application.FileSearch
.Filename = "*." & typeFile
.LookIn = "C:\"
.SearchSubFolders = True
For LstFile = 1 To .Execute(msoSortByFileName)
ActiveSheet.Cells(LstFile + 1, 1).Value = .FoundFiles(LstFile)
Next LstFile
End With
End Sub
Comment ouvrir un fichier TXT,CSV, HTM ... avec le bloc-note (Notepad) ?
Sub OuvreTXT()
lanceur = Shell ("C:\windows\notepad.exe c:\ajeter\lefichier.txt", 1)
End Sub
'OPTION de FENETRE
'vbHide - 0 - La fenêtre est masquée et activée.
'vbNormalFocus - 1 - La fenêtre est rétablie à sa taille et à sa position d'origine.
'vbMinimizedFocus - 2 - La fenêtre est affichée sous forme d'icône et activée.
'vbMaximizedFocus - 3 - La fenêtre est agrandie et activée.
'vbNormalNoFocus - 4 - La fenêtre est rétablie à sa taille et à sa position les plus récentes
'vbMinimizedNoFocus - 6 - La fenêtre est affichée sous forme d'icône.
Ce fichier existe-t'il ?
Sub Existe()
If Dir$("c:\ajeter\test.xls") = "" Then
MsgBox " Pas trouvé ce fichier :O("
Else
MsgBox " OK ! Trouvé :O)"
End If
End Sub
[top]
|
