| auteurs : SilkyRoad, Philben | Vba |
Sub Test ()
MsgBox FichierExiste (" C:\Documents and Settings\dossier\dataBase.mdb " )
End Sub
Function FichierExiste (NomFichier As String ) As Boolean
FichierExiste = Dir (NomFichier) < > " " And NomFichier < > " "
End Function
|
|
| auteur : SilkyRoad | Vba |
Sub Test ()
MsgBox DossierExiste (" C:\Documents and Settings\Nom Dossier " )
End Sub
Function DossierExiste (NomDossier As String ) As Boolean
DossierExiste = Dir (NomDossier, vbSystem + vbDirectory + vbHidden) < > " "
End Function
|
|
| auteur : SilkyRoad |
La procédure récupère le répertoire parent du classeur contenant cette macro.
Vba |
Sub afficherRepertoireParent ()
If ThisWorkbook. Path = " " Then
MsgBox " Est ce que votre classeur est sauvegardé? "
Exit Sub
End If
ChDir (ThisWorkbook. Path )
ChDir " .. "
MsgBox CurDir
End Sub
|
Cet exemple remonte 2 répertoires parents, par rapport au chemin du classeur contenant la macro.
Vba |
Sub afficherRepertoireParent_V02 ()
Dim Chemin As String
If ThisWorkbook. Path = " " Then
MsgBox " Est ce que votre classeur est sauvegardé? "
Exit Sub
End If
ChDir (ThisWorkbook. Path )
ChDir " .. "
Chemin = Left (CurDir, InStrRev (CurDir, " \ " ) - 1 )
MsgBox Chemin
End Sub
|
|
| auteur : SilkyRoad |
Utilisez l'instruction MkDir.
Attention, un message d'erreur survient si le répertoire parent n'existe pas.
L'exemple crée un dossier "Archives" dans "C:\Documents and Settings\dossier".
Vba |
Sub Test ()
CreationRepertoire " C:\Documents and Settings\dossier " , " Archives "
End Sub
Sub CreationRepertoire (DossierParent As String , NomRep As String )
Dim Chemin As String
If Dir (DossierParent, vbDirectory + vbHidden) < > " " Then
If Dir (DossierParent & " \ " & NomRep, vbDirectory + vbHidden) = " " Then _
MkDir DossierParent & " \ " & NomRep
End If
End Sub
|
|
| auteur : SilkyRoad |
4 méthodes sont ici proposées:
Vba |
Sub repertoireExplorateur_V1 ()
Dim Chemin As String
Chemin = " C:\Documents and Settings\dossier "
Shell " C:\windows\explorer.exe " & Chemin, vbMaximizedFocus
End Sub
|
Vba |
Sub repertoireExplorateur_V2 ()
Dim Chemin As String
Chemin = " C:\Documents and Settings\dossier "
ThisWorkbook. FollowHyperlink Chemin
End Sub
|
Vba |
Sub repertoireExplorateur_V3 ()
Dim Chemin As String
Dim IE As Object
Chemin = " C:\Documents and Settings\dossier "
Set IE = CreateObject (" internetExplorer.Application " )
IE. Navigate Chemin
IE. Visible = True
End Sub
|
Vba |
Sub repertoireExplorateur_V4 ()
Dim objShell As Shell
Dim Chemin As String
Chemin = " C:\Documents and Settings\dossier "
Set objShell = New Shell
objShell. Explore (Chemin)
End Sub
|
|
| auteur : SilkyRoad | Vba |
Sub BoucleFichiers ()
Dim Chemin As String , Fichier As String
Chemin = " C:\dossier\ "
Fichier = Dir (Chemin & " *.xls " )
Do While Len (Fichier) > 0
Debug. Print Chemin & Fichier
Fichier = Dir ()
Loop
End Sub
|
|
| auteur : Random | Vba |
Sub Test_V1 ()
MsgBox NombreFichiers (" C:\dossier " )
End Sub
Function NombreFichiers (ByVal Dossier As String ) As Long
Dim FSO As Object
Set FSO = CreateObject (" Scripting.FileSystemObject " )
NombreFichiers = FSO. GetFolder (Dossier). Files . Count
Set FSO = Nothing
End Function
|
Ce deuxième code permet de définir les extensions de fichier à compter.
Vous pouvez indiquer autant d'extensions que vous voulez.
Vba |
Sub Test_V2 ()
MsgBox NbFich (" C:\dossier " , " * " )
MsgBox NbFich (" C:\dossier " , " txt " , " xls " )
End Sub
Function NbFich (Chemin As String , ParamArray Termin () As Variant) As Long
Dim Fichier As String
Dim Extension As Variant
Dim Compteur As Long
For Each Extension In Termin
Fichier = Dir (Chemin & " \*. " & Extension)
Do Until Fichier = " "
Compteur = Compteur + 1
Fichier = Dir
Loop
Next Extension
NbFich = Compteur
End Function
|
|
| auteur : SilkyRoad |
Utilisez l'instruction Name.
Cette instruction permet aussi de renommer les répertoires.
Remarque:
Une erreur survient si le fichier à renommer est déjà ouvert.
Vba |
Sub RenommeFichier ()
Dim AncienNom As String , NouveauNom As String
AncienNom = " C:\Documents and Settings\dossier\NomInitial.pdf "
NouveauNom = " C:\Documents and Settings\dossier\Nom modifié.pdf "
If Dir (AncienNom) = " " Then Exit Sub
Name AncienNom As NouveauNom
End Sub
|
|
| auteur : SilkyRoad | Vba |
Option Explicit
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Const GENERIC_WRITE = & H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = & H1
Private Const FILE_SHARE_WRITE = & H2
Private Declare Function CreateFile Lib " kernel32 " Alias " CreateFileA " _
(ByVal lpFileName As String , ByVal dwDesiredAccess As Long, ByVal _
dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes _
As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function SetFileTime Lib " kernel32 " (ByVal hFile As Long, _
lpCreationTime As FILETIME, _
lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib " kernel32 " _
(lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long
Private Declare Function CloseHandle Lib " kernel32 " _
(ByVal hObject As Long) As Long
Private Declare Function LocalFileTimeToFileTime Lib " kernel32 " _
(lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
Sub Test ()
Dim m_Date As Date
Dim lngHandle As Long
Dim udtFileTime As FILETIME
Dim udtLocalTime As FILETIME
Dim udtSystemTime As SYSTEMTIME
Dim Fichier As String
Fichier = " C:\dossier\nom fichier.txt "
m_Date = Format (Now , " DD-MM-YY " )
udtSystemTime. wYear = Year (m_Date)
udtSystemTime. wMonth = Month (m_Date)
udtSystemTime. wDay = Day (m_Date)
udtSystemTime. wDayOfWeek = Weekday (m_Date) - 1
udtSystemTime. wHour = Hour (m_Date)
udtSystemTime. wSecond = Second (m_Date)
udtSystemTime. wMilliseconds = 0
SystemTimeToFileTime udtSystemTime, udtLocalTime
LocalFileTimeToFileTime udtLocalTime, udtFileTime
lngHandle = CreateFile (Fichier, GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0 & , OPEN_EXISTING, 0 , 0 )
SetFileTime lngHandle, udtFileTime, udtFileTime, udtFileTime
CloseHandle lngHandle
End Sub
|
|
| auteur : SilkyRoad |
En VBA, l'instruction Kill permet de supprimer un fichier, mais celui est alors définitivement effacé de votre PC.
Le code suivant transfère le fichier dans la corbeille et il peut donc être récupéré en cas d'erreur.
Utilisez .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION pour ne pas afficher le message confirmation de la suppression du fichier.
Vba |
Option Explicit
Private Type StructureFichier
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Private Declare Function SHFileOperation Lib " shell32.dll " Alias _
" SHFileOperationA " (lpFileOp As StructureFichier) As Long
Private Const FO_DELETE = & H3
Private Const FOF_ALLOWUNDO = & H40
Private Const FOF_NOCONFIRMATION = & H10
Sub Test ()
EnvoiCorbeille " C:\dossier\NomFichier.xls "
End Sub
Function EnvoiCorbeille (Fichier As String ) As Boolean
Dim Cible As StructureFichier
Dim lReturn As Long
If Dir (Fichier) = " " Then Exit Function
With Cible
. wFunc = FO_DELETE
. pFrom = Fichier
. fFlags = FOF_ALLOWUNDO
End With
lReturn = SHFileOperation (Cible)
End Function
|
|
| auteur : SilkyRoad |
Cet exemple affiche le chemin de "Mes documents".
Adaptez la valeur de la constante en fonction du répertoire à identifier.
Vba |
Sub CheminRepertoiresSpeciaux ()
Const Cible = & H5
Dim objShell As Object
Dim objFolder As Object, objFolderItem As Object
Set objShell = CreateObject (" Shell.Application " )
Set objFolder = objShell. NameSpace (Cible)
Set objFolderItem = objFolder. Self
MsgBox objFolderItem. Path
End Sub
|
|
| auteur : SilkyRoad |
Remarque:
Cet exemple ne boucle pas sur les sous dossiers complets éventuellement contenus dans la corbeille.
Vba |
Sub tailleElementsCorbeille ()
Dim objShell As Object, objFolder As Object, colItems As Object, objItem As Object
Dim tailleGDO As String
Dim Taille As Long, Resultat As Long
Const Cible = & HA&
Set objShell = CreateObject (" Shell.Application " )
Set objFolder = objShell. Namespace (Cible)
Set colItems = objFolder. Items
For Each objItem In colItems
tailleGDO = objFolder. GetDetailsOf (objItem, 3 )
Resultat = Resultat + CLng (Val (tailleGDO))
Next
MsgBox Resultat & " kb "
End Sub
|
|
| auteur : SilkyRoad |
Sélectionnez n'importe quel type de fichier à partir de la boîte de dialogue (GetOpenFileName).
La procédure va ensuite récupérer le nom de l'exécutable associé à ce fichier et retourner des informations sur
le programme, notamment:
Le nom de l'éditeur
La description du programme
La version du fichier
Le nom interne
Le copyright
Le nom de l'application
Le nom du produit
La version du produit
Testé sous XL97,XL2000,XL2002
Vba |
Option Explicit
Private Declare Function GetFileVersionInfo Lib " Version.dll " Alias _
" GetFileVersionInfoA " (ByVal lptstrFilename As String , ByVal dwHandle As Long, _
ByVal dwLen As Long, lpData As Any) As Long
Private Declare Function _
GetFileVersionInfoSize Lib " Version.dll " Alias " GetFileVersionInfoSizeA " _
(ByVal lptstrFilename As String , lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib " Version.dll " Alias " VerQueryValueA " _
(pBlock As Any, ByVal lpSubBlock As String , lplpBuffer As Any, puLen As Long) As Long
Private Declare Sub MoveMemory Lib " kernel32 " Alias " RtlMoveMemory " (dest As Any, _
ByVal Source As Long, ByVal Length As Long)
Private Declare Function lstrcpy Lib " kernel32 " Alias " lstrcpyA " _
(ByVal lpString1 As String , ByVal lpString2 As Long) As Long
Public Declare Function FindExecutableA Lib " shell32.dll " (ByVal lpFile As String , _
ByVal lpdirectory As String , ByVal lpResult As String ) As Long
Public Const MAX_FILENAME_LEN = 256
Public Function DescriptionAppli (ByVal Cible As String , _
ByVal TypeInfo As String ) As String
Dim Buffer As String , Lang_Charset_String As String
Dim Rc As Long, HexNumber As Long, P As Long
Dim strVersionInfo As String , strTemp As String
Dim BufferLen As Long, Dummy As Long
Dim sBuffer () As Byte
Dim ByteBuffer (255 ) As Byte
strVersionInfo = TypeInfo
BufferLen = GetFileVersionInfoSize (Cible, Dummy)
If BufferLen < 1 Then Exit Function
ReDim sBuffer (BufferLen)
Rc = GetFileVersionInfo (Cible, 0 & , BufferLen, sBuffer (0 ))
If Rc = 0 Then
DescriptionAppli = False
Exit Function
End If
Rc = _
VerQueryValue (sBuffer (0 ), " \VarFileInfo\Translation " , P, BufferLen)
If Rc = 0 Then Exit Function
MoveMemory ByteBuffer (0 ), P, BufferLen
HexNumber = ByteBuffer (2 ) + ByteBuffer (3 ) * & H100 + ByteBuffer (0 ) * _
& H10000 + ByteBuffer (1 ) * & H1000000
Lang_Charset_String = Hex (HexNumber)
Do While Len (Lang_Charset_String) < 8
Lang_Charset_String = " 0 " & Lang_Charset_String
Loop
Buffer = String (255 , 0 )
strTemp = " \StringFileInfo\ " & Lang_Charset_String & " \ " & strVersionInfo
Rc = VerQueryValue (sBuffer (0 ), strTemp, P, BufferLen)
If Rc = 0 Then Exit Function
lstrcpy Buffer, P
Buffer = Mid $(Buffer, 1 , InStr (Buffer, Chr (0 )) - 1 )
DescriptionAppli = Buffer
End Function
Function FindExecutable (s As String ) As String
Dim i As Integer
Dim S2 As String
S2 = String (MAX_FILENAME_LEN, 32 ) & Chr $(0 )
i = FindExecutableA (s & Chr $(0 ), vbNullString , S2)
If i > 32 Then
FindExecutable = Left $(S2, InStr (S2, Chr $(0 )) - 1 )
Else
FindExecutable = " "
End If
End Function
Sub AfficherInformationsApplication ()
Dim Resultat As String , MonAppli As String , LeFichier As String
Dim X As Variant
Dim Tableau As Variant
Dim i As Byte
Tableau = Array (" Name " , " comments " , " CompanyName " , " FileDescription " , _
" FileVersion " , " InternalName " , " LegalCopyright " , " legalTrademarks " , _
" privateBuild " , " OriginalFileName " , " ProductName " , _
" productVersionNum " , " ProductVersion " )
X = Application. GetOpenFilename
If X = False Then Exit Sub
LeFichier = X
MonAppli = FindExecutable (LeFichier)
For i = 0 To 12
Resultat = Resultat & Tableau (i) & " : " & _
DescriptionAppli (MonAppli, Tableau (i)) & vbLf
Next i
MsgBox Resultat, , " Informations : " & MonAppli
End Sub
|
|
| auteur : SilkyRoad |
La procédure liste les fichiers d'un répertoire par ordre décroissant de création.
Vous trouverez en commentaire les paramètres pour utiliser la date de
dernière modification des fichiers.
Vba |
Option Explicit
Sub triDecroissant_Fichiers_DateDreation ()
Dim Fichier As String , Chemin As String
Dim Fso As Scripting. FileSystemObject
Dim FileItem As Scripting. File
Dim Tableau ()
Dim Plage As Range
Dim m As Integer, i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Chemin = " C:\Documents and Settings\dossier "
Fichier = Dir (Chemin & " \*.* " )
Do
m = m + 1
ReDim Preserve Tableau (1 To 2 , 1 To m)
Tableau (1 , m) = Fichier
Set Fso = CreateObject (" Scripting.FileSystemObject " )
Set FileItem = Fso. GetFile (Chemin & " \ " & Fichier)
Tableau (2 , m) = Left (FileItem. DateCreated , 10 )
Fichier = Dir
Loop Until Fichier = " "
Do
Valeur = 0
For i = 1 To m - 1
If CDate (Tableau (2 , i)) < CDate (Tableau (2 , i + 1 )) Then
For z = 1 To 2
Cible = Tableau (z, i)
Tableau (z, i) = Tableau (z, i + 1 )
Tableau (z, i + 1 ) = Cible
Next z
Valeur = 1
End If
Next i
Loop While Valeur = 1
Set Plage = Worksheets (" Feuil2 " ). Range (" A1 " )
Set Plage = Plage. Resize (UBound (Tableau (), 2 ), UBound (Tableau ()))
Plage = Application. Transpose (Tableau ())
End Sub
|
|
| auteur : SilkyRoad |
Vous pouvez utiliser l'instruction FileCopy.
Le fichier à copier doit impérativement être fermé sinon une erreur se produit.
Vba |
Sub CopierFichier ()
FileCopy " C:\dossier\general\excel\Classeur.xls " , " D:\Classeur.xls "
End Sub
|
|
| auteur : SilkyRoad |
La procédure permet d'obtenir la liste des répertoires en réseau ainsi que leus nom UNC
(Universal Naming Convention qui est utilisé ainsi: \\NomPcDistant\dossier\...)
Vba |
Sub listeConnexionsReseau_Et_CheminsUNC ()
Dim oNetWork As Object, objDisques As Object
Dim i As Integer
Set oNetWork = CreateObject (" WScript.Network " )
Set objDisques = oNetWork. EnumNetworkDrives
For i = 0 To objDisques. Count - 1 Step 2
Debug. Print objDisques. Item (i) & vbTab & objDisques. Item (i + 1 )
Next
End Sub
|
|
| auteur : SilkyRoad |
Cet exemple crée un raccourci sur le bureau pour le classeur contenant cette macro.
Le classeur est supposé déjà sauvegardé sur le PC.
Vba |
Sub creerRaccourciBureau ()
Dim xShell As IWshRuntimeLibrary. wshShell
Dim Raccourci As IWshRuntimeLibrary. wshShortcut
Dim dirBureau As String
Set xShell = CreateObject (" WScript.Shell " )
dirBureau = xShell. specialFolders (" Desktop " )
Set Raccourci = xShell. createShortcut (dirBureau & " \monFichier.lnk " )
Raccourci. targetPath = ThisWorkbook. FullName
Raccourci. windowStyle = 1
Raccourci. Save
End Sub
|
|
| auteur : SilkyRoad | Vba |
Declare Sub SHAddToRecentDocs Lib " shell32.dll " (ByVal uFlags As Long, _
ByVal pv As String )
Sub viderMenuDocumentsRecents ()
SHAddToRecentDocs 2 , vbNullString
End Sub
|
|
Consultez les autres F.A.Q's
Les sources présentés sur cette pages sont libre de droits,
et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs.
Copyright ©2008
Developpez LLC. Tout droits réservés Developpez LLC.
Aucune reproduction, même partielle, ne peut être faite de ce site et de
l'ensemble de son contenu : textes, documents et images sans l'autorisation
expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans
de prison et jusqu'à 300 000 E de dommages et intérets.
Cette page est déposée à la SACD.
|