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

FAQ Visual Basic

FAQ Visual Basic Consultez toutes les FAQ

Nombre d'auteurs : 50, nombre de questions : 300, dernière mise à jour : 15 juin 2021 

 
OuvrirSommaireSystèmeFichiers
vb
Sélectionnez
If Dir("c:\temp\Erreurs.tmp", vbHidden) <> "" Then
    'le fichier existe (vbHidden permet de le retrouver même s'il est caché)
End If
Créé le 29 juillet 2002  par Romain Puyfoulhoux

Ci-joint vous trouverez une Fonction à ajouter dans un nouveau module qui vous permettra de compter le nombre de fichiers d'une ou plusieurs extensions voulues dans répertoire donné :

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

Voici comment appeler cette Fonction :

 
Sélectionnez
nbfich("c:\mesimages","gif","bmp","pcx")

Vous pouvez mettre une ou plusieurs extensions séparées par des virgules.

Mis à jour le 22 décembre 2008  par random

Au moyen d'une fonction qui tente d'ouvrir un fichier en écriture, en cas d'erreur retournée, cela indique que le fichier est déjà ouvert, dans le cas contraire, on considère qu'il est fermé.

 
Sélectionnez
Function IsFileOpen(ByVal strFic As String) As Boolean
    Dim fic As Integer
    On Error Resume Next
 
    fic = FreeFile()
    Open strFic For Input Access Read Lock Read Write As fic
 
    If Err.Number = 0 Then
        IsFileOpen = False
        Close fic
    Else
        IsFileOpen = True
    End If
End Function
Mis à jour le 22 décembre 2008  par Cafeine

Lien : Tester si un fichier est déjà ouvert

vb
Sélectionnez
'Copie le fichier "c:\temp\Erreurs.tmp" en "c:\temp\Erreurs.bak"
FileCopy "c:\temp\Erreurs.tmp", "c:\temp\Erreurs.bak"
Créé le 29 juillet 2002  par Romain Puyfoulhoux

La méthode habituellement utilisée pour copier un fichier, FileCopy, échoue si le fichier en cours est actuellement ouvert (violation de partage). Pour contourner ce problème, il faut faire appel à une API du kernel nommée CopyFile. Dans l'exemple ci-dessous, cette méthode est utilisée pour sauvegarder une base Access alors même que celle-ci est ouverte.

vb
Sélectionnez
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _ 
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _ 
ByVal bFailIfExists As Long) As Long 
'bFailIfExists doit etre à false pour permettre 'l'overwriting 
 
Private Sub Form_Load() 
Dim Nouvfich As String 
CommonDialog1.Filter = "Base de données (*.mdb)|*.mdb" 
On Error GoTo erreur 
CommonDialog1.ShowSave 
Nouvfich = CommonDialog1.FileName 
CopyFile App.Path & "\tests.mdb", Nouvfich, False 
erreur: 
If Err = 32755 Then 
    Exit Sub 
End If 
End Sub
Créé le 13 juin 2005  par odan71
vb
Sélectionnez
'Renomme "c:\temp\Erreurs.tmp" en "c:\temp\Erreurs.bak"
Name "c:\temp\Erreurs.tmp" As "c:\temp\Erreurs.bak"
'Renomme le répertoire "c:\temp" en "c:\var"
Name "c:\temp" As "c:\var"
Mis à jour le 6 janvier 2003  par Romain Puyfoulhoux
vb
Sélectionnez
Kill "c:\Erreurs.tmp"

Le fichier doit exister sinon une erreur d'exécution a lieu.

Créé le 29 juillet 2002  par Romain Puyfoulhoux

En utilisant les API Windows. Copiez ce code source dans un module standard :

vb
Sélectionnez
Private Type SHFILEOPSTRUCT
   hwnd As Long
   wFunc As Long
   pFrom As String
   pTo As String
   fFlags As Long
   fAnyOperationsAborted As Long
   hNameMappings As Long
   lpszProgressTitle As String
End Type
 
Private Const FO_DELETE As Long = &H3
Private Const FOF_ALLOWUNDO As Long = &H40
 
Private Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" _
                                         (lpFileOp As SHFILEOPSTRUCT) As Long
 
Public Function DansCorbeille(fichier As String, handle As Long) As Boolean
 
    Dim DelFileOp As SHFILEOPSTRUCT
    Dim Result As Long
 
    With DelFileOp
       .hwnd = handle
       .wFunc = FO_DELETE
       .pFrom = fichier & vbNullChar & vbNullChar
       .fFlags = FOF_ALLOWUNDO
    End With
 
    Result = SHFileOperation(DelFileOp)
    DansCorbeille = (Result = 0) And (DelFileOp.fAnyOperationsAborted = 0)
 
End Function

La fonction DansCorbeille renvoie True si l'envoi du fichier dans la corbeille a été effectué. Ses paramètres sont le chemin complet du fichier et le handle de la fenêtre utilisé pour afficher les éventuelles boîtes de dialogue d'avertissement ou de demande de confirmation. Ce deuxième paramètre peut être une valeur nulle. Voici un exemple d'utilisation de cette fonction :

vb
Sélectionnez
If DansCorbeille("C:\lettre.doc", Me.hwnd) Then
    MsgBox "Le fichier a été déplacé dans la corbeille"
Else
    MsgBox "Le fichier n'a pas pu être déplacé dans la corbeille"
End If
Créé le 6 septembre 2004  par Romain Puyfoulhoux

En passant soit par les API, soit par le FileSystemObject. En natif, VB ne donne accès qu'à la date de dernière modification, via la fonction FileDateTime(). Si vous choisissez de passer par les API, voici les déclarations nécessaires :

vb
Sélectionnez
Private Const MAX_PATH = 260
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 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
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
                                       (ByVal lpFileName As String, _
                                       lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" _
                                              (lpFileTime As FILETIME, _
                                               lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" _
                                                 (lpFileTime As FILETIME, _
                                                  lpLocalFileTime As FILETIME) As Long

Les dates d'un fichier sont récupérées par la fonction FindFirstFile qui attend en paramètres le nom du fichier et une structure WIN32_FIND_DATA qui reçoit les informations obtenues. Les dates de création, de dernière modification et de dernier accès sont stockées respectivement dans les champs ftCreationTime, ftLastWriteTime et ftLastAccessTime, tous de type FILETIME. Pour avoir des dates sous une forme exploitable, quelques conversions sont nécessaires. Notre fonction FileTimeToDate() convertit une date de type FILETIME en type Date.

vb
Sélectionnez
Private Function FileTimeToDate(ft As FILETIME) As Date
 
Dim datelocale As FILETIME, datesys As SYSTEMTIME
 
If FileTimeToLocalFileTime(ft, datelocale) = 0 Then Exit Function
If FileTimeToSystemTime(datelocale, datesys) = 0 Then Exit Function
FileTimeToDate = CDate(datesys.wDay & " " & datesys.wMonth & " " & datesys.wYear & " " & _
                       datesys.wHour & ":" & datesys.wMinute & ":" & datesys.wSecond)
 
End Function

La partie principale du code est assez simple :

vb
Sélectionnez
Dim findData As WIN32_FIND_DATA, hFind As Long
 
hFind = FindFirstFile("c:\autoexec.bat", findData)
If hFind = INVALID_HANDLE_VALUE Then Exit Sub
FindClose hFind
 
MsgBox "Crée le : " & FileTimeToDate(findData.ftCreationTime)
MsgBox "Modifié le : " & FileTimeToDate(findData.ftLastWriteTime)
MsgBox "Accédé le : " & FileTimeToDate(findData.ftLastAccessTime)

Pour terminer, voici la version avec le FileSystemObject :

vb
Sélectionnez
Dim fso As FileSystemObject, f As File
 
Set fso = New FileSystemObject
 
On Error GoTo fin
Set f = fso.GetFile("c:\autoexec.bat")
MsgBox "Crée le : " & f.DateCreated
MsgBox "Modifié le : " & f.DateLastModified
MsgBox "Accédé le : " & f.DateLastAccessed
Set f = Nothing
 
fin:
Set fso = Nothing
Créé le 4 septembre 2003  par Romain Puyfoulhoux

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

Cette fonction reçoit le chemin complet d'un fichier en paramètre et renvoie le numéro de version du fichier, s'il existe, sinon renvoie une chaîne vide :
(concerne essentiellement les fichiers .dll, .ocx, .exe et autres fichiers du système)

Collez ce code dans un module standard :

vb
Sélectionnez
'-- Déclarations de structure et des fonctions de l'API Windows
Private Type VS_FIXEDFILEINFO
    dwSignature As Long
    dwStrucVersionl As Integer    '  e.g. = &h0000 = 0
    dwStrucVersionh As Integer    '  e.g. = &h0042 = .42
    dwFileVersionMSl As Integer    '  e.g. = &h0003 = 3
    dwFileVersionMSh As Integer    '  e.g. = &h0075 = .75
    dwFileVersionLSl As Integer    '  e.g. = &h0000 = 0
    dwFileVersionLSh As Integer    '  e.g. = &h0031 = .31
    dwProductVersionMSl As Integer    '  e.g. = &h0003 = 3
    dwProductVersionMSh As Integer    '  e.g. = &h0010 = .1
    dwProductVersionLSl As Integer    '  e.g. = &h0000 = 0
    dwProductVersionLSh As Integer    '  e.g. = &h0031 = .31
    dwFileFlagsMask As Long    '  = &h3F for version "0.42"
    dwFileFlags As Long    '  e.g. VFF_DEBUG Or VFF_PRERELEASE
    dwFileOS As Long    '  e.g. VOS_DOS_WINDOWS16
    dwFileType As Long    '  e.g. VFT_DRIVER
    dwFileSubtype As Long    '  e.g. VFT2_DRV_KEYBOARD
    dwFileDateMS As Long    '  e.g. 0
    dwFileDateLS As Long    '  e.g. 0
End Type
 
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
 
'-- Renvoie le numero de version d'un fichier au format String : x.xx.xxxx.xxxx
Public Function GetFileVerInfo(sFullPath As String) As String
    Dim rc As Long, lDummy As Long, sBuffer() As Byte
    Dim lBufferLen As Long, lVerPointer As Long, udtVerBuffer As VS_FIXEDFILEINFO
    Dim lVerbufferLen As Long
 
    '*** Obtient la taille du buffer ****
    lBufferLen = GetFileVersionInfoSize(sFullPath, lDummy)
    If lBufferLen < 1 Then
        GetFileVerInfo = ""    ' No Version Info available!
        Exit Function
    End If
 
    '**** Stocke les informations dans la structure udtVerBuffer  ****
    ReDim sBuffer(lBufferLen)
    rc = GetFileVersionInfo(sFullPath, 0&, lBufferLen, sBuffer(0))
    rc = VerQueryValue(sBuffer(0), "\", lVerPointer, lVerbufferLen)
    MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)
 
    '**** Renvoie les information de numéro de version ****
    GetFileVerInfo = Format$(udtVerBuffer.dwFileVersionMSh) & "." & _
            Format$(udtVerBuffer.dwFileVersionMSl) & "." & _
            Format$(udtVerBuffer.dwFileVersionLSh) & "." & _
            Format$(udtVerBuffer.dwFileVersionLSl)
End Function

Exemple :

vb
Sélectionnez
Msgbox GetFileVerInfo("C:\windows\Explorer.exe")
Créé le 2 mai 2006  par ThierryAIM
vb
Sélectionnez
Debug.Print FileLen("nomdufichier") 'Affiche en octets la taille du fichier
Créé le 17 février 2004  par Abelman

Lien : Comment convertir une taille de fichier donnée en octets en une unité adaptée ?

La commande FileLen vue ci-dessus, retourne la taille du fichier en octets, mais un fichier de 5368709120 octets ne nous dit rien.

On sait que :
1Ko = 1024o
1Mo = 1024Ko
1Go = 1024Mo
etc...

Pour convertir en une unité compréhensible, nous allons diviser la taille par 1024, si celle-ci est supérieure à 1024.
Si le nombre obtenu est toujours supérieur à 1024, on redivise par 1024, et ainsi de suite...

La fonction suivante permet cette conversion jusqu'aux Yo (yotta-octet = 2^80 octects).

vb
Sélectionnez
Function Unite(ByVal Taille As Double) As String 
 
    Dim TabUnite   'On déclare une variable qui va être un tableau 
    Dim i As Integer    'Un compteur 
 
    TabUnite = Array("o", "Ko", "Mo", "Go", "To", "Po", "Eo", "Zo", "Yo")    'Le tbaleau de unités 
    i = 0    'Initialisation du compteur 
 
    Do While Taille >= 1024 And i < 8    'Début de la boucle 
        Taille = Taille / 1024    'On divise 
        i = i + 1    'on rajoute 1 au compteur 
    Loop 
 
    'On retourne la taille convertie avec l'unité dans une string 
    Unite = Round(Taille, 2) & " " & TabUnite(i) 
End Function

Exemple :

vb
Sélectionnez
MsgBox Unite(FileLen("chemindufichier"))
Créé le 2 mai 2006  par Optitech

Lien : Comment récupérer la taille d'un fichier ?

Ce source copie le contenu du répertoire c:\sources dans le répertoire c:\oldsources. Passer la valeur True en troisième paramètre de CopyFolder indique que les fichiers existants devront être écrasés.

vb
Sélectionnez
Dim fso As FileSystemObject
Set fso = New FileSystemObject
fso.CopyFolder "c:\sources", "c:\oldsources", True
Set fso = Nothing
Créé le 6 janvier 2003  par Romain Puyfoulhoux

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

Avec RmDir, mais vous ne pouvez l'utiliser que pour supprimer des répertoires vides.

vb
Sélectionnez
RmDir "c:\temp"

Pour supprimer un répertoire qui contient fichiers ou répertoires, utilisez le FileSystemObject, qui est disponible seulement si vous avez inclus la librairie Microsoft Scripting Runtime dans les références de votre projet.

vb
Sélectionnez
Dim fso as FileSystemObject
Set fso = New FileSystemObject
fso.DeleteFolder "c:\temp", True

La valeur True passée au deuxième paramètre permet de supprimer le répertoire dans le cas où il aurait l'attribut lecture seule. Ce paramètre est optionnel, et a la valeur False par défaut.

Créé le 29 juillet 2002  par Romain Puyfoulhoux

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

vb
Sélectionnez
Dim rep As String
'obtient le premier fichier ou répertoire qui est dans "c:\"
rep = Dir("c:\*.*", vbDirectory)
'boucle tant que le répertoire n'a pas été entièrement parcouru
Do While (rep <> "")
    'teste si c'est un fichier ou un répertoire
    If (GetAttr("c:\" & rep) And vbDirectory) = vbDirectory Then
        MsgBox "Répertoire " & rep
    Else
        MsgBox "Fichier " & rep
    End If
    'passe à l'élément suivant
    rep = Dir
Loop
Créé le 29 juillet 2002  par Romain Puyfoulhoux

Nécessite d'activer la référence Microsoft Scripting Runtime (scrrun.dll)
Il y a possibilité d'agir sur chaque fichier listé !

vb
Sélectionnez
Private Sub Command1_Click()
 
Dim fso As FileSystemObject, dossier As Folder, sousdossier As Folder, fichier As File
 
    Set fso = New FileSystemObject
    Set dossier = fso.GetFolder("c:\essai")
    scan dossier
 
End Sub
 
Public Sub scan(ByVal dossier As Folder)
 
    For Each fichier In dossier.Files
        Debug.Print fichier
    Next
 
    For Each sousdossier In dossier.SubFolders
        Debug.Print sousdossier
        scan sousdossier
    Next
 
End Sub
Créé le 13 juin 2005  par e-steel

Voici une méthode simple utilisant le FileSystemObject. Placez ce code dans un module :

vb
Sélectionnez
Public Enum UniteMemoire
    octets = 1
    kiloOctets = 2
    megaOctets = 3
End Enum
 
Public Function TailleRepertoire(f As Folder, Optional unite As UniteMemoire = 1) As Long
 
Dim s As Long
 
s = f.Size
Select Case unite
    Case 2:
        TailleRepertoire = Int(s / 1024)
    Case 3:
        TailleRepertoire = Int(s / 1048576)
    Case Else:
        TailleRepertoire = s
End Select
 
End Function

Un exemple d'utilisation :

vb
Sélectionnez
Private Sub Test()
 
Dim fs As FileSystemObject, f As Folder, strTaille As String
 
Set fs = New FileSystemObject
Set f = fs.GetFolder("c:\windows")
 
strTaille = Format(TailleRepertoire(f), "##,##0 octets") & vbCrLf & _
            Format(TailleRepertoire(f, kiloOctets), "##,##0 Ko") & vbCrLf & _
            Format(TailleRepertoire(f, megaOctets), "##,##0 Mo")
MsgBox strTaille
 
End Sub
Créé le 17 février 2004  par ThierryAIM

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

Pour cela vous devez ajouter ces déclarations au début de votre module :

vb
Sélectionnez
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
 
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _ 
    ByVal lpString2 As String) As Long
 
Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
     ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

La fonction suivante ouvre la fenêtre de sélection de répertoire standard de Windows et renvoie le chemin du répertoire sélectionné. Les paramètres attendus sont le titre à afficher et l'identifiant de la fenêtre parente.

vb
Sélectionnez
Public Function SelectFolder(Titre As String, Handle As Long) As String
 
Dim lpIDList As Long
Dim strBuffer As String
Dim strTitre As String
Dim tBrowseInfo As BrowseInfo
 
strTitre = Titre
With tBrowseInfo
    .hWndOwner = Handle
    .lpszTitle = lstrcat(strTitre, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
 
lpIDList = SHBrowseForFolder(tBrowseInfo)
 
If (lpIDList) Then
    strBuffer = String(260, vbNullChar)
    SHGetPathFromIDList lpIDList, strBuffer
    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If
 
End Function

Cette ligne fait appel à la fonction écrite ci-dessus pour ouvrir la fenêtre de sélection de répertoire et afficher le répertoire sélectionné :

vb
Sélectionnez
 MsgBox SelectFolder("Sélectionnez un répertoire :", Me.hWnd)
Créé le 29 juillet 2002  par Romain Puyfoulhoux

Vous trouverez dans la faq : Comment ouvrir une fenêtre de sélection de répertoire ?

Une solution utilisant la fonction SHBrowseForFolder de l'Api shell32,
pour afficher la fenêtre de sélection de répertoire.
Cette fonction prends en paramètre de type BrowseInfo, la modification de la fenêtre de sélection de répertoire est obtenu grâce à la propriété uFlag de ce paramètre .
Et donc une modification de la ligne de code :

 
Sélectionnez
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
Nom Valeur Conséquence
BIF_RETURNONLYFSDIRS &H0001 Autorise seulement la sélection d'éléments du système de fichier ( pas d'imprimante...)
BIF_DONTGOBELOWDOMAIN &H0002 Limite la sélection dans réseau au nom de domaines sans ouverture possible
BIF_STATUSTEXT &H0004 Rajoute une zone état dont le texte peu ensuite être modifié par des appels à SendMessage
BIF_EDITBOX &H0010 Rajout d'une zone d'édition sur la boîte de dialogue parcourir, permettant la saisie d'un répertoire (existant)
BIF_VALIDATE &H0020 Utilisé conjointement avec BIF_EDITBOX, appel de la fonction callback : BrowseCallbackProc, avec le message : BFFM_VALIDATEFAILED, si répertoire saisie invalide.
BIF_NEWDIALOGSTYLE &H0040 Boîte de dialogue nouveau style,support glisser déposer, taille modifiable, bouton créer nouveau dossier, menu contextuel.
BIF_BROWSEINCLUDEURLS &H0080 Permet la sélection d'un fichier par son URL, nécessite les flags : BIF_USENEWUI et BIF_BROWSEINCLUDEFILES.
BIF_USENEWUI &H0050 Nouvelle interface y compris la zone d'édition, équivalent à : BIF_EDITBOX OR BIF_NEWDIALOGSTYLE.
BIF_UAHINT &H0100 Lorsque combiné avec BIF_NEWDIALOGSTYLE, ajoute un texte d'aide ("Pour afficher... cliquez sur + ") , en lieu et place de la zone d'édition, si BIF_EDITBOX et actif celui-ci l'emporte.
BIF_NONEWFOLDERBUTTON &H0200 Supprime l'affichage du bouton nouveau dossier.
BIF_NOTRANSLATETARGETS &H0400 Sur sélection d'un raccourci, renvoi le raccourci lui même plutôt que sa cible.
BIF_BROWSEFORCOMPUTER &H1000 Autorise seulement le choix d'un ordinateur.
BIF_BROWSEFORPRINTER &H2000 Autorise seulement le choix d'une imprimante.
BIF_BROWSEINCLUDEFILES &H4000 Permet la sélection des fichiers.
BIF_SHAREABLE &H8000 Utilisé conjointement avec BIF_NEWDIALOGSTYLE, affiche la liste des ressources partagées par les ordinateurs distants.



implémentation

Le code vu précédemment ici peut-être adapté :

rajouter tout d'abords la déclaration des constantes utiles :

 
Sélectionnez
Public Const BIF_RETURNONLYFSDIRS   = &H0001
Public Const BIF_DONTGOBELOWDOMAIN  = &H0002
Public Const BIF_STATUSTEXT         = &H0004
Public Const BIF_EDITBOX            = &H0010
Public Const BIF_NEWDIALOGSTYLE = &H0040
Public Const BIF_NONEWFOLDERBUTTON  = &H0200
(...)

Modifier :
Dans l'entête de la fonction :

 
Sélectionnez
Public Function SelectFolder(Titre As String, Handle As Long, Optional ByVal uFlags As Long = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN) As String


Dans le corps de la fonction :

 
Sélectionnez
    .ulFlags = uFlags

et en appelant la fonction SelectFolder :
Avec affichage du bouton de création de dossier :

 
Sélectionnez
MsgBox SelectFolder ("Titre", Me.hwnd, BIF_NEWDIALOGSTYLE)

Sans affichage du bouton de création de dossier :

 
Sélectionnez
MsgBox SelectFolder ("Titre", Me.hwnd, BIF_NEWDIALOGSTYLE+ BIF_NONEWFOLDERBUTTON)



MSDN BROWSEINFO Structure

Créé le 22 décembre 2008  par bbil, ThierryAIM

Dans le Menu Projet >> Références >> Ajoutez la librairie Microsoft Scripting Runtime. Le fichier correspondant se nomme scrrun.dll

Créé le 29 juillet 2002  par Romain Puyfoulhoux

Cette fonction reçoit le chemin complet d'un fichier en paramètre et renvoie le chemin du répertoire :

vb
Sélectionnez
Public Function ExtractFilePath(ByVal sFullPath As String) As String
 
If Right(sFullPath, 1) = "\" Then
    ExtractFilePath = sFullPath
Else
    ExtractFilePath = Left(sFullPath, InStrRev(sFullPath, "\"))
End If
 
End Function
Créé le 17 février 2004  par ThierryAIM

Lien : Comment récupérer le nom d'un fichier à partir d'un chemin complet ?
Lien : Comment récupérer l'extension d'un fichier à partir d'un chemin complet ?

Cette fonction propose plusieurs arguments utiles pour personnaliser votre boîte de dialogue, ils sont expliqués dans le code.
Code à placer dans un module :

 
Sélectionnez
  'Déclaration de l'API
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
                   "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
 'Structure du fichier
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
 'Constantes
Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
 
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
 
 
Public Function OuvrirUnFichier(Handle As Long, _
                                Titre As String, _
                                TypeRetour As Byte, _
                                Optional TitreFiltre As String, _
                                Optional TypeFichier As String, _
                                Optional RepParDefaut As String) As String
 'OuvrirUnFichier est la fonction a utiliser dans votre formulaire pour ouvrir _
 'la boîte de dialogue de sélection d'un fichier.
 'Explication des paramètres
    'Handle = le handle de la fenêtre (Me.Hwnd)
    'Titre = Titre de la boîte de dialogue
    'TypeRetour (Définit la valeur, de type String, renvoyée par la fonction)
        '1 = Chemin complet + Nom du fichier
        '2 = Nom fichier seulement
    'TitreFiltre = Titre du filtre
        'Exemple: Fichier Access
        'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
    'TypeFichier = Extention du fichier (Sans le .)
        'Exemple: MDB
        'N'utilisez pas cet argument si vous ne voulez spécifier aucun filtre
    'RepParDefaut = Répertoire d'ouverture par defaut
        'Exemple: C:\windows\system32
        'Si vous laissé l'argument vide, par defaut il se place dans le répertoire de votre application
 
Dim StructFile As OPENFILENAME
Dim sFiltre As String
 
 'Construction du filtre en fonction des arguments spécifiés
If Len(TitreFiltre) > 0 And Len(TypeFichier) > 0 Then
  sFiltre = TitreFiltre & " (" & TypeFichier & ")" & Chr$(0) & "*." & TypeFichier & Chr$(0)
End If
sFiltre = sFiltre & "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0)
 
 
 'Configuration de la boîte de dialogue
  With StructFile
    .lStructSize = Len(StructFile) 'Initialisation de la grosseur de la structure
    .hwndOwner = Handle 'Identification du handle de la fenêtre
    .lpstrFilter = sFiltre 'Application du filtre
    .lpstrFile = String$(254, vbNullChar) 'Initialisation du fichier '0' x 254
    .nMaxFile = 254 'Taille maximale du fichier
    .lpstrFileTitle = String$(254, vbNullChar) 'Initialisation du nom du fichier '0' x 254
    .nMaxFileTitle = 254  'Taille maximale du nom du fichier
    .lpstrTitle = Titre 'Titre de la boîte de dialogue
    .flags = OFN_HIDEREADONLY  'Option de la boite de dialogue
    If ((IsNull(RepParDefaut)) Or (RepParDefaut = "")) Then
        .lpstrInitialDir = App.path
        Else: .lpstrInitialDir = RepParDefaut
    End If
  End With
 
If (GetOpenFileName(StructFile)) Then 'Si un fichier est sélectionné
    Select Case TypeRetour
      Case 1: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFile, InStr(1, StructFile.lpstrFile, vbNullChar)-1))
      Case 2: OuvrirUnFichier = Trim$(Left(StructFile.lpstrFileTitle, InStr(1,  StructFile.lpstrFileTitle, vbNullChar)-1))
    End Select
  End If 
 
End Function

Exemple pour appeler la fonction depuis le code d'un formulaire :

 
Sélectionnez
MsgBox OuvrirUnFichier(Me.Hwnd, "Parcourir", 1, "Fichier Word", "doc")
Mis à jour le 22 décembre 2008  par shwin

Lien : Afficher la boîte de dialogue Enregistrer sous afin de récupérer le nom et le chemin du fichier sélectionné
Lien : Utilise le contrôle Common Dialog pour récupérer le chemin d'un fichier
Lien : Comment avec l'API GetOpenFileNameA ouvrir plusieurs fichiers à la fois ?

Il suffit de mettre l'attribut flags à la valeur suivante :

 
Sélectionnez
openfile.flags = &H200 'Multiselect

Ensuite, la variable fichier est un string qui va contenir les noms.

 
Sélectionnez
C:\autoexec.bat nouveau.txt

A vous de travailler cette chaîne pour obtenir le résultat souhaité.

Mis à jour le 22 décembre 2008  par shwin

Lien : Afficher la boîte de dialogue ouvrir afin de récupérer le nom et le chemin du fichier sélectionné

Note : Les arguments de cette fonction sont expliqués dans le code.
Code à placer dans un module :

 
Sélectionnez
  'Déclaration de l API
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) _
        As Long
 
 'Structure du fichier
Private Type OPENFILENAME
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  Flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
 
 
Function EnregistrerUnFichier(Handle As Long, Titre As String,  _
                    NomFichier As String, Chemin As String) As String
 
 'EnregistrerUnFichier est la fonction a utiliser dans votre formulaire pour ouvrir _
la boîte de dialogue d'enregistrement d'un fichier.
 'Explication des paramètres
    'Handle = le handle de la fenêtre (Me.Hwnd)
    'Titre = Titre de la boîte de dialogue
    'NomFichier = Nom par défaut du fichier à enregistrer
    'Chemin = Chemin par défaut du fichier à enregistrer
 
Dim structSave As OPENFILENAME
 
With structSave
    .lStructSize = Len(structSave)
    .hWndOwner = Handle
    .nMaxFile = 255
    .lpstrFile = NomFichier & String$(255 - Len(NomFichier), 0)
    .lpstrInitialDir = Chemin
    .lpstrFilter = "Tous (*.*)" & Chr$(0) & "*.*" & Chr$(0) 'Définition du filtre (aucun)
    .Flags = &H4  'Option de la boite de dialogue
End With
 
If (GetSaveFileName(structSave)) Then
    EnregistrerUnFichier = Mid$(structSave.lpstrFile, 1, InStr(1, structSave.lpstrFile, vbNullChar) - 1)
End If 
 
End Function

Exemple pour appeler la fonction depuis le code d'un formulaire :

 
Sélectionnez
MsgBox EnregistrerUnFichier(Me.hwnd, "Enrégistrer sous", "Test.doc", "C:\")
Mis à jour le 22 décembre 2008  par shwin

Lien : Afficher la boîte de dialogue ouvrir afin de récupérer le nom et le chemin du fichier sélectionné
Lien : Utilise le contrôle Common Dialog pour récupérer le chemin d'un fichier

Pour obtenir le chemin relatif d'un fichier par rapport à un répertoire, vous pouvez utiliser la fonction suivante :

 
Sélectionnez
Function GetRelativePath(ByVal strPath As String, Optional ByVal strPathCurrent As String)
 
Dim tmpCurr() As String
Dim tmpP() As String
Dim i As Integer
Dim iIndex As Integer
 
' par défaut on considère que c'est relatif par rapport au chemin courant de la base
' pour VB6, on utilise le chemin de l'application :
 
If strPathCurrent = "" Then strPathCurrent = App.Path  'CurrentProject.Path
If Right(strPathCurrent, 1) = "\" Then strPathCurrent = Left(strPathCurrent, Len(strPathCurrent) - 1)
 
' on passe tout en minuscule pour éviter les erreurs de comparaison minuscule et majuscule
strPath = LCase(strPath)
strPathCurrent = LCase(strPathCurrent)
 
 
If Left(strPath, 1) = Left(strPathCurrent, 1) Then
    ' on recherche la partie commune aux deux chemins
 
 
    tmpP = VBA.Split(strPath, "\")
    tmpCurr = VBA.Split(strPathCurrent, "\")
    For iIndex = 0 To IIf(UBound(tmpP) > UBound(tmpCurr), UBound(tmpCurr), UBound(tmpP))
        If tmpP(iIndex) <> tmpCurr(iIndex) Then
            Exit For
        Else
            i = iIndex
        End If
    Next iIndex
    If i = UBound(tmpCurr) Then
        ' c'est un sous répertoire
 
 
        For iIndex = i + 1 To UBound(tmpP)
            GetRelativePath = GetRelativePath & tmpP(iIndex) & "\"
        Next iIndex
        GetRelativePath = Left(GetRelativePath, Len(GetRelativePath) - 1)
    Else
        ' il faut remonter de UBound(tmpCurr) - i
 
 
        For iIndex = 1 To UBound(tmpCurr) - i
            GetRelativePath = GetRelativePath & "..\"
        Next iIndex
        For iIndex = i + 1 To UBound(tmpP)
            GetRelativePath = GetRelativePath & tmpP(iIndex) & "\"
        Next iIndex
        GetRelativePath = Left(GetRelativePath, Len(GetRelativePath) - 1)
    End If
Else
    ' deux lecteurs différents
 
 
    GetRelativePath = strPath
End If
 
End Function

Le premier paramètre correspond au chemin du fichier ou du dossier, le second correspond au chemin courant.

Exemple :

 
Sélectionnez
?getrelativepath("c:\toto\tata\test.xls","c:\tintin")
..\toto\tata\test.xls
?getrelativepath("c:\toto\tata\test.xls","c:\toto\tata")
\test.xls
Mis à jour le 22 décembre 2008  par Cafeine, Tofalu

Cette fonction reçoit le chemin complet d'un fichier en paramètre et renvoie le nom du fichier :

vb
Sélectionnez
Public Function ExtractFileName(ByVal sFullPath As String) As String
    If InStr(sFullPath, "\") = 0 Or Right(sFullPath, 1) = "\" Then
        ExtractFileName = ""
        Exit Function
    End If
    ExtractFileName = Mid(sFullPath, InStrRev(sFullPath, "\") + 1)
End Function
Créé le 2 mai 2006  par ThierryAIM

Lien : Comment récupérer le répertoire d'un fichier à partir de son chemin complet ?
Lien : Comment récupérer l'extension d'un fichier à partir d'un chemin complet ?

Cette fonction reçoit le chemin complet d'un fichier en paramètre et renvoie l'extension du fichier, si elle existe, sinon renvoie une chaîne vide :
(Nécessite la fonction ExtractFileName)

vb
Sélectionnez
Public Function ExtractFileExt(ByVal sFullPath As String) As String
    Dim sName As String
    sName = ExtractFileName(sFullPath)
    If InStr(sName, ".") = 0 Then
        ExtractFileExt = ""
    Else
        ExtractFileExt = Mid(sName, InStrRev(sName, ".") + 1)
    End If
End Function
Créé le 2 mai 2006  par ThierryAIM

Lien : Comment récupérer le nom d'un fichier à partir d'un chemin complet ?
Lien : Comment récupérer le répertoire d'un fichier à partir de son chemin complet ?

VB n'inclut pas de composant permettant de compresser des fichiers. Il est possible de s'en sortir en exécutant, via la fonction Shell, un programme de type pkzip. Mais une solution plus pratique est d'utiliser une librairie ou un active-x. Ici nous utiliserons la zlib, qui a l'avantage d'être gratuite, open source et de créer des zips standards. Le code à écrire en VB pour la manipuler étant assez conséquent, nous allons aussi importer les classes VB d'Andrew McMillan disponibles dans les fichiers zipclass.zip et ZipExtractionClass.zip (la zlib est aussi dans ces zips).

Après avoir téléchargé ces 2 fichiers, importez les classes dans votre projet et copiez le fichier zlib.dll dans le répertoire de votre projet ou dans le répertoire système.

Voici comment créer un fichier zip :

vb
Sélectionnez
Dim z As ZipClass
 
Set z = New ZipClass
z.AddFile "c:\test.doc"
z.AddFile "c:\test.jpg"
z.WriteZip "c:\test.zip", True
Set z = Nothing

Et comment faire une extraction :

vb
Sélectionnez
Dim zip As ZipExtractionClass
 
Set zip = New ZipExtractionClass
If zip.OpenZip("C:\Test\Test.zip") Then
   If zip.Extract("C:\Test\Extract", True, True) Then
      MsgBox "Extraction terminée.", vbInformation
   End If
   zip.CloseZip
End If
Set zip = Nothing
Mis à jour le 22 décembre 2008  par Elifqaoui, Romain Puyfoulhoux

Lien : La zlib
Lien : La création d'un zip par Andrew McMillan
Lien : L'extraction d'un zip par Andrew McMillan

Le FileSystemObject vous permet de le faire facilement :

vb
Sélectionnez
Public Function TypeLecteur(ByVal drvpath) As String
 
    Dim fs As FileSystemObject, d As drive, t As String
 
    Set fs = New FileSystemObject
 
    On Error GoTo fail
    Set d = fs.GetDrive(drvpath)
 
    Select Case d.DriveType
        Case 0: t = "Inconnu"
        Case 1: t = "Amovible"
        Case 2: t = "Fixe"
        Case 3: t = "Réseau"
        Case 4: t = "CD-ROM"
        Case 5: t = "Disque RAM"
    End Select
 
fin:
    TypeLecteur = t
    Exit Function
 
fail:
    t = "Introuvable"
    Resume fin
 
End Function

Cette fonction attend en argument la lettre d'un lecteur et renvoie son type en toutes lettres. Par exemple :

vb
Sélectionnez
MsgBox TypeLecteur("c")
Créé le 26 avril 2004  par Alexandre Lokchine, Romain Puyfoulhoux

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

Voici une fonction qui vous renvoie le premier lecteur qui contient un CD, ou une chaîne vide s'il n'y en a aucun. Vous devez ajouter le FileSystemObject dans les références du projet.

vb
Sélectionnez
Public Function LecteurAvecCD() As String
 
    Dim fso As FileSystemObject, lecteur As Drive
    Dim strPath As String, strLecteurCD As String
 
    Set fso = New FileSystemObject
 
    For Each lecteur In fso.Drives
        If lecteur.DriveType = 4 Then
            On Error GoTo suite
            strPath = Dir(lecteur.path)
            strLecteurCD = lecteur.path
            Exit For
        End If
suite:
    Next
 
    Set fso = Nothing
    LecteurAvecCD = strLecteurCD
 
End Function

Sans utilisation de FSO (FileSystemObject), placez ce code dans un module :

vb
Sélectionnez
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" ( _ 
     ByVal lpRootPathName As String, _ 
     ByVal lpVolumeNameBuffer As String, _ 
     ByVal nVolumeNameSize As Long, _ 
     ByRef lpVolumeSerialNumber As Long, _ 
     ByRef lpMaximumComponentLength As Long, _ 
     ByRef lpFileSystemFlags As Long, _ 
     ByVal lpFileSystemNameBuffer As String, _ 
     ByVal nFileSystemNameSize As Long) As Long 
 
Public Function Test_Lecteur(Lecteur As String) As Long 
 
    Dim VolNameBuffer As String 
    VolNameBuffer = String(255, ".") 
    Test_Lecteur = GetVolumeInformation(Lecteur, VolNameBuffer, 255, 0, 0, 0, 0, 255) 
 
End Function

Appel de la procédure :

vb
Sélectionnez
Dim result As Long 
result = Test_Lecteur("D:\") 
If result = 0 Then 
    MsgBox "Lecteur Vide" 
Else 
    MsgBox "CD présent dans le lecteur" 
End If
Mis à jour le 13 juin 2005  par Romain Puyfoulhoux, Alexandre Lokchine, ridan

Lien : Quelle référence dois-je ajouter à mon projet pour pouvoir utiliser le FileSystemObject ?

1) En utilisant l'API Windows :

vb
Sélectionnez
Private Declare Function GetDiskFreeSpace Lib "kernel32.dll" Alias "GetDiskFreeSpaceA" ( _ 
     ByVal lpRootPathName As String, _ 
     ByRef lpSectorsPerCluster As Long, _ 
     ByRef lpBytesPerSector As Long, _ 
     ByRef lpNumberOfFreeClusters As Long, _ 
     ByRef lpTtoalNumberOfClusters As Long) As Long 
 
Private Function conversion(nombre As Currency) As String 
 
    Const KB As Double = 1024 
    Const MB As Double = KB * 1024 
    Const GB As Double = MB * 1024 
 
    If nombre <= 999 Then 
        conversion = Str(nombre) & " bytes" 
    ElseIf nombre <= KB * 999 Then 
        conversion = Format((nombre / KB), "0.00") & " KB" 
    ElseIf nombre <= MB * 999 Then 
        conversion = Format((nombre / MB), "0.00") & " MB" 
    ElseIf nombre <= GB * 999 Then 
        conversion = Format((nombre / GB), "0.00") & " GB" 
    End If 
 
End Function 
 
Public Function Espace_Disque() As String 
 
    Dim SectorsPerCluster As Long 
    Dim BytesPerCluster As Long 
    Dim NumberOfFreeClusters As Long 
    Dim TtoalNumberOfClusters As Long 
 
    Dim Espace_Libre As Currency 
    Dim Espace_Total As Currency 
    Dim Espace_Utilise As Currency 
 
    GetDiskFreeSpace "C:\", SectorsPerCluster, _ 
                            BytesPerSector, _ 
                            NumberOfFreeClusters, _ 
                            TtoalNumberOfClusters 
 
    Espace_Libre = NumberOfFreeClusters * BytesPerSector * SectorsPerCluster 
    Espace_Total = BytesPerSector * TtoalNumberOfClusters * SectorsPerCluster 
    Espace_Utilise = Espace_Total - Espace_Libre 
 
    Espace_Disque = "Espace Libre : " & conversion(Espace_Libre) & vbCrLf & _ 
                    "Espace Total : " & conversion(Espace_Total) & vbCrLf & _ 
                    "Espace Utilisé : " & conversion(Espace_Utilise) 
 
End Function

2) En utilisant le FileSystemObject :

vb
Sélectionnez
' Ajouter la référence à Microsoft Scripting Runtime à votre projet
 
Sub InfoEspaceDisques() 
  Dim fso As New FileSystemObject, d As Drive, txt As String
    For Each d In fso.Drives
        'If d.DriveType = 2 Or d.DriveType = 5 or d.DriveType = 3 Then
 
        If d.DriveType = Fixed Or d.DriveType = RamDisk Or _
        d.DriveType = Remote Then
            txt = txt & "Disk " & d.DriveLetter & "(" & d.VolumeName & ")" & vbTab
            txt = txt & "Total : " & d.TotalSize & vbTab
            txt = txt & "Libre : " & d.FreeSpace & vbCrLf
            Debug.Print txt
        End If
    Next
    Set fso = Nothing
End Sub
Créé le 13 juin 2005  par ridan

Placez un contrôle Timer et ce code :

vb
Sélectionnez
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" ( _ 
     ByVal lpszWindowName As String, _ 
     ByVal dwStyle As Long, _ 
     ByVal X As Long, _ 
     ByVal Y As Long, _ 
     ByVal nWidth As Long, _ 
     ByVal nHeight As Long, _ 
     ByVal hwndParent As Long, _ 
     ByVal nID As Long) As Long 
 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _ 
     ByVal hwnd As Long, _ 
     ByVal wMsg As Long, _ 
     ByVal wParam As Long, _ 
     ByRef lParam As Any) As Long 
 
Private Const WM_USER As Long = &H400 
Private Const WM_CAP_DRIVER_CONNECT As Long = WM_USER + 10 
Private Const WM_CAP_DRIVER_DISCONNECT As Long = WM_USER + 11 
Private Const WM_CAP_GRAB_FRAME As Long = WM_USER + 60 
Private Const WM_CAP_EDIT_COPY As Long = WM_USER + 30 
 
Private iResult As Long 
 
Private Sub Form_Load() 
 
    Timer1.Interval = 50 
    iResult = capCreateCaptureWindow("Capture", _ 
                                    0, 0, 0, _ 
                                    Picture1.ScaleWidth, _ 
                                    Picture1.ScaleHeight, _ 
                                    Me.hwnd, 0) 
    SendMessage iResult, WM_CAP_DRIVER_CONNECT, 0, 0 
 
End Sub 
 
Private Sub Form_Unload(Cancel As Integer) 
 
    SendMessage iResult, WM_CAP_DRIVER_DISCONNECT, 0, 0 
 
End Sub 
 
Private Sub Timer1_Timer() 
 
    Clipboard.Clear 
    SendMessage iResult, WM_CAP_GRAB_FRAME, 0, 0 
    SendMessage iResult, WM_CAP_EDIT_COPY, 0, 0 
    Picture1.Picture = Clipboard.GetData 
 
End Sub
Créé le 13 juin 2005  par ridan

En complément des fonctions SetAttr et GetAttr, ces fonctions de l'API Windows permettent de modifier ou de lire les attributs d'un fichier, non accessibles par VB6 :

vb
Sélectionnez
Private Const FILE_ATTRIBUTE_READONLY As Long = &H1    'Fichier en lecture seule.
Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2    'Fichier caché.
Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4    'Fichier système.
Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10    'L'élément est un répertoire.
Private Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20    'Le fichier a l'attribut archive.
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80    'Le fichier n'a pas d'attribut.
Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100    'Fichier temporaire.
Private Const FILE_ATTRIBUTE_COMPRESSED As Long = &H800    'Fichier (répertoire) compressé.
Private Const FILE_ATTRIBUTE_ENCRYPTED As Long = &H4000    ' Fichier crypté
 
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" _
(ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long

Modifier les attributs d'un fichier :

vb
Sélectionnez
Private Sub Command1_Click()
    MsgBox SetFileAttributes("C:\str.txt", FILE_ATTRIBUTE_SYSTEM)
End Sub

Lire les attributs d'un fichier :

vb
Sélectionnez
    If GetFileAttributes("C:\test.ini") And FILE_ATTRIBUTE_ENCRYPTED Then MsgBox "Fichier crypté"
Mis à jour le 2 mai 2006  par shwin, ThierryAIM

Ce code intègre un son wav sans utiliser Windows média player ou mdi.

vb
Sélectionnez
Private Const SND_APPLICATION = &H80         '  look for application specific association 
Private Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry 
Private Const SND_ALIAS_ID = &H110000    '  name is a WIN.INI [sounds] entry identifier 
Private Const SND_ASYNC = &H1         '  play asynchronously 
Private Const SND_FILENAME = &H20000     '  name is a file name 
Private Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound 
Private Const SND_MEMORY = &H4         '  lpszSoundName points to a memory file 
Private Const SND_NODEFAULT = &H2         '  silence not default, if sound not found 
Private Const SND_NOSTOP = &H10        '  don't stop any currently playing sound 
Private Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy 
Private Const SND_PURGE = &H40               '  purge non-static events for task 
Private Const SND_RESOURCE = &H40004     '  name is a resource name or atom 
Private Const SND_SYNC = &H0         '  play synchronously (default) 
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
(ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Arrêter le son :

vb
Sélectionnez
Private Sub Arreter_Click() 
PlaySound 0&, ByVal 0&, SND_FILENAME Or SND_ASYNC 
End Sub

Jouer le son :

vb
Sélectionnez
Private Sub Jouer_Click() 
    PlaySound "C:\WINDOWS\MEDIA\test.WAV", ByVal 0&, SND_FILENAME Or SND_ASYNC 
End Sub
Créé le 13 juin 2005  par odan71, Tofalu

Ce code nécessite d'activer la référence "Standard OLE Types" :

vb/vba
Sélectionnez
Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
        (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, _
        ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
 
Public Declare Function OleCreatePictureIndirect _
        Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
        ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Public Type PicBmp
   Size As Long
   tType As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type
 
Public Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type
 
Public Type SHFILEINFO
    hicon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * 260
    szTypeName As String * 80
End Type
 
 
Public Function GetIconFromFile(FileName As String, IconIndex As Long, _
        UseLargeIcon As Boolean) As IPicture
    '**************************************************************
    'Necessite d'activer la reference "Standard OLE Types"
    '**************************************************************
    Dim b As SHFILEINFO
    Dim retval As Long
    Dim pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
 
    retval = SHGetFileInfo(FileName, 0, b, Len(b), &H100)
 
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
 
    With pic
        .Size = Len(b)
        .tType = 3 'vbPicTypeIcon
        .hBmp = b.hicon
    End With
 
    Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
    Set GetIconFromFile = IPic
End Function
Créé le 3 octobre 2006  par SilkyRoad

Nécessite d'activer la référence DSO OLE Document Propeties Reader 2.1 (dsofile.dll)
Lien Microsoft pour téléchargement dll qui encapsule les interfaces "IPropertyStorage" et "IPropertySetStorage".

vb
Sélectionnez
Sub LitEcritProprieteAvancees()
    Dim dso As New DSOFile.OleDocumentProperties
    Dim docP As DSOFile.SummaryProperties
    Dim stFichier As String
    stFichier = App.Path & "\monfic.txt"
    dso.Open stFichier
    Set docP = dso.SummaryProperties
    docP.Comments = docP.Comments & IIf(docP.Comments <> "", vbCrLf, "") & "Ajout ou Modification à : " & Now
    dso.Save
End Sub
Créé le 16 septembre 2007  par DarkVader, bbil

En utilisant un objet ADODB.stream, ajouter pour cela la référence à "Microsoft ActiveX Data Object " version 2.5 ou supérieure.

vb
Sélectionnez
' Ajouter la référence Microsoft ActiveX Data Objects 2.5 ou +
    Dim stream As New ADODB.stream
    stream.Charset = "UTF-8"
    stream.Open
    stream.LoadFromFile "c:\tmp\testUTF8.txt"
    MsgBox stream.ReadText
    stream.Close
Créé le 16 septembre 2007  par forum

C'est faisable grâce aux RegExp, pensez à ajouter la référence Microsoft Regular Expressions 5.5 :

 
Sélectionnez
Function CountMatches(ByVal strFic As String, ByVal strSearch As String) As Long
 
    Dim reg As VBScript_RegExp_55.RegExp
    Dim Matches As VBScript_RegExp_55.MatchCollection
    Dim Fic As Integer
    Dim strBuff As String * 20000
    Dim strBorder As String
 
    ' instanciation
 
    Set reg = New VBScript_RegExp_55.RegExp
 
    reg.Global = True
    reg.IgnoreCase = True
    reg.Multiline = True
    reg.Pattern = "(" & strSearch & ")"
 
    ' gestion fichier
 
    Reset
    Fic = FreeFile
    Open strFic For Binary Access Read As #Fic
 
    Do While Not EOF(Fic)
        strBorder = Right(strBuff, Len(strSearch) - 1)
        Get #Fic, , strBuff
        strBorder = strBorder & strBuff
        Set Matches = reg.Execute(strBorder)
        CountMatches = CountMatches + Matches.Count
    Loop
    Close #Fic
 
    ' libération
 
    Set reg = Nothing
    Set Matches = Nothing
 
End Function

Exemple :

 
Sélectionnez
?countmatches("c:\temp\long.txt"," ")
 7500
Mis à jour le 22 décembre 2008  par Cafeine

Lien : Les Expressions Rationnelles et Access par la pratique

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