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"

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

CouperColler("D:\test.txt","d:\test2.txt",0)

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

    Dim NewFile As FileType
    NewFile.Name = "Fichier texte"
    NewFile.Extension = ".txt"
    NewFile.IconPath = "c:\monicone.ico"
    NewFile.ExePath = "c:\windows\notepad.exe"
    Associate NewFile

'------------------- 
'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

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

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

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

'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

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

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

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

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

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

MsgBox InformationAVI("C:\WINDOWS\clock.avi"), _
vbInformation, "Info AVI"

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

msgbox fileExists("C:\fichier.ext") 'retourne vrai si le fichier existe, sinon faux

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

Appui_touche(20)

Appui_touche(44)

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

If IsFileOpen("C:\MonClasseur.xls") Then
  Msgbox "Fichier ouvert"
End if

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