vendredi 6 janvier 2017

Compter le nombre de fichiers dans un répertoire avec une (ou des) extensions passées en paramètres

Dans un module en VBA, copier/coller le code suivant :

Sub AfficheTotalFichiers()
    Debug.Print  NombreFichiers("C:\Mes Documents\", "docx", "xlsx")
End Sub


'Fonction qui compte le nombre de fichiers dans un répertoire
Function NombreFichiers(Chemin As String, ParamArray LesExtensions() As Variant) As Long
    Dim Fichier As String
    Dim Extension As Variant
    Dim Compteur As Long
 
    For Each Extension In LesExtensions
        Fichier = Dir(Chemin & "*." & Extension)
            Do Until Fichier = ""
            Compteur = Compteur + 1
            Fichier = Dir
        Loop
    Next
 
    NombreFichiers = Compteur
End Function

mardi 31 mai 2016

Parcourir la liste des control sur un formulaire (CheckBox, TextBox, ComboBox...)


A placer dans un UserForm. Cela fonctionne sur n'importe quel type de control.

Dim objControl As Control

'variante 1
For Each objControl In Me.Controls
  If TypeOf objControl Is MSForms.TextBox Then 'modifier ici le type si nécessaire
    MsgBox objControl.Name
  End If
Next

'variante 2
For Each objControl In Me.Controls
  If TypeName(objControl) = "TextBox" Then 'modifier ici le type si nécessaire
    MsgBox objControl.Name
  End If
Next

lundi 23 mai 2016

Procédure pour supprimer du code VBA qui aurait été associé directement à une feuille de calcul

Sub PurgeCode()
    For Each VBComp In VBComps
        If VBComp.Type = 100 Then
           With VBComp.CodeModule
               .DeleteLines 1, .CountOfLines
           End With
        End If
    Next VBComp
End Sub

mercredi 11 mai 2016

Vérification de la saisie dans une TextBox

A placer sur l'événement KeyPress d'une TextBox

Gestion de certaines valeurs autorisées :

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    'n'accepte que les chiffres et le /
    If InStr("1234567890/", Chr(KeyAscii)) = 0 Then KeyAscii = 0: Beep
End Sub



Gestion de la décimale virgule / point

Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
 Select Case KeyAscii
    Case 44, 46 ' que l'on frappe une virgule ou un point
      If InStr(TextBox1.Text, ",") Then 'si déjà une virgule présent
         KeyAscii = 0 'on ne permet pas deux virgules
      Else ' sinon
        KeyAscii = 44 'on force la une virgule
      End If
    Case 48 To 57
      'on laisse passer car ce sont des chiffres
    Case Else
      KeyAscii = 0 'on ne laisse pas passer
 End Select
End Sub

mardi 8 mars 2016

Manipuler Word en Vba depuis Excel par exemple

'**************************************************************************************
'  Manipuler Word en VBA
'  ajouter la référence à Microsoft Word xx.x library au projet 

'  (Menu Projet >> Références...)
'**************************************************************************************
    

Sub GestionWord ()

   
Dim AppWord As Word.Application

    On Error Resume Next
 
    ' Cherche une instance de Word si elle existe
    Set AppWord = GetObject(, "Word.Application")
 
    If Err <> 0 Then
    ' Si GetObject échoue, utiliser CreateObject pour créer une instance de Word
        Set AppWord = CreateObject("Word.Application")
    End If
 
    ' ajoute un nouveau document
     AppWord.Documents.Add
      
     
' insère du texte au point d'insertion
     AppWord.Selection.TypeText Text:="Liste des Clients"

     ' sauter une ligne
     AppWord.Selection.TypeParagraph

     ' copie le contenu de A1 dans le document Word
     AppWord.Selection.TypeText Text:="" & Range("A1").Value

     ' enregistre les modifications
     AppWord.Documents.Save

     ' rend Word visible
     AppWord.Visible = True

    ' Quitte Word
     AppWord.Quit
 
    ' Vide l'objet en mémoire
    Set AppWord = Nothing


End Sub

lundi 21 décembre 2015

Vérifier par VBA si un lecteur ou un dossier (répertoire) ou un fichier existe

Cocher la bibliothèque  Microsoft Scripting Runtime dans Outils / Références

Dans un module en VBA, copier/coller le code suivant :

Public oFSO As Scripting.FileSystemObject
Public oFichier As Scripting.File 'pour gérer un fichier
Public oTxt As Scripting.TextStream 'pour gérer le contenu

Function VerifLecteur(Lecteur As String) As Boolean
    'permet de tester l'existence d'un lecteur
    'initialisation de l'objet oFSO
    Set oFSO = New Scripting.FileSystemObject
    'test si le lecteur  existe
    If oFSO.DriveExists(Lecteur) = True Then
        VerifLecteur = True
    Else
        VerifLecteur = False
    End If
End Function

Function VerifRep(Repertoire As String) As Boolean
    'permet de tester l'existence d'un répertoire
    'initialisation de l'objet oFSO
    Set oFSO = New Scripting.FileSystemObject
    'test si le lecteur  existe
    If oFSO.FolderExists(Repertoire) = True Then
        VerifRep = True
    Else
        VerifRep = False
    End If
End Function

Function VerifFich(Fichier As String) As Boolean
    'permet de tester l'existence d'un fichier
    'initialisation de l'objet oFSO
    Set oFSO = New Scripting.FileSystemObject
    'test si le lecteur  existe
    If oFSO.FileExists(Fichier) = True Then
        VerifFich = True
    Else
        VerifFich = False
    End If
End Function


Dans un autre module, faire appel à ces fonctions, par exemple de la manière suivante :

Sub Test()
    'initialisation de l'objet oFSO
    Set oFSO = New Scripting.FileSystemObject
 
    'test sur un lecteur
    If VerifLecteur("P") = True Then
        MsgBox "le lecteur existe"
    Else
        MsgBox "le lecteur n'existe pas"
    End If

    'test sur un dossier (répertoire)
    If VerifRep("C:\Android") = True Then
        MsgBox "le repertoire existe"
    Else
        MsgBox "le repertoire n'existe pas"
    End If
 
    'test sur un fichier
    If VerifFich("C:\Windows\win.ini") = True Then
        MsgBox "le fichier existe"
    Else
        MsgBox "le fichier n'existe pas"
    End If


End Sub

lundi 3 août 2015

Intercepter touche Entrée dans un TextBox

Il suffit d'utiliser l'événement "KeyDown" et de vérifier si le code renvoyé correspond à la touche ENTREE

Private Sub TexBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then
        'mon code
    End If
End Sub