Auteur :
| Version : 28/01/2005 | | |
| | Versions : 97 et supérieures
Pour que ce code fonctionne correctement, vous devez référencer la librairie Microsoft Scripting Runtime (scrrun.dll).
Dim fs As FileSystemObject
dim f as TextSream
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.opentextfile("c:\CopyDB.bat", 2, True)
f.write "copy " & CurrentDb.Name & " destination"
f.Close
Shell "c:\CopyDB.bat" |
|
Auteur : Tofalu
| Version : 28/01/2005 | | |
| | Versions : 97 et supérieures
Dans un module : Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" _
(ByVal lpFileName As String) As Long
Function CopierColler(Source as string,Destination as String, _
NePasEcraser as long) as long
CopierColler = CopyFile(Source, Destination, NePasEcraser)
End Function
Function CouperColler(Source as string,Destination as String, _
NepasEcraser as long) as long
Dim r as long
r = CopyFile(Source, Destination, NePasEcraser)
if r then CouperColler=DeleteFile(Source)
CouperColler=r
End Function |
Définition des paramètres :
- Source : Source de la copie
- Destination : Destination de la copie
- NePasEcraser : Si ce paramètre vaut zéro, la copie écrase un fichier de même nom s'il existe.
Les fonctions retournent 0 en cas d'échec de l'opération.
Utilisation : CouperColler("D:\test.txt","d:\test2.txt",0) |
Copie test.txt en test2.txt ( en l'écrasant s'il existe déjà), puis supprime test.txt
|
| | Versions : 97 et supérieures
Cet exemple permet de créer un nouveau type de fichier, lui associer un programme et une icône. Ainsi, lorsque l'utilisateur double cliquera sur un de ces fichiers, il sera automatiquement ouvert avec les paramètres renseignés précédemment grâce à ce code.
Le code en lui même est assez simple, il ne s'agit que d'une suite d'insertion de clés et de valeurs dans le registre.
Dans un module, placer le code suivant : Public Type FileType
Name As String
Extension As String
IconPath As String
ExePath As String
End Type
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const REG_SZ = 1
Public Const MAX_PATH = 255
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" ( _
ByVal Hkey As Long, _
ByVal lpSubKey As String, _
phkResult As Long) As Long
Public Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueExA" ( _
ByVal Hkey As Long, _
ByVal lpValueName As String, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
lpData As Any, _
ByVal cbData As Long) As Long
Public Sub Associate(file As FileType)
Dim temp, result, result2 As Long
temp = RegCreateKey(HKEY_CLASSES_ROOT, file.Extension, result)
temp = RegSetValue(result, "", 0, REG_SZ, ByVal file.Name, Len(file.Name))
temp = RegCreateKey(HKEY_CLASSES_ROOT, file.Name, result)
temp = RegCreateKey(result, "DefaultIcon", result2)
temp = RegSetValue(result2, "", 0, REG_SZ, ByVal file.IconPath, MAX_PATH)
temp = RegCreateKey(result, "shell\open\command", result2)
temp = RegSetValue(result2, "", 0, REG_SZ, ByVal file.ExePath, MAX_PATH)
End Sub |
Puis, par exemple sur un bouton : Dim NewFile As FileType
NewFile.Name = "Fichier texte"
NewFile.Extension = ".txt"
NewFile.IconPath = "c:\monicone.ico"
NewFile.ExePath = "c:\windows\notepad.exe"
Associate NewFile |
|
Auteur : Shwin
| Version : 28/01/2005 | | |
| | Versions : 97 et supérieures
Private Declare Function InternetCloseHandle Lib "wininet.dll" _
(ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, _
ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias _
"FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" _
(ByVal hConnect As Long, ByVal lpszRemoteFile As String, _
ByVal lpszNewFile As String, ByVal fFailIfExists As Long, _
ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, _
ByRef dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias _
"FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, _
ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Private Sub Commande27_Click()
Dim HwndConnect As Long
Dim HwndOpen As Long
HwndOpen = InternetOpen("SiteWeb", 0, vbNullString, vbNullString, 0)
HwndConnect = InternetConnect(HwndOpen, "<ftp>", <port>, _
"<username>", "<password>", 1, 0, 0)
FtpSetCurrentDirectory HwndConnect, "page_web/documents"
FtpGetFile HwndConnect, "test.txt", "C:\WINDOWS\Bureau\test.txt", _
False, 0, &H0, 0
FtpPutFile HwndConnect, "C:\windows\bureau\test.txt", "shwin.txt", &H0, 0
InternetCloseHandle HwndConnect
InternetCloseHandle HwndOpen
End Sub |
|
| | Attention, pour fonctionner ce code nécessite la référence Microsoft Scripting Runtime.
Cet exemple de code montre la marche à suivre pour manipuler les fichiers textes. N'hésitez surtout pas à télecharger le fichier source au format zip.
Nous utilisons ici plusieurs contrôles :
- TFichier : une zone de texte contenant le nom du fichier
- TLigne : une zone de texte dont le contenu sera écrit dans un fichier
- TTexte : une zone de texte qui affichera le contenu du fichier
- BOuvrir : un bouton pour selectionner le nom du fichier
- BAjout : un bouton qui envoit la ligne selectionnée dans le fichier
- TEcraser : une zone de liste contenant (Ajouter;Ecraser) pour savoir si on ajoute au fichier ou si on ecrase le contenu.
Créer un fichier texte : Private Function creerfichier() As String
On Error GoTo err
Dim FSO As New Scripting.FileSystemObject
Dim FichText As Scripting.TextStream
Dim Fichier As String
Fichier = EnregistrerUnFichier(Me.hwnd, _
"Enregistrer", "MonFichier.txt", CurrentProject.Path)
If Fichier <> "" Then
Set FichText = FSO.CreateTextFile(Fichier, True)
TFichier = Fichier
creerfichier = Fichier
End If
GoTo fin
err:
MsgBox "Impossible de créer le fichier", vbCritical, _
"Erreur"
fin:
Set FSO = Nothing
Set FichText = Nothing
End Function |
La fonction EnregistrerUnFichier est disponible dans la FAQ Access.
Ecrire une ligne dans un fichier texte : Private Sub EcrireLigne(Fichier As String, _
Ligne As String, ecraser As Boolean)
On Error GoTo err
Dim FSO As New Scripting.FileSystemObject
Dim FichText As Scripting.TextStream
If ecraser Then
Set FichText = FSO.OpenTextFile(Fichier, ForWriting)
Else
Set FichText = FSO.OpenTextFile(Fichier, ForAppending)
End If
FichText.WriteLine (Ligne)
GoTo fin
err:
MsgBox "Impossible d'ecrire le fichier texte", vbCritical, vbCritical, _
"Erreur"
fin:
Set FSO = Nothing
Set FichText = Nothing
End Sub |
Lire un fichier texte : Private Sub Bouvrir_Click()
On Error GoTo err
Dim Fichier As String
Fichier = OuvrirUnFichier(Me.hwnd, "Ouvrir un fichier texte", _
1, "Fichier Texte", "txt")
If Fichier <> "" Then
TFichier = Fichier
lirefichier (Fichier)
End If
Exit Sub
err:
MsgBox "Impossible d'ouvrir le fichier", vbCritical, _
"Erreur"
End Sub
Private Sub lirefichier(Nom As String)
On Error GoTo err
Dim FSO As New Scripting.FileSystemObject
Dim FichText As Scripting.TextStream
Set FichText = FSO.OpenTextFile(Nom, ForReading)
TTexte = FichText.ReadAll
GoTo fin
err:
MsgBox "Impossible de lire le fichier", vbCritical, _
"Erreur de lecture"
fin:
Set FichText = Nothing
Set FSO = Nothing
End Sub |
La fonction OuvrirUnFichier est disponible dans la FAQ Access ainsi que dans le fichier source zippé.
|
| | Versions : 2000 et supérieures
L'objet Office FileSearch permet de faire une recherche de fichiers d'un certain type en utilisant la propriété FileType mais les constantes acceptées (MsoFileType) ne sont parfois pas suffisantes : par exemple si l'on souhaite rechercher uniquement des fichiers de type audio (.mp3, .wav etc...).
On peut donc utiliser la fonction suivante pour laquelle il faut créer une table Listage_fichier avec le détail suivant :
1 champ "chemin" texte(255)
1 champ "fichier" texte (255)
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"_
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const TABLE_FILE = "Listage_fichier"
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
StripNulls = OriginalStr
End Function
Function FindFilesAPI(path As String, searchstr As String, filecount As Long, _
dircount As Long, sub_dir As Boolean)
Dim filename As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim rs As DAO.Recordset
Set rs = CurrentDB.OpenRecordset("SELECT * from listage_fichier")
If Right$(path, 1) <> "\" Then path = path & "\"
If sub_dir Then
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = StripNulls(WFD.cFileName)
If (DirName <> ".") And (DirName <> "..") Then
If GetFileAttributes(path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
dirNames(nDir) = DirName
dircount = dircount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
Cont = FindNextFile(hSearch, WFD)
Loop
Cont = FindClose(hSearch)
End If
End If
hSearch = FindFirstFile(path & searchstr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
filename = StripNulls(WFD.cFileName)
If (filename <> ".") And (filename <> "..") Then
FindFilesAPI = FindFilesAPI + (WFD.nFileSizeHigh * MAXDWORD) _
+ WFD.nFileSizeLow
filecount = filecount + 1
rs.AddNew
rs![chemin] = path
rs![fichier] = filename
rs.Update
End If
Cont = FindNextFile(hSearch, WFD)
Wend
Cont = FindClose(hSearch)
End If
If nDir > 0 Then
For i = 0 To nDir - 1
FindFilesAPI = FindFilesAPI + FindFilesAPI(path & _
dirNames(i) & "\", searchstr, filecount, dircount, sub_dir)
Next i
End If
End Function |
Dans un formulaire :
- filecount et dircount sont des variables de retour (il ne faut donc pas passer leur valeur directement, ici il faut déclarer des variables type Long).
- sub_dir = true si vous voulez regarder dans les sous-repertoires, et false dans le cas contraire. Private Sub recherchemp3_Click()
Dim path As String
Dim searchstr As String
Dim filecount As Long
Dim dircount As Long
Dim sub_dir As Boolean
path = "d:\"
searchstr = "*.txt"
sub_dir = True
DoCmd.SetWarnings False
CurrentDB.Execute ("DELETE * FROM Listage_fichier")
DoCmd.SetWarnings True
Call FindFilesAPI(path, searchstr, filecount, dircount, sub_dir)
End Sub |
La liste des fichiers trouvés est stockée dans la table Listage_fichier
|
| | Versions : 2000 et supérieures
Ce code permet de rechercher un fichier dans un répertoire ou dans un disque complet. Il propose à la fois de choisir le repertoire, d'inclure les sous répertoires de la recherche et de combiner les caractères génériques (tels que *) pour une recherche partielle.
Afin de faire fonctionner ce code, vous devez ajouter la référence Microsoft Scripting Runtime à votre projet.
Code de la recherche : Private Function ScanFolder(FolderPath As String, _
Optional Filename As String = "", _
Optional SubFold As Boolean = True) As Long
On Error Resume Next
Dim Element As Variant
Dim StrPath() As String
ScanFolder = fs.GetFolder(FolderPath).Files.Count
For Each Element In fs.GetFolder(FolderPath).Files
If Stopper Then Exit Function
EResultat.Caption = FolderPath
If Filename <> "" Then
StrPath = Split(Element, "\")
If StrPath(UBound(StrPath)) Like Filename Then
Listeresultat.RowSource = Listeresultat.RowSource & Element & ";"
End If
Else
Listeresultat.RowSource = Listeresultat.RowSource & Element & ";"
End If
DoEvents
Next Element
If SubFold Then
For Each Element In fs.GetFolder(FolderPath).SubFolders
ScanFolder = ScanFolder + ScanFolder(Element.Path, _
Filename, SubFold)
Next Element
End If
End Function |
Principe de fonctionnement :
Le principe est assez simple, on appelle une première fois la fonction en lui passant les paramètres suivant : chemin de recherche, nom du fichier, et un booléen (SubFold) pour savoir s'il on doit inclure les sous-dossiers. Dans une première phase, la fonction examine chaque fichier et si le nom correspond à celui saisit, alors ce nom est ajouté à une zone de liste. Cet ajout est fait en complétant la propriété RowSource de la zone de liste. Dans une seconde phase, si SubFold est vrai, la fonction est rappelée pour chaque sous dossier avec comme paramètre : le chemin du sous dossier, le nom du fichier et le booléen SubFold. Et ainsi de suite pour chaque dossier du sous dossier concerné. Un autre avantage de cette fonction c'est quelle renvoit le nombre de fichiers parcourus. Ceci peut être trés utile pour effectuer des statistiques.
N'hésitez pas à télecharger le fichier de démonstration pour visualiser le résultat obtenu.
|
| |
Cette fonction permet de trouver le premier fichier qui porte le nom passé en paramètre. La recherche se fait dans toute l'arborescence à partir de la racine qui figure dans l'argument root. Cette fonction peut s'avérer trés utile pour rechercher un fichier dans un ensemble de sous-répertoires. Le seul frein à son utilisation est le fait que la rechercher s'arrête dés le premier fichier trouvé.
Dans un module : Private Declare Function SearchTreeForFile _
Lib "imagehlp" (ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
Public Function chercherFichier(NomFichier As String, _
Root As String)
Dim NomFichier As String, Resultat As Long
tempStr = String(260, 0)
Resultat = SearchTreeForFile(Root, NomFichier, Temp)
If Resultat <> 0 Then _
chercherFichier = Left$(NomFichier, InStr(1, NomFichier, Chr$(0)) - 1)
End Function |
Utilisation :
Msgbox ChercherFichier("Excel.exe","C:\") |
Affiche le chemin d'accés du logiciel Excel.
|
| | Versions : 97 et supérieures
Dans un module, placez le code suivant :
Private Const OF_SHARE_DENY_WRITE As Long = &H20
Private Type AVIFileInfo
dwMaxBytesPerSec As Long
dwFlags As Long
dwCaps As Long
dwStreams As Long
dwSuggestedBufferSize As Long
dwWidth As Long
dwHeight As Long
dwScale As Long
dwRate As Long
dwLength As Long
dwEditCount As Long
szFileType As String * 64
End Type
Private Declare Function AVIFileOpen Lib "avifil32" Alias _
"AVIFileOpenA" (ppfile As Long, ByVal szFile As String, _
ByVal mode As Long, pclsidHandler As Any) As Long
Private Declare Function AVIFileRelease Lib "avifil32" _
(ByVal pfile As Long) As Long
Private Declare Function AVIFileInfo Lib "avifil32" Alias _
"AVIFileInfoA" (ByVal pfile As Long, pfi As AVIFileInfo, _
ByVal lSize As Long) As Long
Private Declare Sub AVIFileInit Lib "avifil32" ()
Private Declare Sub AVIFileExit Lib "avifil32" ()
Public Function InformationAVI(NomFichierAVI As String) _
As String
Dim hFile As Long, AviInfo As AVIFileInfo
Dim Reponse As String
AVIFileInit
If AVIFileOpen(hFile, NomFichierAVI, _
OF_SHARE_DENY_WRITE, ByVal 0&) = 0 Then
If AVIFileInfo(hFile, AviInfo, Len(AviInfo)) = 0 Then
Reponse = "Nom du fichier : " & NomFichierAVI & vbCrLf
Reponse = Reponse & "Dimensions : " & CStr(AviInfo.dwWidth) & _
"x" & CStr(AviInfo.dwHeight) & vbCrLf
Reponse = Reponse & "Durée : " & CStr(AviInfo.dwLength) & _
" Secondes"
Else
Reponse = "Impossible d'obtenir les informations."
End If
AVIFileRelease hFile
Else
Reponse = "Impossible d'accéder au fichier"
End If
AVIFileExit
InformationAVI = Reponse
End Function |
Utilisation : MsgBox InformationAVI("C:\WINDOWS\clock.avi"), _
vbInformation, "Info AVI" |
Ceci affiche une fenêtre avec le nom du fichier, ses dimensions ainsi que sa longueur.
Vous remarquerez que bien d'autres informations sont disponibles, comme par exemple le nombre de bytes par seconde :
dwMaxBytesPerSec
|
Auteur : Shwin
| Version : 28/01/2005 | | |
| | Versions : 97 et supérieures
La vitesse d'exécution est sensiblement la même que la fonction .fileExists de la référence "Microsoft Scripting Runtime", sauf que que cette méthode évite d'avoir à utiliser une référence externe. Qui plus est, elle est plus rapide que la fonction dir sur des traitements réccurents puisque cette fonction vise le fichier et s'arrète dés qu'elle le trouve alors que la fonction dir parcourt tout le répertoire même si le fichier a déjà été trouvé.
Public Const INVALID_HANDLE_VALUE = -1
Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Public Function FileExists(source As String) As Boolean
Dim lpFindFileData As WIN32_FIND_DATA
Dim hFindFile As Long
hFindFile = FindFirstFile(source, lpFindFileData)
FileExists = hFindFile <> INVALID_HANDLE_VALUE
FindClose (hFindFile)
End Function |
Utilisation : msgbox fileExists("C:\fichier.ext") |
|
| | Versions : 97 et supérieures
Cette méthode permet de simuler l'appui de n'importe quelle touche. Le nombre passé en paramètre correspond au KeyCode de la touche. (par exemple, 44 pour un imprime écran)
Contrairement à l'instruction sendkeys, cette procédure permet d'appuyer et de relacher une touche ou de la laisser appuyée. Public Declare Sub keybd Lib "user32" Alias "keybd_event" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Public Sub appui_touche(T as long)
keybd T, 0, 0, 0
keybd T, 0, 2, 0
End Sub |
Pour simuler capslock, on aura : Pour simuler impr-ecran, on aura : |
Auteur : =JBO=
| Version : 12/11/2005 | | |
| |
Versions : Toutes
Un fichier ouvert en lecture seule est considéré comme fermé.
Les erreurs (fichier introuvable...) sont reportées dans la procédure appelante.
Public Function IsFileOpen(sFilePath As String) As Boolean
Dim nFile As Integer
On Error GoTo Erreur
nFile = FreeFile()
Open sFilePath For Input Access Read Lock Read Write As nFile
Close nFile
IsFileOpen = False
Exit Function
Erreur:
If Err.Number = 70 Then
IsFileOpen = True
Else
Err.Raise Err.Number, "IsFileOpen"
End If
End Function |
Exemple d'utilisation :
If IsFileOpen("C:\MonClasseur.xls") Then
Msgbox "Fichier ouvert"
End if |
|
|