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 et renomme en shwin.txt un coup rend 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