IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)

Les meilleures sources Access

Les meilleures sources AccessConsultez toutes les sources

Nombre d'auteurs : 44, nombre de sources : 147, création le 19 mars 2013 

 
OuvrirSommaireDiversTraitements sur les fichiers

Versions : 97 et supérieures

Pour que ce code fonctionne correctement, vous devez référencer la librairie Microsoft Scripting Runtime (scrrun.dll).

 
Sélectionnez
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"
Créé le 28 janvier 2005  par stephane eyskens

Page de l'auteur

Versions : 97 et supérieures

Dans un module :

 
Sélectionnez
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 :


Les fonctions retournent 0 en cas d'échec de l'opération.


Utilisation :

  • 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.
 
Sélectionnez
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

Créé le 28 janvier 2005  par Tofalu

Page de l'auteur

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 :

 
Sélectionnez
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 :

 
Sélectionnez
    Dim NewFile As FileType
    NewFile.Name = "Fichier texte"
    NewFile.Extension = ".txt"
    NewFile.IconPath = "c:\monicone.ico"
    NewFile.ExePath = "c:\windows\notepad.exe"
    Associate NewFile
Créé le 5 mars 2005  par ridan

Page de l'auteur

Versions : 97 et supérieures

 
Sélectionnez
'------------------- 
'Déclaration des API 
'------------------- 
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 
 
 
 
 
'Envoi et réception d'un fichier 
Private Sub Commande27_Click() 
Dim HwndConnect As Long 
Dim HwndOpen As Long 
'Ouvre internet 
HwndOpen = InternetOpen("SiteWeb", 0, vbNullString, vbNullString, 0) 
'Connection au site ftp 
HwndConnect = InternetConnect(HwndOpen, "<ftp>", <port>, _
  "<username>", "<password>", 1, 0, 0) 
'positionnement du curseur dans le répertoire 
FtpSetCurrentDirectory HwndConnect, "page_web/documents" 
 'Téléchargement de test.txt 
FtpGetFile HwndConnect, "test.txt", "C:\WINDOWS\Bureau\test.txt", _
  False, 0, &H0, 0
 
FtpPutFile HwndConnect, "C:\windows\bureau\test.txt", "shwin.txt", &H0, 0 
'Envoi du fichier test.txt en le renommant shwin.txt sur le serveur 
 
InternetCloseHandle HwndConnect 'Ferme la connection 
InternetCloseHandle HwndOpen 'Ferme internet 
End Sub
Créé le 28 janvier 2005  par Shwin

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 :

 
Sélectionnez
Private Function creerfichier() As String
On Error GoTo err
Dim FSO As New Scripting.FileSystemObject
Dim FichText As Scripting.TextStream
Dim Fichier As String
'Recupere le nom du fichier
Fichier = EnregistrerUnFichier(Me.hwnd, _
  "Enregistrer", "MonFichier.txt", CurrentProject.Path)
If Fichier <> "" Then
  'Creer le fichier texte
  Set FichText = FSO.CreateTextFile(Fichier, True)
  TFichier = Fichier
  'Retourne le chemin du 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 :

 
Sélectionnez
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
'Si ecraser alors
If ecraser Then
  'Ouvre le fichier en mode ecriture
  Set FichText = FSO.OpenTextFile(Fichier, ForWriting)
Else
  'Ouvre le fichier en mode ajout
  Set FichText = FSO.OpenTextFile(Fichier, ForAppending)
End If
'Ecrit la ligne
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 :

 
Sélectionnez
Private Sub Bouvrir_Click()
On Error GoTo err
Dim Fichier As String
'Recuper le nom du fichier
Fichier = OuvrirUnFichier(Me.hwnd, "Ouvrir un fichier texte", _
  1, "Fichier Texte", "txt")
If Fichier <> "" Then
  'Affiche le nom du fichier
  TFichier = Fichier
  'Lit le 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
'Declare le systeme de fichier
Dim FSO As New Scripting.FileSystemObject
'Declare le fichier texte
Dim FichText As Scripting.TextStream
'Ouvre le fichier en lecture
Set FichText = FSO.OpenTextFile(Nom, ForReading)
  'Lit le fichier
  TTexte = FichText.ReadAll
'libere les variable
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é.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur
Téléchargez le zip

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)

 
Sélectionnez
'Déclaration des API 
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 
 
'Constantes pour les API 
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" 
 
 
'Type pour les API 
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 
'Cette fonction permet de supprimer le caractère de fin de chaine d'une chaine 
    If (InStr(OriginalStr, Chr(0)) > 0) Then 
        'On prend les données à gauche de la chaine. 
        OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) 
    End If 
    'on affecte la nouvelle chaine à l'argument de sortie. 
    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 
 
    'On ouvre un curseur sur la table 
    Set rs = CurrentDB.OpenRecordset("SELECT * from listage_fichier") 
    If Right$(path, 1) <> "\" Then path = path & "\" 
    'Si on veut inclure les sous-répertoire (Sub_dir = true) 
    If sub_dir Then 
        ' Recherche des sous répertoires 
        nDir = 0 
        'redimensionne ndir 
        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 
                'on ajoute le fichier dans la liste 
                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.

 
Sélectionnez
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 
 
'on vide la table 
    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

Créé le 28 janvier 2005  par Gaël Donat

Page de l'auteur

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 :

 
Sélectionnez
Private Function ScanFolder(FolderPath As String, _
 Optional Filename As String = "", _
 Optional SubFold As Boolean = True) As Long
 
' Fonction récursive pour l'exploration des répertoires
On Error Resume Next
  'Declaration des variables
  Dim Element As Variant
  Dim StrPath() As String
  'Recuper le nombre de fichier a scanner
  ScanFolder = fs.GetFolder(FolderPath).Files.Count
  'Parcours le dossier
  For Each Element In fs.GetFolder(FolderPath).Files
    'Si utilisateur clique sur arreter alors stopeer le code
    If Stopper Then Exit Function
    'Affiche le traitement en bas du formulaire
    EResultat.Caption = FolderPath
    'Si on a saisi un fichier à rechercher
    If Filename <> "" Then
      StrPath = Split(Element, "\")
      'si le nom de fichier correspond
      If StrPath(UBound(StrPath)) Like Filename Then
        'Ajoute le nom de fichier à la liste
        Listeresultat.RowSource = Listeresultat.RowSource & Element & ";"
      End If
    Else
      'Ajoute tous les fichiers
      Listeresultat.RowSource = Listeresultat.RowSource & Element & ";"
  End If
    DoEvents
  Next Element
  'Si on inclut les sous dossiers
  If SubFold Then
    'Parcourir chaque sous dossier
    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.

Créé le 5 mars 2005  par Thierry AIM

Page de l'auteur
Téléchargez le zip

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 :

 
Sélectionnez
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
'Creer un buffer
tempStr = String(260, 0)
'Lance la recherche
Resultat = SearchTreeForFile(Root, NomFichier, Temp)
If Resultat <> 0 Then _
  chercherFichier = Left$(NomFichier, InStr(1, NomFichier, Chr$(0)) - 1)
End Function

Utilisation :

 
Sélectionnez
Msgbox ChercherFichier("Excel.exe","C:\")

Affiche le chemin d'accés du logiciel Excel.

Créé le 5 mars 2005  par Tofalu

Page de l'auteur

Versions : 97 et supérieures

Dans un module, placez le code suivant :

 
Sélectionnez
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
    'Initialise la librairie AVI
    AVIFileInit
    'Recupere un pointeur vers le fichier
    If AVIFileOpen(hFile, NomFichierAVI, _
     OF_SHARE_DENY_WRITE, ByVal 0&) = 0 Then
        'Lit les informations
        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
        'Libère le pointeur
        AVIFileRelease hFile
    Else
        Reponse = "Impossible d'accéder au fichier"
    End If
    'Quitte le fichier AVI
    AVIFileExit
    InformationAVI = Reponse
End Function

Utilisation :

 
Sélectionnez
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

Créé le 5 février 2005  par Tofalu

Page de l'auteur

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é.

 
Sélectionnez
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 
 
'---Les types--- 
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 
 
'Savoir si un fichier existe 
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 'return vrai ou faux 
FindClose (hFindFile) 
End Function

Utilisation :

 
Sélectionnez
msgbox fileExists("C:\fichier.ext") 'retourne vrai si le fichier existe, sinon faux
Créé le 28 janvier 2005  par Shwin

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.

 
Sélectionnez
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) 
'appuie sur la touche 
keybd T, 0, 0, 0 
'relache la touche 
keybd T, 0, 2, 0 
End Sub

Pour simuler capslock, on aura :

 
Sélectionnez
Appui_touche(20)

Pour simuler impr-ecran, on aura :

 
Sélectionnez
Appui_touche(44)
Créé le 28 janvier 2005  par Tofalu

Page de l'auteur

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.

 
Sélectionnez
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 
        ' Si permission refusée, alors fichier déjà ouvert 
        IsFileOpen = True 
    Else 
        ' Sinon, toute autre erreur est répercutée dans la procédure appelante 
        Err.Raise Err.Number, "IsFileOpen" 
    End If 
End Function

Exemple d'utilisation :

 
Sélectionnez
If IsFileOpen("C:\MonClasseur.xls") Then
  Msgbox "Fichier ouvert"
End if
Créé le 12 novembre 2005  par =JBO=

Ce code permet d'ouvrir une Vcard ou fichier vcf et d'importer les informations sous Access.

Une Vcard est en quelque sorte une carte de visite électronique. Elle contient différentes informations sur le contact. Elle est aujourd'hui normalisée par des normes RFC et peut être lue par des clients de messagerie ou de pocket pc... Les Vcard peuvent être considérées comme des fichiers textes, vous pouvez l'ouvrir avec le bloc notes pour en voir le contenu. Les informations contenues peuvent varier suivant les cartes de visite.
Dans l'exemple ci-dessous, seuls quelques champs sont utilisés. Pour avoir tous les champs possibles de ces cartes de visite électroniques, il faut consulter les RFC.

Pour plus d'informations, se référer aux RFC et documents suivants : Les VCard version 3.0 sont définies par les RFC 2425 et 2426 : lien vers l'Internet Mail Consortium http://www.imc.org/pdi
Pour les versions 2.1, se référer à ce document : http://www.imc.org/pdi/vcard-21.txt

 
Sélectionnez
Public Function LireVCard(sNomForm As String)
 
    Dim sPath, sLigne, temp As String
    Dim t As Variant ' Access97
    'Dim t() As String ' Versions supérieures
    Dim ctl As Control
    Dim I As Integer
    Dim db As DAO.Database, rst As DAO.Recordset
    Dim sql As String
 
    ' Ouverture du fichier *.vcf
    sPath = OuvrirUnFichier(Forms(sNomForm).hWnd, "Open a Vcard", 1, "Vcard", "vcf")
    ' Vérification de l'existence du fichier 
    If sPath <> "" And Nz(Dir(sPath), "") <> "" Then
		' Ouverture d'un fichier texte en lecture
		Open sPath For Input As #1
		' Parcours du fichier vcf ligne par ligne
        Do While Not EOF(1)
            Input #1, sLigne
			'mon ensemble de if permet de vérifier si on est sur le bon champ Name
			'Dans ce cas là il faut découper car nom et prénom sont _
			sur la même ligne séparés par ";"
            If left(sLigne, 2) = "n:" Then
                t = FctSplit(right(sLigne, Len(sLigne) - 2), ";") ' Access97
                't = Split(right(sLigne, Len(sLigne) - 2), ";") ' Versions supérieures
                Forms(sNomForm).Nom = Nz(t(0), "")
                If UBound(t) > 0 Then
                    Forms(sNomForm).Prenom = Nz(t(1), "")
                End If
            End If
			'tel du travail
            If left(sLigne, 9) = "tel;work:" Then
                Forms(sNomForm).Telpro = right(sLigne, Len(sLigne) - 9)
            End If
			'fax
            If left(sLigne, 8) = "tel;fax:" Then
                Forms(sNomForm).Fax = right(sLigne, Len(sLigne) - 8)
            End If
			'Fonction
            If left(sLigne, 6) = "title:" Then
                Forms(sNomForm).Fonction = right(sLigne, Len(sLigne) - 6)
            End If
			'mail
            If left(sLigne, 20) = "EMAIL;PREF;INTERNET:" Then
                Forms(sNomForm).Email = right(sLigne, Len(sLigne) - 20)
            End If
			'Entreprise
            If left(sLigne, 4) = "org:" Then
                Forms(sNomForm).Entreprise = right(sLigne, Len(sLigne) - 4)
            End If
        Loop
 
    	' Fermeture fichier
        Close #1
    End If
 
End Function

Liens utiles :
Code de remplacement de la fonction Split
Ouvrir un fichier

Créé le 15 mai 2007  par musicmandj5

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2013 Maxence Hubiche Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.