Exemples

Consultation - modification - boutons suivant/précédent

Form consultation simple
Form ajout modif sup tableau dynamique
Form modification
Form Consult/Modification/Ajout trié
Form Consult/Modification/Ajout trié Camping
Form ajout modif sup tableau dynamique
Form ajout modif sup tableau dynamique 3

Affiche la fiche suivante/précédente.

Form consultation suivant précédent

Dim ligne
Dim maBD
Private Sub UserForm_Initialize()
  Set maBD = Sheets("BD")
  maBD.[A2:H2000].Sort key1:=maBD.[B2] ' Tri la BD
  Me.ChoixNom.List = Range(maBD.[B2], maBD.[B65000].End(xlUp)).Value
  Me.ChoixNom.ListIndex = 0
End Sub

Private Sub ChoixNom_Change()
  ligne = [B2].Offset(ChoixNom.ListIndex, 0).Row
  Me.nom = maBD.Cells(ligne, 2)
  Me.Marié = maBD.Cells(ligne, 3)
  Me.date_naissance = maBD.Cells(ligne, 4)
  Me.service = maBD.Cells(ligne, 5)
  Me.ville = maBD.Cells(ligne, 6)
  Me.Salaire = maBD.Cells(ligne, 7)
  '-- civilité
  For Each c In Me.Civilité.Controls
    If maBD.Cells(ligne, "a") = c.Caption Then c.Value = True
  Next c
  '---
  Répertoire = ThisWorkbook.Path
  If Dir(Répertoire & "\" & Me.nom & ".jpg") <> "" Then
    Me.Image1.Picture = LoadPicture(Répertoire & "\" & Me.nom & ".jpg")
  Else
    Me.Image1.Picture = LoadPicture
  End If
End Sub

Private Sub B_suivant_Click()
 If Me.ChoixNom.ListIndex < Me.ChoixNom.ListCount - 1 Then
   Me.ChoixNom.ListIndex = Me.ChoixNom.ListIndex + 1
  End If
End Sub

Private Sub b_précédent_Click()
  If Me.ChoixNom.ListIndex > 0 Then
    Me.ChoixNom.ListIndex = Me.ChoixNom.ListIndex - 1
  End If
End Sub

Private Sub b_fin_Click()
   Unload Me
End Sub

Formulaire de consultation/modification/Ajout trié

Le combobox ChoixNom est trié.

Form Consultation Modification Ajout Trié
Form Consultation Modification Ajout Trié Filtre
Form Consultation Modification Ajout Trié Filtre2
Form Consultation Modification Ajout Trié photo
Form Consultation Modification Ajout Trié Tableau Dyn
Form Consultation Modification Ajout Trié Tableau Dyn Photo
Form Consultation Modification Ajout Armoire Tableau Dyn Photo
Form Consultation Modification Ajout Trié Tableau Dyn Gestion stock Photo
Form Consultation Modification Ajout Trié Tableau Groupes Options

Dim f, ligneEnreg
Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  lignefin = f.[a65000].End(xlUp).Row
  If lignefin > 2 Then
    Clé = f.Range("A2:A" & f.[a65000].End(xlUp).Row)
    Tri Clé, LBound(Clé), UBound(Clé)
    Me.CléCherchée.List = Clé
    Me.CléCherchée.ListIndex = -1
  Else
    If lignefin = 2 Then Me.CléCherchée.AddItem f.Range("A2")
  End If
  Me.Service.List = Array("Etudes", "Informatique", "Marketing", "Production")
  Me.Loisirs.List = Array("Lecture", "Cinéma", "Vélo", "Natation", "Internet")
  B_ajout_Click
End Sub

Private Sub CléCherchée_Click()
  ligneEnreg = f.[A:A].Find(Me.CléCherchée, LookIn:=xlValues).Row
  Me.enreg = ligneEnreg
  Me.nom = f.Cells(ligneEnreg, 1)
  Me.Marié = f.Cells(ligneEnreg, 3)
  Me.Date_naissance = f.Cells(ligneEnreg, 4)
  Me.Service = f.Cells(ligneEnreg, 5)
  Me.Ville = f.Cells(ligneEnreg, 6)
  Me.Salaire = f.Cells(ligneEnreg, 7)
  '-- civilité
  For Each c In Me.Civilité.Controls
    If f.Cells(ligneEnreg, "b") = c.Caption Then c.Value = True
  Next c
  '--- loisirs
  temp = f.Cells(ligneEnreg, 8)
  a = Split(temp, ";")
  For j = 0 To Me.Loisirs.ListCount - 1: Me.Loisirs.Selected(j) = False: Next j
  If UBound(a) >= 0 Then
    For j = 0 To Me.Loisirs.ListCount - 1
      If Not IsError(Application.Match(Me.Loisirs.List(j), a, 0)) Then
        Me.Loisirs.Selected(j) = True
      Else
        Me.Loisirs.Selected(j) = False
      End If
    Next j
  End If
End Sub

Private Sub B_validation_Click()
  If Me.nom = "" Then
    MsgBox "Saisir un nom"
    Me.nom.SetFocus
    Exit Sub
  End If
  If Not IsDate(Me.Date_naissance) Then
    MsgBox "Saisir une date"
    Me.Date_naissance.SetFocus
    Exit Sub
  End If
  If Not IsNumeric(Me.Salaire) Then
    MsgBox "Saisir un salaire"
    Me.Salaire.SetFocus
    Exit Sub
  End If
  '--- Transfert Formulaire dans BD
  f.Cells(ligneEnreg, 1) = Application.Proper(Me!nom)
  f.Cells(ligneEnreg, 3) = Me.Marié 'OuiNon(Me.Marié)
  f.Cells(ligneEnreg, 4) = CDate(Me.Date_naissance)
  f.Cells(ligneEnreg, 5) = Me.Service
  f.Cells(ligneEnreg, 6) = Me.Ville
  f.Cells(ligneEnreg, 7) = CDbl(Me.Salaire)
  '-- Civilité
  temp = ""
  For Each c In Me.Civilité.Controls
    If c.Value = True Then
      temp = c.Caption
    End If
   Next c
   f.Cells(ligneEnreg, 2) = temp
   '-- loisirs
   temp = ""
   For i = 0 To Me.Loisirs.ListCount - 1
     If Me.Loisirs.Selected(i) = True Then temp = temp & Me.Loisirs.List(i) & ";"
   Next i
   f.Cells(ligneEnreg, 8) = temp
   UserForm_Initialize
End Sub

Private Sub B_ajout_Click()
  ligneEnreg = f.[a65000].End(xlUp).Row + 1
  Me.enreg = ligneEnreg
  Me.nom = ""
  Me.Marié = False
  Me.Date_naissance = ""
  Me.Service = ""
  Me.Ville = ""
  Me.Salaire = ""
  For j = 0 To Me.Loisirs.ListCount - 1: Me.Loisirs.Selected(j) = False: Next j
  Me.nom.SetFocus
End Sub

Private Sub B_suivant_Click()
  If Me.CléCherchée.ListIndex < Me.CléCherchée.ListCount - 1 Then
    Me.CléCherchée.ListIndex = Me.CléCherchée.ListIndex + 1
  End If
End Sub

Private Sub b_précédent_Click()
  If Me.CléCherchée.ListIndex > 0 Then
    Me.CléCherchée.ListIndex = Me.CléCherchée.ListIndex - 1
   End If
End Sub

Private Sub B_sup_Click()
  If MsgBox("Etes vous sûr de suppimer " & f.Cells(ligneEnreg, 1) & "?", vbYesNo) = vbYes Then
    ncol = 8
    f.Cells(ligneEnreg, 1).Resize(, ncol).Delete Shift:=xlUp
    UserForm_Initialize
  End If
End Sub

Intuitif Textbox/ListBox

Intuitif textbox/ListBox

Option Compare Text
Dim nomTableau, TblBD(), nbCol

Private Sub UserForm_Initialize()
  nomTableau = "Tableau1"
  nbCol = Range(nomTableau).Columns.Count
  TblBD = Range(nomTableau).Resize(, nbCol + 1).Value ' Array: + rapide
  For i = 1 To UBound(TblBD): TblBD(i, nbCol + 1) = i: Next i ' No enregistrement
  LabelsTextBox
  TextBoxRecherche_Change
End Sub

Private Sub TextBoxRecherche_Change()
  ColRecherche = 1
  ColRecherche2 = 2
  clé = Me.TextBoxRecherche & "*": n = 0
  Dim Tbl()
  For i = 1 To UBound(TblBD)
     If TblBD(i, ColRecherche) Like clé Or TblBD(i, ColRecherche2) Like clé Then
        n = n + 1: ReDim Preserve Tbl(1 To 3, 1 To n)
        For k = 1 To 2: Tbl(k, n) = TblBD(i, k): Next k
        Tbl(3, n) = TblBD(i, nbCol + 1)
     End If
   Next i
   If n > 0 Then Me.Listbox1.Column = Tbl Else Me.Listbox1.Clear
End Sub

Private Sub Listbox1_Click()
  ligneEnreg = Me.Listbox1.Column(2)
  Me.Enreg = ligneEnreg
  For k = 1 To nbCol
      Me("textbox" & k) = TblBD(ligneEnreg, k)
  Next k
End Sub

Sub LabelsTextBox()
For c = 1 To nbCol
Me("textbox" & c).Width = Range(nomTableau).Columns(c).Width * 1.3
tmp = Range(nomTableau).Offset(-1).Item(1, c)
Me("label" & c).Caption = tmp
lg = Len(tmp): If Len(tmp) > 20 Then lg = 20
Me("label" & c).Width = lg * 8
Next
End Sub

Sub raz()
For k = 1 To nbCol
Me("textBox" & k) = ""
Next k
Me.TextBox1.SetFocus
End Sub

Formulaire de modification général

C'est un programme générique. Le code est le même pour toutes les BD.
Les noms des champs du formulaire sont les titres de la BD. On peut donc ajouter des champs dans la BD ou les déplacer sans modifier la programmation.

Form général Consultation/modification/création
Form général Consultation/modification/création 2
Form général Consultation/modification/création 3
Form général Consultation/modification/création photo
Form général Consultation/modification/création intuitif

Pour vérifier que les options ont bien été cochées.

'---- contrôles particuliers
For Each c In Me.Controls
  If TypeName(c) = "Frame" Then
  témoin = False
  For Each opt In c.Controls
    If opt.Value Then témoin = True
  Next opt
  If témoin = False Then MsgBox c.Name & "Non coché!": Controls(c.Name).SetFocus: Exit Sub
 End If
Next c

Option Compare Text
Dim f, ligneEnreg
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Clé = Application.Transpose(f.Range("A2:A" & f.[a65000].End(xlUp).Row).Value)
  Tri Clé, LBound(Clé), UBound(Clé)
  Me.CléCherchée.List = Clé
  Me.Loisirs.List = Array("Lecture", "Cinéma", "Vélo", "Natation", "Internet")
  Me.service.List = Array("A", "B", "C")
  ligneEnreg = f.[a65000].End(xlUp).Row + 1
  Me.CléCherchée.SetFocus
End Sub

Private Sub CléCherchée_click()
  ligneEnreg = Sheets("BD").[A:A].Find(CléCherchée, LookIn:=xlValues).Row
  For Each c In Me.Controls
    nom_control = c.Name
    If nom_control <> "CléCherchée" And nom_control <> "Enreg" Then
      col = Application.Match(nom_control, [titre], 0)
      Select Case TypeName(c)
         Case "TextBox", "ComboBox"
           Me(nom_control) = f.Cells(ligneEnreg, col)
        Case "Frame"
          For Each opt In c.Controls
            If f.Cells(ligneEnreg, col) = opt.Caption Then opt.Value = True
         Next opt
       Case "CheckBox"
         Me(nom_control) = f.Cells(ligneEnreg, col)
       Case "ListBox"
         temp = f.Cells(ligneEnreg, col)
        a = Split(temp, ";")
        For j = 0 To Me(nom_control).ListCount - 1: Me(nom_control).Selected(j) = False: Next j
        If UBound(a) >= 0 Then
         For j = 0 To Me(nom_control).ListCount - 1
           If Not IsError(Application.Match(Me(nom_control).List(j), a, 0)) Then
             Me(nom_control).Selected(j) = True
           Else
             Me(nom_control).Selected(j) = False
           End If
         Next j
       End If
     End Select
   End If
  Next c
  Me.Enreg = ligneEnreg
  Me.CléCherchée.SetFocus
End Sub

Private Sub bt_valider_Click()
  If Me.NomPrenom = "" Or ligneEnreg = 0 Then Exit Sub
  If MsgBox("Etes-vous certain de vouloir modifier ce contact ?", vbYesNo, "Demande de confirmation") =     vbYes And ligneEnreg > 1 Then
    For Each c In Me.Controls
      nom_control = c.Name
      If nom_control <> "CléCherchée" And nom_control <> "Enreg" Then
         col = Application.Match(nom_control, [titre], 0)
         Select Case TypeName(c)
           Case "TextBox", "ComboBox"
              tmp = Me(nom_control)
              If IsNumeric(tmp) Then
                 If InStr(tmp, " ") > 0 Then  tmp = "'" & tmp  Else tmp = CDbl(tmp)
              End If
              If IsDate(tmp) Then tmp = CDate(tmp)
              f.Cells(ligneEnreg, col) = tmp
           Case "CheckBox"
              tmp = Me(nom_control)
              f.Cells(ligneEnreg, col) = tmp
           Case "Frame"
              For Each opt In c.Controls
                  If opt.Value = True Then f.Cells(ligneEnreg, col) = opt.Caption
              Next opt
           Case "ListBox"
              temp=""
              For i = 0 To Me(nom_control).ListCount - 1
                If Me(nom_control).Selected(i) = True Then
                   temp = temp & Me(nom_control).List(i) & ";"
                End If
              Next i
              f.Cells(ligneEnreg, col) = temp
          End Select
       End If
    Next c
    raz
    UserForm_Initialize
    ligneEnreg = f.[a65000].End(xlUp).Row + 1
  End If
End Sub

Formulaire de consultation/modification doublons avec saisie intuitive

-L'opérateur frappe les premières lettres du nom cherché.
-Les noms en doublon sont affichés dans une ListBox.
-Les libellés des champs du formulaire s'adaptent automatiquement aux titres de la BD. On peut déplacer des champs de la BD ou en ajouter sans modifier le programme.

Form Consultation/modification
Form Consultation/modification doublons intuitif
Form Consultation intuitif cases-options

Recherche par nom +prénom

Recherche Nom + prénom
Recherche Nom + prénom intuitif

Option Compare Text
Dim f, ligneEnreg, Tblclé(), tblBD()
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:B" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  tblBD = Range("A2:G" & [A65000].End(xlUp).Row).Value ' BD
  Call Tri2col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

Version avec index dans la troisième colonne du ComboBox

Sur cette version, on ajoute dans la troisième colonne de la table TblClé() les numéros d'enregistrements pour retrouver plus tard directement l'enregistrement choisi dans le combobox

Recherche Nom + prénom avec no enreg

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:C" & [A65000].End(xlUp).Row).Value ' Nom+Prénom
  For i = 1 To UBound(Tblclé): Tblclé(i, 3) = i+1: Next i   ' Index dans la troisième colonne
  Call Tri2Col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

L'enregistrement choisi dans le combobox est retrouvé avec :

ligneEnreg = Me.ChoixNom.Column(2)

Doublons sur Nom+prénom

On affiche la ville dans le ComboBox de recherche

Recherche Nom + prénom + ville avec no enreg
Recherche Nom + prénom + ville avec no enreg photo
Recherche Nom + prénom + ville avec no enreg intuitif_photo

Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Tblclé = Range("A2:D" & [A65000].End(xlUp).Row).Value             ' Nom+Prénom
  For i = 1 To UBound(Tblclé): Tblclé(i, 3) = f.Cells(i + 1, 7): Next i ' ville
  For i = 1 To UBound(Tblclé): Tblclé(i, 4) = i + 1: Next i                ' index
  Call Tri2Col(Tblclé, LBound(Tblclé), UBound(Tblclé))
  Me.ChoixNom.List = Tblclé
End Sub

Choix intuitif de la ville & du code postal dans un combobox

La liste des villes apparaît au fur et à mesure de la frappe des caractères.

Form Saisie Ville CodePostal Intuitif

Recherche dans une colonne de BD (choix de la colonne de recherche)

Sur cet exemple, on choisi la colonne de recherche dans un ComboBox.

Recherche BD
Recherche BD Intuitif
Recherche BD Photo

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  col = f.[iv1].End(xlToLeft).Column
  Me.ComboBox1.List = Application.Transpose(f.[a1].Resize(, col))
End Sub

Private Sub ComboBox1_click()
  col = Me.ComboBox1.ListIndex
  n = f.[a65000].End(xlUp).Row - 1
  Me.ComboBox2.List = f.[A2].Offset(, col).Resize(n).Value
  Me.choixitem.Caption = "choix " & Me.ComboBox1
End Sub

Private Sub ComboBox2_Click()
  ligneEnreg = Me.ComboBox2.ListIndex + 2
  For Z = 1 To 12
    Me("label" & Z).Caption = f.Cells(1, Z)
    Me("textbox" & Z) = f.Cells(ligneEnreg, Z)
  Next Z
End Sub

Saisie de vente de produits avec Maj Stock

Nous mettons à jour le stock avec les ventes.

Maj stock
Saisie ventes de produits & maj stock
Saisie ventes de produits & maj stock2
Saisie ventes de produits & maj stock3
Saisie commande de produits & maj stock

Sub majstock()
  Set f = Sheets("stock") ' lecture stock dans dico
  Set d = CreateObject("scripting.dictionary")
  Set Rng = f.Range("A3:A" & f.[A65000].End(xlUp).Row)
  For Each c In Rng
     If c.Value <> "" Then d(c.Value) = c.Offset(, 1)
  Next c
  '---- soustraction des ventes du stock
  Set Rng2 = f.Range("D3:D" & f.[D65000].End(xlUp).Row)
  For Each c In Rng2
    If c.Value <> "" Then d(c.Value) = d(c.Value) - c.Offset(, 1)
  Next c
  f.[A3].Resize(d.Count) = Application.Transpose(d.keys)
  f.[B3].Resize(d.Count) = Application.Transpose(d.items)
End Sub

Recherche BD par nom, ville et activité + Modif +ajout

Recherche Modif Ajout BD

Ajout à une liste

Si l'élément frappé n'appartient pas à la liste, il est ajouté (Liste dans le tableur)

- FormAjoutListe -

Private Sub Choix_Exit(ByVal Cancel As MSForms.ReturnBoolean)
  If IsError(Application.Match(Me.Choix, Range("liste"), 0)) And Me.Choix <> "" Then
    Range("liste").End(xlDown).Offset(1, 0) = Me.Choix
    Range("liste").Sort key1:=Range("liste")(1)
 End If
End Sub

Liste des feuilles du classeur actif

Private Sub UserForm_Initialize()
  For i = 1 To Sheets.Count
    Me.ComboBox1.AddItem Sheets(i).Name
  Next i
End Sub

Création de fiches achat/vente avec photos

Achat Vente
Formulaire Création Pièces Ventes

Dim bdAchat, répertoirePhoto
Private Sub UserForm_Initialize()
  Set bdAchat = Sheets("Achat")
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = bdAchat.Cells(lignefin, 1) + 1
  Me.TYpeAchat.List = Range("type").Value
  Me.Facture.List = Range("ouinon").Value
  Me.DateAchat = Date
  répertoirePhoto = "c:\mesdoc" ' Adapter
  nf = Dir(répertoirePhoto & "\*.jpg")
  Do While nf <> ""
    Me.ChoixPhoto.AddItem nf
    nf = Dir
  Loop
End Sub

Private Sub ChoixPhoto_click()
  Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & ChoixPhoto)
End Sub

Private Sub B_validation_Click()
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Dim c As Control
  For Each c In Me.Controls
     pos = Val(c.Tag)
     If pos <> 0 Then
       If IsNumeric(c) Then
         bdAchat.Cells(lignefin + 1, pos) = Val(c)
       Else
          If IsDate(c) Then
             bdAchat.Cells(lignefin + 1, pos) = CDate(c)
          Else
            bdAchat.Cells(lignefin + 1, pos) = c
          End If
        End If
       End If
     Next c
     raz
     Me.Id.SetFocus
     lignefin = bdAchat.[A65000].End(xlUp).Row
     Me.Id = bdAchat.Cells(lignefin, 1) + 1
     Me.Image1.Picture = LoadPicture
End Sub

Sub raz()
  Dim c As Control
  For Each c In Me.Controls
    Select Case TypeName(c)
      Case "TextBox", "ComboBox"
        c.Value = ""
     Case "Picture"
        c.Picture = LoadPicture
    End Select
  Next c
End Sub

Liste des macros des modules

La liste des procédures est affiché dans un formulaire non modal.

- ActiveSub -

Private Sub UserForm_Initialize()
' Outils/Macros/Sécurité/Sources fiables/Cocher Faire confiance au projet Visual Basic
  For Each c In ActiveWorkbook.VBProject.VBComponents
    For ligne = 1 To c.CodeModule.CountOfLines
      temp = Trim(c.CodeModule.Lines(ligne, 1))
      If Left(temp, 3) = "Sub" Then Me.ComboBox1.AddItem Mid(Left(temp, Len(temp) - 2), 4)
    Next
  Next
End Sub

Private Sub ComboBox1_Change()
   Application.Run Me.ComboBox1
End Sub

Private Sub Workbook_Open()
   UserForm1.Show
End Sub

Lien hyper-texte sur formulaire

- Form Hyper-Lien -

Private Sub MonLien_Click()
  On Error Resume Next
  ActiveWorkbook.FollowHyperlink Address:=Me.MonLien.Caption, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Changement couleur au survol

Private Sub Monlien_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If X < 2 Or X > Monlien.Width - 2 Or Y < 5 Or Y > Monlien.Height - 5 Then
    Me.Monlien.ForeColor = RGB(0, 0, 0)
  Else
    Me.Monlien.ForeColor = RGB(255, 0, 0)
  End If
End Sub

Private Sub MonMail_Click()
  On Error Resume Next
  ActiveWorkbook.FollowHyperlink Address:="mailto:" & Me.MonMail.Caption, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Lien hypertexteListBox

ListBoxLien

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ListBox1.Clear
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = f.Cells(i, 1).Hyperlinks(1).Address
  Next i
End Sub

Private Sub ListBox1_Click()
  On Error Resume Next
  Err = 0
  ActiveWorkbook.FollowHyperlink Address:=Me.ListBox1.Column(1), NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

LienListBox
LienHyperFeuille

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub

Private Sub listbox1_Click()
  ligne = Me.ListBox1.ListIndex + 2
  temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
  On Error Resume Next
  Err = 0
  ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
  If Err <> 0 Then MsgBox "Erreur"
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   ligne = Int(Y / (ListBox1.Font.Size * 1.18))
   If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
     Me.Curseur.Visible = True
     Me.Lien.Visible = True
     Me.Adr.Visible = True
     Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
     Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
     temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
     Me.Adr.Caption = temp
     Me.ListBox1.ListIndex = -1
   Else
     Me.Curseur.Visible = False
     Me.Lien.Visible = False
     Me.Adr.Visible = False
  End If
End Sub

Version avec curseur et validation sur double-clic

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub


Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   ligne = Int(Y / (ListBox1.Font.Size * 1.18))
   If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
     Me.Lien.Visible = True
     Me.Adr.Visible = True
     Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
     temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
     Me.Adr.Caption = temp
     Me.ListBox1.ListIndex = ligne + Me.ListBox1.TopIndex
   Else
     Me.Lien.Visible = False
     Me.Adr.Visible = False
   End If
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   ligne = Me.ListBox1.ListIndex + 2
   temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
   On Error Resume Next
   Err = 0
   ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
   If Err <> 0 Then MsgBox "Erreur"
End Sub

Choix d'une photo dans un ComboBox

La liste des photos est dans la colonne A .Les fichiers sont toutes dans même répertoire c:\Photos

FormPhotoNom

Private Sub UserForm_Initialize()
  Me.ChoixPhoto.RowSource = "A2:" & "A" & [A65000].End(xlUp).Row ' nom de photos dans colonne A
End Sub

Private Sub ChoixPhoto_Change()
  répertoirePhoto = "c:\photos"
  If Dir(répertoirePhoto & "\" & Me.ChoixPhoto & ".jpg") <> "" Then
     Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & ChoixPhoto & ".jpg")
  Else
     Me.Image1.Picture = LoadPicture
  End If
End Sub

Version avec Création/Recherche/Modification/Suppression

Avec cette version,les photos ne sont pas dans le même répertoire. C'est à la création que le chemin de la photo est choisi et enregistré dans la BD.

Création & recherche
Création & recherche intuitif

Dim f, RngBD, TblBD(), LigneEnreg
  Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Set RngBD = f.Range("A2:E" & f.[A65000].End(xlUp).Row)
  RngBD.Sort key1:=Application.Index(RngBD, 1, 1) ' Tri alpha
  TblBD = RngBD.Value
  If f.[A65000].End(xlUp).Row > 1 Then Me.ComboBox1.List = TblBD
  B_ajout_Click
End Sub

Private Sub ComboBox1_click()
  EnregBD = Me.ComboBox1.ListIndex + 1
  LigneEnreg = Me.ComboBox1.ListIndex + RngBD.Row
  Me.Enreg = LigneEnreg
  Me.TextBox1 = TblBD(EnregBD, 1)
  Me.TextBox2 = TblBD(EnregBD, 2)
  Me.TextBox3 = TblBD(EnregBD, 3)
  Me.TextBox4 = TblBD(EnregBD, 4)
  Me.Chemin = TblBD(EnregBD, 5)
  If Dir(Me.Chemin) <> "" Then
    Me.Image1.Picture = LoadPicture(Me.Chemin)
  Else
    Me.Image1.Picture = LoadPicture
  End If
End Sub

Private Sub B_photo_Click()
  nf = Application.GetOpenFilename("Fichiers jpg,*.jpg")
  If Not nf = False Then
    Me.Chemin = nf
    Me.Image1.Picture = LoadPicture(nf)
  End If
End Sub

Private Sub B_valid_Click()
  If Me.TextBox1 <> "" Then
    LigneEnreg = Me.Enreg
    f.Cells(LigneEnreg, 1) = Me.TextBox1
    f.Cells(LigneEnreg, 2) = Me.TextBox2
    If IsNumeric(Me.TextBox3) Then f.Cells(LigneEnreg, 3) = CDbl(Me.TextBox3)
    If IsDate(Me.TextBox4) Then f.Cells(LigneEnreg, 4) = CDate(Me.TextBox4)
    f.Cells(LigneEnreg, 5) = Me.Chemin
    UserForm_Initialize
  End If
End Sub

Private Sub B_ajout_Click()
  LigneEnreg = f.[A65000].End(xlUp).Row + 1
  Me.Enreg = LigneEnreg
  raz
  Me.ComboBox1 = ""
  Me.Image1.Picture = LoadPicture
  Me.Chemin = ""
  Me.TextBox1.SetFocus
End Sub

Sub raz()
  For i = 1 To 4
    Me("Textbox" & i) = ""
  Next i
End Sub

Private Sub B_sup_Click()
  If MsgBox("Etes vous sûr de suppimer " & f.Cells(Enreg, 1) & "?", vbYesNo) = vbYes Then
    Enreg = Me.Enreg
    f.Cells(Enreg, 1).Resize(, UBound(TblBD, 2)).Delete Shift:=xlUp
    raz
    Me.Enreg = ""
    UserForm_Initialize
  End If
End Sub

Autre exemple

La liste est remplie avec la liste des fichiers jpg du répertoire où est situé le classeur.

Form PhotoRep

Private Sub UserForm_Initialize()
   répertoire = ThisWorkbook.Path
   nf = Dir(répertoire & "\*.jpg")
   Do While nf <> ""
      Me.ChoixPhoto.AddItem nf
      nf = Dir
   Loop
End Sub

Private Sub ChoixPhoto_Change()
   répertoire = ThisWorkbook.Path
   Me.Image1.Picture = LoadPicture(répertoire & "\" & ChoixPhoto)
End Sub

 

Bouton Toggle avec image

L'image du bouton est modifiée si le bouton est enfoncé.

ToogleImage

Private Sub ToggleButton1_Click()
  Me.ToggleButton1.Picture = IIf(ToggleButton1, Me.Image1.Picture, Me.Image2.Picture)
End Sub

Affichage des photos d'un répertoire

Le répertoire est choisi par l'opérateur.

FormPhotoNom

Private Sub B_ChoixRep_Click()
  DossierChoisi = VoirDossier("Choisir le dossier") ' voir module mod_voir_dossier
  If DossierChoisi <> "" Then
    Me.Dossier = DossierChoisi
    ChDir DossierChoisi
    UserForm_Initialize
  End If
End Sub

Private Sub UserForm_Initialize()
  ChDir CurDir()
  Me.Dossier = CurDir()
  nf = Dir("*.*")
  n = 0
  Me.ListBox1.Clear
  Do While nf <> ""
    If UCase(Right(nf, 3)) = "JPG" Or UCase(Right(nf, 3)) = "GIF" Then
      Me.ListBox1.AddItem
      Me.ListBox1.List(n, 0) = nf
      Me.ListBox1.List(n, 1) = FileLen(nf)
      n = n + 1
    End If
    nf = Dir
  Loop
  If n > 0 Then
    Me.Image1.Picture = LoadPicture(Me.Dossier & "\" & Me.ListBox1.List(0, 0))
  End If
  Me.TextBox1 = n & " Fichiers"
End Sub

Private Sub ListBox1_Click()
  Me.Image1.Picture = LoadPicture(Me.Dossier & "\" & Me.ListBox1)
End Sub

DiaporamaFormulaire
DiaporamaFormPhotosInternes

Inversion image interne au survol dans un formulaire

FormImageInterneSurvol
FormImageExterneSurvol

Affichage d'une image interne dans un formulaire

En mode direct

Pour copier une image interne dans un contrôle image d'un formulaire, Edition/Copier puis dans la propriété Picture du contrôle Edition/Coller.

En VBA

FormImageInterne

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
    Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_Change()
  Set s = f.Shapes(CStr(Me.ComboBox1))
  s.CopyPicture xlScreen, xlBitmap
  With s.Parent.ChartObjects.Add(0, 0, s.Width, s.Height).Chart
    While .Shapes.Count = 0
      DoEvents
      .Paste
    Wend
    .Export "monimage.jpg", "Jpg"
    .Parent.Delete
  End With
  Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.jpg")
  Kill "monimage.jpg"
End Sub

Autre solution

Les images sont encapsulées dans des contrôles Image

FormImageInterne3

Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("photos")
  For Each s In f.Shapes
     Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_Change()
  temp = Me.ComboBox1
  Me.Image1.Picture = f.OLEObjects(temp).Object.Picture
End Sub

Image Web dans un formulaire

FormImageWeb

Private Sub UserForm_Initialize()
  Set f = Sheets("feuil1")
  s = "https://www.google.fr/images/srpr/logo11w.png"
  Set img = ActiveSheet.Pictures.Insert(s)
  img.Left = 1
  img.Top = 1
  img.CopyPicture xlScreen, xlBitmap
  With img.Parent.ChartObjects.Add(0, 0, img.Width, img.Height).Chart
    While .Shapes.Count = 0
      DoEvents
      .Paste
    Wend
    .Export "monimage.gif", "gif"
    .Parent.Delete
  End With
  Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
  Me.Image1.Picture = LoadPicture("monimage.gif")
  img.Delete
End Sub

Filtre famille de photos dans un formulaire

Filtre famille photos

Création BD avec Photo

BDPhoto

Dim bdAchat, répertoirePhoto
Private Sub UserForm_Initialize()
  Set bdAchat = Sheets("Achat")
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = Val(bdAchat.Cells(lignefin, 1)) + 1
  Me.TYpeAchat.List = Range("type").Value
  Me.Facture.List = Range("ouinon").Value
  Me.DateAchat = Date
  répertoirePhoto = "c:\mesdoc" ' Adapter
  nf = Dir(répertoirePhoto & "\*.jpg")
  Do While nf <> ""
    Me.ChoixPhoto.AddItem nf
    nf = Dir
  Loop
End Sub

Private Sub ChoixPhoto_click()
  Me.Image1.Picture = LoadPicture(répertoirePhoto & "\" & Me.ChoixPhoto)
End Sub

Private Sub B_validation_Click()
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Dim c As Control
  For Each c In Me.Controls
    If TypeName(c) <> "Image" Then
      pos = Val(c.Tag)
      If pos <> 0 Then
        If IsNumeric(c) Then
        bdAchat.Cells(lignefin + 1, pos) = Val(c)
      Else
         If IsDate(c) Then
            bdAchat.Cells(lignefin + 1, pos) = CDate(c)
         Else
            bdAchat.Cells(lignefin + 1, pos) = c
         End If
      End If
    End If
  Else
     If Me.ChoixPhoto <> "" Then
       pos = Val(c.Tag)
       Set cel = bdAchat.Cells(lignefin + 1, pos)
       With bdAchat
         .Pictures.Insert(répertoirePhoto & "\" & Me.ChoixPhoto).Name = Me.ChoixPhoto
         .Shapes(Me.ChoixPhoto).Height = cel.Height - 2
         .Shapes(Me.ChoixPhoto).Left = cel.Left + (c.Width - .Shapes(Me.ChoixPhoto).Width) / 2 + 1
         .Shapes(Me.ChoixPhoto).Top = cel.Top + 1
         .Shapes(Me.ChoixPhoto).LockAspectRatio = msoTrue
       End With
     End If
   End If
  Next c
  raz
  Me.Id.SetFocus
  lignefin = bdAchat.[A65000].End(xlUp).Row
  Me.Id = bdAchat.Cells(lignefin, 1) + 1
  Me.Image1.Picture = LoadPicture
End Sub

Affichage d'images au survol de boutons d'options

Survol boutons d'options

Dim Bouton(1 To 4) As New ClasseBouton
Private Sub UserForm_Initialize()
  i = 0
  For Each c In Me.Controls
    If TypeName(c) = "OptionButton" Then
       i = i + 1: Set Bouton(i).GrBoutons = Me(c.Name)
    End If
  Next c
End Sub

Module de classe

Public WithEvents GrBoutons As msforms.OptionButton
Private Sub GrBoutons_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  nom = GrBoutons.Name
  UserForm1.Image1.Picture = LoadPicture("c:\photos\" & nom & ".jpg")
End Sub

Remplissage conditionnel d'un combobox

On veut remplir le combobox avec H ou F ou les deux.

RemplissageConditionnel

Private Sub OptionButton1_Click()
  RemplitCombo "H"
End Sub

Private Sub OptionButton2_Click()
  RemplitCombo "F"
End Sub

Private Sub OptionButton3_Click()
  RemplitCombo "*"
End Sub

Private Sub UserForm_Initialize()
  RemplitCombo "*"
End Sub

Sub RemplitCombo(Sexe)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
    If c.Offset(0, 1) Like Sexe Then
      If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
    End If
  Next c
  Me.ComboBox1.List = MonDico.items
  Me.ComboBox1.ListIndex = 0
End Sub

Version avec tri

Sub RemplitCombo(Sexe)
  Set MonDico = CreateObject("Scripting.Dictionary")
  For Each c In Range([A2], [A65000].End(xlUp))
     If c.Offset(0, 1) Like Sexe Then
        If Not MonDico.Exists(c.Value) Then MonDico.Add c.Value, c.Value
     End If
  Next c
  temp = MonDico.items ' le tableau temp() reçoit les éléments de MonDico
  Call Tri(temp, LBound(temp), UBound(temp)) ' tri
  Me.ComboBox1.List = temp
  Me.ComboBox1.ListIndex = 0
End Sub

Sub Tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
    Do While a(g) < ref: g = g + 1: Loop
    Do While ref < a(d): d = d - 1: Loop
      If g <= d Then
        temp = a(g): a(g) = a(d): a(d) = temp
        g = g + 1: d = d - 1
      End If
    Loop While g <= d
    If g < droi Then Call Tri(a, g, droi)
    If gauc < d Then Call Tri(a, gauc, d)
End Sub

Annuaire

Annuaire
AnnuaireParam
AnnuairePhoto
AnnuairePhoto2

Dim Btn(1 To 27) As New ClasseLettres
Dim ligne
Private Sub UserForm_Initialize()
    For b = 1 To 27: Set Btn(b).GrLettres = Me("B_" & b): Next b
    Sheets("BD").[A2:G5000].Sort key1:=Sheets("BD").[A2]
    '-- Liste des noms
    Me.Lettre = "*"
    majChoixNom
    ligne = 2
    majFiche
End Sub

Private Sub ChoixNom_Click()
  ligne = Sheets("BD").[A:A].Find(choixnom, LookIn:=xlValues).Row
  majFiche
End Sub

Sub majFiche()
   Me.nom = Sheets("BD").Cells(ligne, 1)
   Me.Service = Sheets("BD").Cells(ligne, 2)
   Me.Tph = Sheets("BD").Cells(ligne, 3)
   Me.Portable = Sheets("BD").Cells(ligne, 4)
   Me.Email = Sheets("BD").Cells(ligne, 5)
End Sub

Private Sub b_validation_Click()
   If Me.nom = "" Then
     MsgBox "Saisir un nom!"
     Me.nom.SetFocus
     Exit Sub
   End If
   Set temp = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues)
   If Not temp Is Nothing Then
      If temp.Row <> ligne Then
         MsgBox "Existe déjà!"
         Exit Sub
      End If
   End If
   '---- transfert base
   Sheets("bd").Cells(ligne, 1) = Application.Proper(Me.nom)
   Sheets("bd").Cells(ligne, 2) = Me.Service
   Sheets("bd").Cells(ligne, 3) = Me.Tph
   Sheets("bd").Cells(ligne, 4) = Me.Portable
   Sheets("bd").Cells(ligne, 5) = Me.Email
   Me.nom.SetFocus
   Sheets("BD").[A2:G5000].Sort key1:=Sheets("BD").[A2]
   ligne = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues).Row
   majChoixNom
End Sub

Private Sub B_ajout_Click()
   ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
   nettoie
End Sub

Private Sub B_sup_Click()
  rep = MsgBox("Etes vous sûr?", vbYesNo)
  If rep = vbYes Then
     Sheets("BD").Rows(ligne).Delete
     nettoie
     ligne = Sheets("BD").[A65000].End(xlUp).Row + 1
     majChoixNom
   End If
End Sub

Sub nettoie()
   Me.nom = ""
   Me.Service = ""
   Me.Tph = ""
   Me.Portable = ""
   Me.Email = ""
   Me.nom.SetFocus
End Sub

Sub majChoixNom()
  Me.choixnom.Clear
  If Me.Lettre = "*" Then
    For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
      Me.choixnom.AddItem c
    Next c
  Else
      For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
        If Left(c.Value, 1) = Me.Lettre Then Me.choixnom.AddItem c
      Next c
  End If
End Sub

Private Sub b_fin_Click()
   Unload Me
End Sub

Private Sub B_suiv_Click()
   If Me.Lettre = "*" Then
     If ligne < Sheets("BD").[A65000].End(xlUp).Row Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne + 1
          majFiche
       End If
Else
    If Left(Sheets("bd").Cells(ligne + 1, 1), 1) = Me.Lettre Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne + 1
          majFiche
       End If
    End If
End Sub

Private Sub B_prec_Click()
  If Me.Lettre = "*" Then
     If ligne > 2 Then
       If Me.nom <> "" Then b_validation_Click
          ligne = ligne - 1
          majFiche
       End If
   Else
      If Left(Sheets("bd").Cells(ligne - 1, 1), 1) = Me.Lettre Then
         If Me.nom <> "" Then b_validation_Click
           ligne = ligne - 1
           majFiche
         End If
      End If
End Sub

Module de classe

Public WithEvents GrLettres As MSForms.CommandButton
Private Sub GrLettres_Click()
   F_Lettre2.Lettre = GrLettres.Caption
   F_Lettre2.choixnom.Clear
      If GrLettres.Caption = "*" Then
        For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
          F_Lettre2.choixnom.AddItem c
        Next c
      Else
        For Each c In Range(Sheets("BD").[A2], Sheets("BD").[A65000].End(xlUp))
           If Left(c.Value, 1) = GrLettres.Caption Then F_Lettre2.choixnom.AddItem c
        Next c
      End If
      If F_Lettre2.choixnom.ListCount > 0 Then
         F_Lettre2.choixnom.ListIndex = 0
      End If
End Sub

Saisie dans un tableau à 2 dimensions

Noms de champ
Ca =DECALER($B$2;;;NBVAL($A:$A);NBVAL($1:$1))
Mois =DECALER($B$1;;;;NBVAL($1:$1))
produit =DECALER($A$2;;;NBVAL($A:$A))

- FormIndex -

Private Sub UserForm_Initialize()
  Me.ComboBox1.RowSource = "produit"
  Me.ComboBox2.List = Application.Transpose([mois])
End Sub

Private Sub CommandButton1_Click()
  If Not IsNumeric(Me.TextBox1) Then
     MsgBox "Saisir du num!"
  Else
     Application.Index([CA], Me.ComboBox1.ListIndex + 1, Me.ComboBox2.ListIndex + 1) = CDbl(Me.TextBox1)
  End If
End Sub

Choix d'un onglet dans un formulaire

Un formulaire non modal permet de sélectionner une feuille du classeur.

Private Sub UserForm_Initialize()
  For Each s In ActiveWorkbook.Sheets
    Me.ComboBox1.AddItem s.Name
  Next s
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
  m = Me.ComboBox1
  Sheets(m).Select
End Sub

La liste des onglets est affichée automatiquement au survol du formulaire. -Form Choix onglet -

Private Sub UserForm_Initialize()
  Dim temp()
  For i = 1 To Sheets.Count
    ReDim Preserve temp(1 To i)
    temp(i) = Sheets(i).Name
  Next i
  n = UBound(temp)
  Call Tri(temp, 1, n)
  Me.ComboBox1.List = temp
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Me.Show
  Me.ComboBox1.SetFocus
  SendKeys "{F4}"
End Sub

Private Sub ComboBox1_Change()
  m = Me.ComboBox1
  Sheets(m).Select
End Sub

Sub Tri(a, gauc, droi) ' Quick sort
  ref = a((gauc + droi) \ 2)
  g = gauc: d = droi
  Do
     Do While a(g) < ref: g = g + 1: Loop
     Do While ref < a(d): d = d - 1: Loop
     If g <= d Then
       temp = a(g): a(g) = a(d): a(d) = temp
       g = g + 1: d = d - 1
     End If
  Loop While g <= d
  If g < droi Then Call Tri(a, g, droi)
  If gauc < d Then Call Tri(a, gauc, d)
End Sub

Zoom formulaire en fonction de la taille de l'écran

Dans un module:
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Function largeurEcran()
  largeurEcran = GetSystemMetrics(0)
End Function

Formulaire:
Private Sub UserForm_Initialize()
  Me.Zoom = largeurEcran * 100 / 800
End Sub

Formulaire de coloriage

Les couleurs sont définies sur l'onglet couleurs

FormColoriage
FormColoriage2
Form Coloriage Notation

Code formulaire

Dim Btn(1 To 10) As New ClasseBoutons
  Private Sub UserForm_Initialize()
  For i = 1 To 8
    Me("CommandButton" & i).BackColor = Sheets("couleurs").Cells(i, 1).Interior.Color
    Me("CommandButton" & i).ForeColor = Sheets("couleurs").Cells(i, 1).Font.Color
    Me("CommandButton" & i).Caption = Sheets("couleurs").Cells(i, 1)
    Set Btn(i).GrBoutons = Me("commandbutton" & i)
  Next i
End Sub

Module de classe ClasseBoutons

Public WithEvents GrBoutons As Msforms.CommandButton
  Private Sub GrBoutons_Click()
  Selection.Interior.Color = GrBoutons.BackColor
  Selection.Font.Color = GrBoutons.ForeColor
  Selection.Value = GrBoutons.Caption
End Sub

Version label

FormColoriage2

Code formulaire

Dim Lbl(1 To 10) As New ClasseLabel
Private Sub UserForm_Initialize()
  For i = 1 To 8
   Me("Label" & i).BackColor = Sheets("couleurs").Cells(i, 1).Interior.Color
   Me("Label" & i).ForeColor = Sheets("couleurs").Cells(i, 1).Font.Color
   Me("Label" & i).Caption = Sheets("couleurs").Cells(i, 1)
   Set Lbl(i).GrLabel = Me("Label" & i)
 Next i
End Sub

Module de classe ClasseLabel

Public WithEvents GrLabel As Msforms.Label
Private Sub GrLabel_Click()
  Selection.Interior.Color = GrLabel.BackColor
  Selection.Font.Color = GrLabel.ForeColor
  Selection.Value = GrLabel.Caption
End Sub

Bulle commentaire sur ListBox

ListBox avec curseur au survol

FormListBoxCurseurSurvol

Private Sub UserForm_Initialize()
  With Sheets(1)
    Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Lien.Visible = True
    Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
    Me.ListBox1.ListIndex = ligne + Me.ListBox1.TopIndex
  Else
    Me.Lien.Visible = False
  End If
End Sub

Un commentaire est affiché dans un TextBox en fonction de l'option survolée.

FormBulle
FormBulleCombo
FormBulleShape

Private Sub UserForm_Initialize()
   Me.ListBox1.List = [MaBD].Value
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.2))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.2 + Me.ListBox1.Top
    Me.TextBox1 = ListBox1.List(ligne + Me.ListBox1.TopIndex, 1)
  Else
    Me.Curseur.Visible = False
    Me.TextBox1 = ""
  End If
End Sub

Affichage d'une photo externe au survol d'un ListBox

SurvolListBoxImage
SurvolListBoxImage2

Private Sub UserForm_Initialize()
With Sheets("bd")
Me.ListBox1.List = .Range("A2:B" & .Range("A65000").End(xlUp).Row).Value
End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.ListBox1.ListIndex = -1
    répertoire = ThisWorkbook.Path
    photo = ListBox1.List(ligne + Me.ListBox1.TopIndex, 0) & ".jpg"
    If Dir(répertoire & "\" & photo) <> "" Then
      Me.Image1.Picture = LoadPicture(répertoire & "\" & photo)
    Else
     Me.Image1.Picture = LoadPicture
    End If
    Me.TextBox1 = ListBox1.List(ligne + Me.ListBox1.TopIndex, 1)
  Else
   Me.Curseur.Visible = False
  End If
End Sub

Affichage d'une photo interne au survol d'un ListBox

SurvolListBoxPhotoInterne

Public répertoirePhotos
Sub auto_open()
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("liste")
    lig = [Liste].Find(c, LookAt:=xlWhole).Row
    col = [Liste].Column + 1
    For Each s In f.Shapes
      If s.TopLeftCell.Address = Cells(lig, col).Address Then
        H = s.Height
        L = s.Width
        s.CopyPicture xlScreen, xlBitmap
        With s.Parent.ChartObjects.Add(0, 0, s.Width, s.Height).Chart
          While .Shapes.Count = 0
            DoEvents
            .Paste
           Wend
            .Export répertoirePhotos & c & ".jpg", "Jpg"
            .Parent.Delete
          End With
       End If
    Next s
  Next c
  UserForm1.Show
End Sub

Private Sub UserForm_Initialize()
   Me.ListBox1.List = [Liste].Value
   Me.TextBox2 = répertoirePhotos
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.ListBox1.ListIndex = -1
   On Error Resume Next
   photo = ListBox1.List(ligne + Me.ListBox1.TopIndex, 0) & ".jpg"
   On Error GoTo 0
   Me.TextBox1 = photo
   If Dir(répertoirePhotos & photo) <> "" Then
     Me.Image1.Picture = LoadPicture(répertoirePhotos & photo)
   Else
     Me.Image1.Picture = LoadPicture
   End If
  Else
    Me.Curseur.Visible = False
  End If
End Sub

Choix d'une image externe dans un combobox

L'image du produit choisi dans le combobox apparaît au survol.
Double cliquer en colonne A pour afficher le formulaire.

FormImageComboBox

Dim répertoire
Private Sub UserForm_Initialize()
  répertoire = ThisWorkbook.Path
  With Sheets("bd")
     Me.ComboBox1.List = .Range("A2:A" & .Range("A65000").End(xlUp).Row).Value
  End With
End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ComboBox1.Font.Size * 1.18))
  If ligne < Me.ComboBox1.ListCount Then
    photo = ComboBox1.List(ligne + Application.Max(Me.ComboBox1.TopIndex, 0), 0) & ".jpg"
    If Dir(répertoire & "\" & photo) <> "" Then
       Me.Image1.Picture = LoadPicture(répertoire & "\" & photo)
    Else
      Me.Image1.Picture = LoadPicture
    End If
   End If
End Sub

Private Sub ComboBox1_Change()
  ActiveCell = Me.ComboBox1
  ActiveCell.Offset(, 1).Select
  Set monimage = ActiveSheet.Pictures.Insert(repertoire & Me.ComboBox1 & ".jpg")
  monimage.Left = ActiveCell.Left + 2
  monimage.Top = ActiveCell.Top + 2
  Unload Me
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 If Target.Column = 1 Then
   UserForm3.Show
   Cancel = True
  End If
End Sub

Choix d'un hyper lien dans un listbox

HyperLienListBox

Private Sub UserForm_Initialize()
With Sheets(1)
Me.ListBox1.List = .Range("A2:C" & .Range("A65000").End(xlUp).Row).Value
End With
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ligne = Int(Y / (ListBox1.Font.Size * 1.18))
  If Y > 0.2 And Y <= ListBox1.Height - 3 And ligne < Me.ListBox1.ListCount Then
    Me.Curseur.Visible = True
    Me.Lien.Visible = True
    Me.Adr.Visible = True
    Me.Curseur.Top = ligne * ListBox1.Font.Size * 1.18 + Me.ListBox1.Top
    Me.Lien.Caption = ListBox1.List(ligne + Me.ListBox1.TopIndex, 2)
    temp = Sheets(1).Cells(ligne + Me.ListBox1.TopIndex + 2, "c").Hyperlinks(1).Address
    Me.Adr.Caption = temp
    Me.ListBox1.ListIndex = -1
  Else
    Me.Curseur.Visible = False
    Me.Lien.Visible = False
    Me.Adr.Visible = False
  End If
End Sub

Private Sub listbox1_Click()
ligne = Me.ListBox1.ListIndex + 2
temp = Sheets(1).Cells(ligne, "c").Hyperlinks(1).Address
On Error Resume Next
Err = 0
ActiveWorkbook.FollowHyperlink Address:=temp, NewWindow:=True
If Err <> 0 Then MsgBox "Erreur"
End Sub

Formulaire de recherche

Le zones de saisie du formulaire sont générées automatiquement en fonction des colonnes de la BD. Celle ci doit être située en A1.

FormRecherche

Dim f, nbCol, pointeur, ligne
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  ligne = 2
  nbCol = f.[A1].CurrentRegion.Columns.Count
  x = 11
  y = 15
  For i = 1 To nbCol
    retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
    Me("label" & i).Caption = f.Cells(1, i)
    Me("label" & i).Top = y
    Me("label" & i).Left = x
    retour = Me.Controls.Add("Forms.TextBox.1", "TextBox" & i, True)
    Me("textbox" & i).Top = y
    Me("textbox" & i).Left = x + 30
    Me("textbox" & i).Width = f.Columns(i).Width + 4
    y = y + 20
  Next
  retour = Me.Controls.Add("Forms.Label.1", "Label" & i, True)
  Me("label" & i).Caption = f.Cells(1, 1)
  Me("label" & i).Top = Me.ListBox1.Top - 10
  Me("label" & i).Left = Me.ListBox1.Left + 2
  '--
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = i
  Next
  If nbCol > 8 Then Me.Height = y + 30
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub ListBox1_Click()
  ligne = Me.ListBox1.Column(1)
  pointeur = Me.ListBox1.ListIndex
  affiche
End Sub

Private Sub b_suiv_Click()
  If pointeur < Me.ListBox1.ListCount - 1 Then
    pointeur = pointeur + 1
    ligne = Me.ListBox1.List(pointeur, 1)
    affiche
  End If
End Sub

Private Sub b_prec_Click()
  If pointeur > 0 Then
    pointeur = pointeur - 1
    ligne = Me.ListBox1.List(pointeur, 1)
    affiche
  End If
End Sub

Private Sub b_premier_Click()
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub b_dernier_Click()
  pointeur = Me.ListBox1.ListCount - 1
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub B_ok_Click()
  Me.ListBox1.Clear
  i = 0
  Set plage = f.[A1].CurrentRegion
  Set c = plage.Find(Me.MotCle, , , xlPart)
  If Not c Is Nothing Then
    premier = c.Address
    Do
      Me.ListBox1.AddItem
      lig = c.Row
      Me.ListBox1.List(i, 0) = plage.Cells(lig, 1)
      Me.ListBox1.List(i, 1) = lig
      i = i + 1
      Set c = plage.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> premier
  End If
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Private Sub b_tout_Click()
  Me.ListBox1.Clear
  For i = 2 To f.[A65000].End(xlUp).Row
    Me.ListBox1.AddItem
    Me.ListBox1.List(i - 2, 0) = f.Cells(i, 1)
    Me.ListBox1.List(i - 2, 1) = i
  Next
  pointeur = 0
  ligne = Me.ListBox1.List(pointeur, 1)
  affiche
End Sub

Sub affiche()
  For i = 1 To nbCol:
    Me("textbox" & i).Value = f.Cells(ligne, i)
    w = Evaluate("Cell(""format""," & f.Cells(ligne, i).Address & ")")
    If Left(w, 1) = "C" Then Me("textbox" & i).Value = Format(f.Cells(ligne, i), "0000.00 €")
  Next i
End Sub

Saisie de date début et date fin dans un tableau 2 colonnes

-Afficher le formulaire calendrier (double-clic)
-Cliquer sur la cellule dans la colonne Date début
-Choisir la Date début dans le calendrier
-Choisir Date Fin dans le calendrier
-Ok

Calendrier2Dates

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  F_calendrier2datesTableur.Show
  Cancel = True
End Sub

Le formulaire peut être exporté puis importé dans un autre classeur (clic-droit/exporter).

Le calendrier Microsoft :
-ne permet de choisir un intervalle de dates
-ne donne pas les jours fériés

Formulaire de saisie BD avec dates

FormSaisie2dates

Private Sub UserForm_Initialize()
  With Sheets("Listes")
    Me.Lieu.List = .Range("a2:A" & .Range("A65000").End(xlUp).Row).Value
    Me.Thème.List = .Range("b2:b" & .Range("b65000").End(xlUp).Row).Value
  End With
  F_calendrier2dates.Show
  F_calendrier2dates.Left = 190
  F_calendrier2dates.Top = 170
End Sub

Private Sub B_ok_dates_Click()
   Me.début = F_calendrier2dates.date_début
   Me.fin = F_calendrier2dates.date_fin
End Sub

Private Sub B_ok2_Click()
   If Me.Stage = "" Then
      MsgBox "Stage!"
      Me.Stage.SetFocus
      Exit Sub
  End If
  If Me.Lieu = "" Then
    MsgBox "Lieu!"
    Me.Lieu.SetFocus
    Exit Sub
  End If
  If Not IsDate(Me.début) Or Not IsDate(Me.fin) Then
     MsgBox "Dates!"
     Exit Sub
  End If
  With Sheets("BD")
    ligne = .Range("A65000").End(xlUp).Row + 1
    .Cells(ligne, 1) = Me.Stage
    .Cells(ligne, 2) = Me.Lieu
    .Cells(ligne, 3) = Me.Thème
    .Cells(ligne, 4) = CDate(Me.début)
    .Cells(ligne, 5) = CDate(Me.fin)
  End With
  Me.Stage = ""
  Me.Lieu = ""
  Me.Thème = ""
  Me.début = ""
  Me.fin = ""
End Sub

Private Sub B_fin_Click()
   Unload F_calendrier2dates
   Unload Me
End Sub

Liste des fichiers d'un répertoire dans un ListBox

Sur cet exemple, nous obtenons la liste des fichiers du répertoire du classeur où est situé le code.

FormListBoxFichiers

Private Sub UserForm_Initialize()
  repertoire = ThisWorkbook.Path & "\" ' adapter
  nf = Dir(repertoire & "*.*")   ' premier fichier
  Do While nf <> ""
    Me.ListBox1.AddItem nf
    nf = Dir                             ' fichier suivant
  Loop
End Sub

Choix de la colonne de tri dans un combobox

FormTri

Private Sub UserForm_Initialize()
  Me.ComboBox1.List = Application.Transpose([A1].CurrentRegion.Resize(1))
End Sub

Private Sub ComboBox1_Change()
  [A1].CurrentRegion.Sort Key1:=[A1].Offset(, Me.ComboBox1.ListIndex), Header:=xlGuess
End Sub

Private Sub Workbook_Open()
  UserForm1.Show
End Sub

Liste des feuilles d'un fichier

ListeFeuillesFichier

Dim repertoire
Private Sub UserForm_Initialize()
  repertoire = ThisWorkbook.Path & "\" ' adapter
  nf = Dir(repertoire & "*.xls") 'premier fichier xls
  Do While nf <> ""
    Me.ComboBox1.AddItem nf
    nf = Dir
  Loop
  Me.ComboBox1.ListIndex = 0
End Sub

Private Sub ComboBox1_Change()
  Set cnn = CreateObject("ADODB.Connection")
  Set cata = CreateObject("ADOX.Catalog")
  FichXLS = Me.ComboBox1
  cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & repertoire & FichXLS & ";Extended Properties=Excel 8.0;"
  Set cata.ActiveConnection = cnn
  Me.ListBox1.Clear
  For Each t In cata.Tables
     Me.ListBox1.AddItem Replace(Replace(t.Name, "$", ""), "'", "")
  Next t
  cnn.Close
  Set cata = Nothing
  Set cnn = Nothing
End Sub

Facture

Facture

Dim ComboProd(1 To 5) As New ClasseProdFacture
Dim TextQte(1 To 5) As New ClasseQteFacture
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboProd(b).GrProduitFact = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQteFact = Me("qte" & b): Next b
  For i = 1 To 5
    'Me("produit" & i).List = TriChamp(Application.Index([BdProduit4], , 1))
    Me("produit" & i).List = TriChamp(Range([J2], [J2].End(xlDown)))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("libellé" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 2, False)
  Me("Prix" & no) = Application.VLookup(Me("Produit" & no), [BdProduit4], 3, False)
  Calcul no
End Sub

Sub Calcul(no)
  If Me("Prix" & no) <> "" And Me("Qte" & no) <> "" Then
    Me("Total" & no) = CDbl(Me("Prix" & no)) * CDbl(Me("Qte" & no))
  End If
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("Libellé" & i)
    ActiveCell.Offset(0, 2) = Val(Me("Prix" & i))
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrProduitFact As MSForms.ComboBox
Private Sub GrProduitFact_Click()
  F_Facture.ChoixProduit Mid(GrProduitFact.Name, 8)
End Sub

Public WithEvents GrQteFact As MSForms.TextBox
Private Sub GrQteFact_change()
  F_Facture.Calcul Mid(GrQteFact.Name, 4)
End Sub

Devis multi lignes

DevisMultiLignes

Dim ComboCoul(1 To 5) As New ClasseCoul
Dim ComboProd(1 To 5) As New ClasseProd
Dim TextQte(1 To 5) As New ClasseQte
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set ComboCoul(b).GrCouleur = Me("couleur" & b): Next b
  For b = 1 To 5: Set ComboProd(b).GrProduit = Me("produit" & b): Next b
  For b = 1 To 5: Set TextQte(b).GrQte = Me("qte" & b): Next b
  For i = 1 To 5
    Me("produit" & i).List = SansDoublonsTrié(Application.Index([BdProduit2], , 1))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("couleur" & no).Clear
  For Each c In Range([J2], [j65000].End(xlUp))
    If c = Me("produit" & no) Then Me("couleur" & no).AddItem c.Offset(0, 1)
  Next c
End Sub

Sub ChoixCouleur(no)
  For i = 1 To [BdProduit2].Rows.Count
     If Me("produit" & no) = [BdProduit2].Cells(i, 1) _
        And Me("couleur" & no) = [BdProduit2].Cells(i, 2) Then
          Me("total" & no) = [BdProduit2].Cells(i, 3) * Val(Me("qte" & no))
     End If
  Next i
End Sub

Private Sub B_ok_Click()
  [D7] = Me.nom
  [D9] = Me.Rue
  [D11] = Me.Ville
  [C16].Select
  For i = 1 To 5
    ActiveCell = Me("produit" & i)
    ActiveCell.Offset(0, 1) = Me("couleur" & i)
    ActiveCell.Offset(0, 3) = Val(Me("qte" & i))
    ActiveCell.Offset(1, 0).Select
  Next i
End Sub

Modules de classe

Public WithEvents GrCouleur As MSForms.ComboBox
Private Sub GrCouleur_Click()
  F_Devis.ChoixCouleur Mid(GrCouleur.Name, 8)
End Sub

Public WithEvents GrProduit As MSForms.ComboBox
Private Sub GrProduit_Click()
  F_Devis.ChoixProduit Mid(GrProduit.Name, 8)
End Sub

Public WithEvents GrQte As MSForms.TextBox
Private Sub GrQte_change()
  F_Devis.ChoixCouleur Mid(GrQte.Name, 4)
End Sub

Choix d'une feuille

On peut créer une nouvelle feuille.

Form choix Feuille2

Autres versions

Form choix Feuille1
Form Choix FeuilleTrie1
Form Choix FeuilleTrie2
FormFeuilleCondTrié

Private Sub UserForm_Initialize()
  For Each s In ActiveWorkbook.Sheets
    Me.ComboBox1.AddItem s.Name
  Next
End Sub

Private Sub ComboBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
   temp = Me.ComboBox1.Value
   On Error Resume Next
   Sheets(Me.ComboBox1.Value).Select
   If Err > 0 Then
     If MsgBox("On ajoute?", vbYesNo) = vbYes Then
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = temp
       Me.ComboBox1.AddItem temp
     End If
  End If
End Sub

Private Sub ComboBox1_Click()
   Sheets(Me.ComboBox1.Value).Select
End Sub

Liste triée des recettes en A1 du classeur en combobox

Les noms des recettes sont en A1.

ChoixFeuille

Private Sub UserForm_Initialize()
  Dim temp()
  For i = 2 To Sheets.Count
    Me.ComboBox1.AddItem
    Me.ComboBox1.List(i - 2, 0) = Sheets(i).[A1]
    Me.ComboBox1.List(i - 2, 1) = Sheets(i).Name
  Next i
  temp = Me.ComboBox1.List
  Call tri(temp(), LBound(temp, 1), UBound(temp, 1), 2, 0)
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Change()
   m = Me.ComboBox1.Column(1)
   Sheets(m).Select
End Sub

Sub tri(a(), gauc, droi, NbCol, colTri) ' Quick sort
   ref = a((gauc + droi) \ 2, colTri)
   g = gauc: d = droi
   Do
     Do While a(g, colTri) < ref: g = g + 1: Loop
     Do While ref < a(d, colTri): d = d - 1: Loop
     If g <= d Then
       For c = 0 To NbCol - 1
         temp = a(g, c): a(g, c) = a(d, c): a(d, c) = temp
       Next
       g = g + 1: d = d - 1
     End If
   Loop While g <= d
   If g < droi Then Call tri(a, g, droi, NbCol, colTri)
   If gauc < d Then Call tri(a, gauc, d, NbCol, colTri)
End Sub

ListBox en couleur

ListBoxSimuleClasse
ListBoxSimuleSansClasse

Dim début, n
Dim Lbl(1 To 5) As New ClasseLabel
Private Sub UserForm_Initialize()
  For b = 1 To 5: Set Lbl(b).GrLabel = Me("Label" & b): Next b
    début = 1
    n = 5
    Me.ScrollBar1.Min = 1
    Me.ScrollBar1.Max = [liste].Count - n + 1
    affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
    Me("label" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1).Offset(, 1)
    Me("label" & i).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
    Me("label" & i).ForeColor = Range("liste").Cells(i + début - 1, 1).Font.Color
  Next i
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Module de classe ClasseLabel

Public WithEvents GrLabel As Msforms.Label
Private Sub GrLabel_click()
  p = Val(Mid(GrLabel.Name, 6))
  For i = 1 To 5: UserForm1.Controls("label" & i).BorderStyle = 0: Next i
  UserForm1.Controls("label" & p).BorderStyle = 1
  For Each c In Selection
    c.Value = GrLabel.Caption
    c.Font.Color = GrLabel.ForeColor
    c.Interior.Color = GrLabel.BackColor
  Next
End Sub

ListBox photo

Les photos d'origine sont dans des commentaires

ListBoxPhotoInterneCommentaire

Ce programme exporte les photos en commentaire sous forme de JPG dans un répertoire c:\photos\

Sub auto_open()
  répertoirePhotos = "c:\photos\"    ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("liste")
  For Each c In f.Range("a2:a" & f.[a65000].End(xlUp).Row)
    c.Comment.Visible = True
    H = c.Comment.Shape.Height
    L = c.Comment.Shape.Width
    c.Comment.Shape.CopyPicture
    c.Comment.Visible = False
    f.ChartObjects.Add(0, 0, L, H).Chart.Paste
    f.ChartObjects(1).Border.LineStyle = 0
    f.ChartObjects(1).Chart.Export Filename:= _
       répertoirePhotos & c & ".jpg", FilterName:="jpg"
    f.ChartObjects(1).Delete
  Next c
  UserForm1.Show
End Sub

Code du formulaire

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, répertoirePhotos
Private Sub UserForm_Initialize()
  début = 1
  n = 3
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [Liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  répertoirePhotos = "c:\photos\" ' Adapter
  For i = 1 To n
     nom = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).Picture = LoadPicture(répertoirePhotos & Range("liste").Cells(i + début - 1, 1) & ".jpg")
     Me("Image" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1)
     Me("Image" & i).BorderStyle = 0
     Me("Label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Sub ChoixClick(p, nom)
   For i = 1 To n
     Me("Image" & i).BorderStyle = 0
   Next i
   Me("Image" & p).BorderStyle = 1
   Set sel = Selection
   For Each c In Selection
     c.Value = nom
     Liste].Find(c.Value, LookAt:=xlWhole).Copy
     c.PasteSpecial Paste:=xlPasteFormats
     c.PasteSpecial Paste:=xlPasteComments
   Next c
   sel.Select
End Sub

Private Sub Image1_Click()
  ChoixClick 1, Me.Image1.ControlTipText
End Sub

Private Sub Image2_Click()
  ChoixClick 2, Me.Image2.ControlTipText
End Sub

Private Sub Image3_Click()
   ChoixClick 3, Me.Image3.ControlTipText
End Sub

Private Sub Label1_Click()
  ChoixClick 1, Me.Label1.Caption
End Sub

Private Sub Label2_Click()
ChoixClick 2, Me.Label2.Caption
End Sub

Private Sub Label3_Click()
ChoixClick 3, Me.Label3.Caption
End Sub

Les photos sont externes

ListBoxPhotoExterne

Les photos sont internes au classeur, encapsulées dans des images BO contrôles

ListBoxPhotoInterne

Renommer un fichier

RenommerFichier

Private Sub UserForm_Initialize()
  Me.Dossier = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir("*.*") ' premier
  Do While nf <> ""
     Me.ChoixFichier.AddItem nf
     nf = Dir ' suivant
  Loop
End Sub

Private Sub ChoixFichier_Click()
   Me.FichierChoisi = Me.ChoixFichier
End Sub

Private Sub B_ok_Click()
   On Error Resume Next
   Name ChoixFichier As Me.FichierChoisi
   UserForm_Initialize
End Sub

Private Sub b_dossier_Click()
   DossierChoisi = VoirDossier("Choisir le dossier")
   If DossierChoisi <> "" Then
       Me.Dossier = DossierChoisi
       ChDir DossierChoisi
   End If
   UserForm_Initialize
End Sub

Message défilant

Message défilant

Private Sub UserForm_Initialize()
Me.Label1.Caption = "Le message qui défile pendant un temps donné ..."
End Sub

Private Sub UserForm_Activate()
  n = Len(Me.Label1.Caption) * 2
  For i = 1 To n
    Me.Label1.Caption = Right(Me.Label1.Caption, Len(Me.Label1.Caption) - 1) & Left(Me.Label1.Caption, 1)
    w = 0.2
    temp = Timer
     Do While Timer < temp + w
       DoEvents
    Loop
  Next i
End Sub

Message défilant2

Dim depart, lg
Private Sub UserForm_Initialize()
  Me.Label1.Width = 700
  depart = Me.Label1.Left
  Message = "Ceci est un message défilant..."
  Me.Label1.Caption = Message & Message & Message
  lg = Len(Me.Label1.Caption)
End Sub

Private Sub UserForm_Activate()
  Me.Label1.Visible = True
  For x = depart To -(4.16 * lg - depart) Step -1
    Me.Label1.Left = x
    Me.Label1.Top = 10
    w = 0.04
    temp = Timer
    Do While Timer < temp + w
     DoEvents
    Loop
  Next x
  UserForm_Activate
End Sub

Barre d'attente

F_BarreAttente

Sub Attente()
  n = 20 ' nb de fichiers à traiter
  témoin = True ' pour empêcher fermeture du formulaire
  F_BarreAttente.Show False
  For f = 1 To n
    '-- traitement fichier
    For a = 1 To 50000000: Next a ' Simulation attente
      '--------------
      p = p + 1 / n ' calcul du pourcentage
      F_BarreAttente.Label1.Width = p * 100
      F_BarreAttente.Caption = Format(p, "0%")
      DoEvents
    Next f
    témoin = False
    Unload F_BarreAttente
End Sub

Pour empêcher la fermeture du formulaire

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  If témoin Then Cancel = True
End Sub

Autre exemple

BarreProgression

On dit ouvrir tous les fichiers commençant par A. On suppose que le temps de chargement de chaque fichier est proportionnel à la taille. On calcule d'abord la longueur totale des fichiers à traiter.

Private Sub UserForm_Activate()
  Deroule
End Sub

Private Sub Deroule()
  Application.DisplayAlerts = False
  ChDir (ActiveWorkbook.Path)
  masque = "a*.xls"
  nf = Dir(masque)
  '- taille totale
  n = 0
  Do While nf <> ""
    n = n + FileLen(CurDir() & "\" & nf)
    nf = Dir()
  Loop
  '----
  Application.StatusBar = "Attendez Svp..." & c
  nf = Dir(masque)
  Do While nf <> ""
    Workbooks.Open Filename:=nf
    ActiveWorkbook.Close
    p = p + FileLen(CurDir() & "\" & nf) / n
    UserForm1.CadreProgression.Caption = Format(p, "0%")
    UserForm1.BarreProgression.Width = p * (UserForm1.CadreProgression.Width - 15)
    UserForm1.Repaint
    nf = Dir()
   Loop
   Unload Me
   Application.StatusBar = ""
End Sub

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Création de boutons

FormCrétionBoutons

Private Sub B_crée_Click()
  For b = 1 To Me.Combien
    retour = Me.Controls.Add("Forms.OptionButton.1", "Opt" & b, True)
    Me("Opt" & b).Top = 40
    Me("Opt" & b).Left = 30 + (b - 1) * 15
  Next
End Sub

Private Sub B_sup_Click()
   For b = 1 To Me.Combien
     On Error Resume Next
     Me.Controls.Remove "opt" & b
  Next
End Sub

Private Sub b_result_Click()
   For b = 1 To Me.Combien
     On Error Resume Next
     If Me("opt" & b) Then MsgBox b
   Next
End Sub

Private Sub B_label_Click()
   retour = Me.Controls.Add("Forms.Label.1", "Label1", True)
   Me("label1").Caption = "essai"
   Me("label1").Top = 60
   Me("label1").Left = 200
End Sub

Private Sub b_sup_label_Click()
  Me.Controls.Remove "Label1"
End Sub

Simulation listBox couleur

-Permet d'obtenir une ligne sur 2 en couleur
-Permet d'afficher du texte sur plusieurs lignes

ListBoxSimul
ListBoxFiltreElaboré
ListBoxFiltreElaboré6Col

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, nLigneTxt, n, f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  début = 1
  nLigneTxt = 5
  n = nLigneTxt
  nBD = Application.CountA(f.[A:A]) - 1
  If nBD < n Then n = nBD
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = nBD - n + 1
  affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("txt1" & i).Value = f.Cells(i + début, 1)
    Me("txt2" & i).Value = f.Cells(i + début, 2)
    Me("txt3" & i).Value = f.Cells(i + début, 3)
    If i Mod 2 = 0 Then
      Me("txt1" & i).BackColor = RGB(0, 255, 0)
      Me("txt2" & i).BackColor = RGB(0, 255, 0)
      Me("txt3" & i).BackColor = RGB(0, 255, 0)
    End If
  Next i
  Me.Repaint
End Sub

Private Sub ScrollBar1_Change()
   début = ScrollBar1
   affiche
End Sub

Private Sub B_ok_Click()
  Set f = Sheets("BD")
  f.[K2] = "*" & Me.TextBox1 & "*"
  f.[A1:C10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[K1:K2],      CopyToRange:=Sheets("interro").[A1:C1]
  Set f = Sheets("interro")
  début = 1
  For i = 1 To n
    Me("txt1" & i).Value = ""
    Me("txt2" & i).Value = ""
    Me("txt3" & i).Value = ""
  Next i
  nInterro = Application.CountA(f.[A:A]) - 1
  If nInterro < n Then n = nInterro
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = nInterro - n + 1
  affiche
  n = nLigneTxt
End Sub

Simulation Listbox avec image arrière-plan

ListBoxImageFond

Editeur de cellule

-Les ajouts sont mis dans la couleur du nom d'utilisateur
-Double-cliquer sur la cellule à modifier

EditCellule

Dim couleur As String, CouleurUser As Integer
  Private Sub UserForm_Initialize()
  CouleurUser = 4
  p = Application.Match(Environ("username"), [utilisateurs], 0)
  If Not IsError(p) Then CouleurUser = Range("couleurs")(p)
  Me.TextBox1 = ActiveCell
  n = Len(Me.TextBox1)
  For i = 1 To n
    c = ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex
    If c = -4105 Then c = 255
    couleur = couleur & Chr(c)
  Next i
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  lg = TextBox1.SelLength
  If lg = 0 Then lg = 1
  If KeyCode = 46 Then ' Touche sup
    p = TextBox1.SelStart
    couleur = Left(couleur, p) & Mid(couleur, p + lg + 1)
  Else
    If KeyCode = 8 Then ' Touche backspace
       p = TextBox1.SelStart
       couleur = Left(couleur, p - 1) & Mid(couleur, p + lg)
     Else
       If KeyCode <> 37 And KeyCode <> 39 And KeyCode <> 16 Then ' 16
         p = TextBox1.SelStart
         couleur = Left(couleur, p) & Chr(CouleurUser) & Mid(couleur, p + 1)
       End If
     End If
   End If
End Sub

Private Sub B_ok_Click()
  Application.ScreenUpdating = False
  On Error Resume Next
  ActiveCell = Replace(Me.TextBox1, Chr(13), "")
  n = Len(ActiveCell)
  For i = 1 To n
    c = Asc(Mid(couleur, i, 1))
    If c = 255 Then c = -4105
    ActiveCell.Characters(Start:=i, Length:=1).Font.ColorIndex = c
  Next i
  Unload Me
End Sub

Recherche un mot dans tout le classeur

RechercheMotClasseur

Recherche d'un mot dans une colonne de BD

Recherche Mot ComboBox
Recherche Mot TextBox
Recherche Mot Formulaire

Private Sub ComboBox1_Click()
  Set fRech = Sheets("recherche")
  Set fbd = Sheets("bd")
  fRech.[J2] = "*" & Me.ComboBox1 & "*"
  fbd.Range("A1:F10000").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=fRech.Range("J1:J2"), CopyToRange:=fRech.Range("A1:F1")
End Sub

Recherche adhérent

La recherche se fait avec

-les premières lettres de la première colonne (ou de toutes les colonnes)
-lettres contenues dans la première colonne (ou de toutes les colonnes)

Le résultat est affiché dès la saisie des caractères.

Recherche Adhérent Find

Private Sub TextBox1_Change()
  Set fRech = Sheets("recherche")
  Set fbd = Sheets("bd")
  Set plageBD = fbd.[a1].CurrentRegion.Offset(1)
  ncol = plageBD.Columns.Count
  Application.ScreenUpdating = False
  fRech.[A11].Resize(100, ncol + 1).ClearContents
  Set plageRech = IIf(Me.CheckBox1, plageBD, Range(fbd.[A2], fbd.[A65000].End(xlUp)))
  Set c = plageRech.Find(Me.TextBox1 & "*", , , xlWhole)
  LigRech = 1
  If Not c Is Nothing Then
    premier = c.Address
    Do
      ligBD = c.Row - plageBD.Row + 1
      For col = 1 To ncol
        fRech.[A11].Cells(LigRech, col) = plageBD.Cells(ligBD, col)
      Next col
      fRech.[A11].Cells(LigRech, ncol + 1) = ligBD
      Set c = plageRech.FindNext(c)
      LigRech = LigRech + 1: If LigRech > 100 Then Exit Do
    Loop While Not c Is Nothing And c.Address <> premier
  End If
End Sub

Accès rapide

Accès Rapide

Private Sub ComboBox1_Click()
  p = Application.Match(CDbl(CDate(Me.ComboBox1)), [a:a], 0)
  If Not IsError(p) Then [a1].Offset(p - 1).Select
End Sub

Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
For Each c In [A3:A1000]
   If c <> "" Then Me.ComboBox1.AddItem c
Next
End Sub

Message défilant dans un label de formulaire

FormDéfilant

Dim depart, lg
Private Sub UserForm_Initialize()
  Me.Label1.Width = 700
  depart = Me.Label1.Left
  Message = "Ceci est un message défilant..."
  Me.Label1.Caption = Message & Message & Message
  lg = Len(Me.Label1.Caption)
End Sub

Private Sub UserForm_Activate()
  Me.Label1.Visible = True
  For x = depart To -(4.16 * lg - depart) Step -1
    Me.Label1.Left = x
    Me.Label1.Top = 10
    w = 0.04
    temp = Timer
    Do While Timer < temp + w
      DoEvents
    Loop
  Next x
  UserForm_Activate
End Sub

Liste des fichiers d'un répertoire

Liste fichiers répertoire

Private Sub UserForm_Initialize()
  Me.Répertoire = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir(Me.Répertoire & "\*.*") ' premier
  n = 0
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir ' suivant
    n = n + 1
  Loop
  Me.nbFichiers = n
End Sub

Private Sub ChoixFichier_Click()
  Me.FichierChoisi = Me.ChoixFichier
End Sub

Private Sub B_ok_Click()
   On Error Resume Next
   Name ChoixFichier As Me.FichierChoisi
  UserForm_Initialize
End Sub

Private Sub b_dossier_Click()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = CurDir()
      .Show
      If .SelectedItems.Count > 0 Then
        Me.Répertoire = .SelectedItems(1)
        ChDir Me.Répertoire
      Else
        Me.Répertoire = ""
      End If
      UserForm_Initialize
    End With
  Else
     DossierChoisi = VoirDossier("Choisir le dossier")
     If DossierChoisi <> "" Then
       Me.Répertoire = DossierChoisi
       ChDir DossierChoisi
   End If
   UserForm_Initialize
  End If
End Sub

Visualisation d'un fichier texte

VisuTxt

Private Sub UserForm_Initialize()
  Me.Dossier = CurDir()
  Me.ChoixFichier.Clear
  Me.Texte = ""
  nf = Dir("*.txt") ' premier
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir ' suivant
  Loop
End Sub

Private Sub ChoixFichier_Click()
  Open Me.ChoixFichier For Input As #1
  MonTexte = ""
  Do While Not EOF(1)
     Line Input #1, ligne
     MonTexte = MonTexte & ligne & Chr(13)
  Loop
  Close #1
  Me.Texte = MonTexte
End Sub

Simulation ListBox couleur

ListBoxSimuleClasse
ListBoxSimuleClasseSansClasse

Dim début, n
Private Sub UserForm_Initialize()
  début = 1
  n = 5
  Me.ScrollBar1.Min = 1
  Me.ScrollBar1.Max = [liste].Count - n + 1
  affiche
End Sub

Sub affiche()
  For i = 1 To n
    Me("label" & i).Caption = Range("liste").Cells(i + début - 1, 1)
    Me("label" & i).ControlTipText = Range("liste").Cells(i + début - 1, 1).Offset(, 1)
    Me("label" & i).BackColor = Range("liste").Cells(i + début - 1, 1).Interior.Color
    Me("label" & i).ForeColor = Range("liste").Cells(i + début - 1, 1).Font.Color
  Next i
End Sub

Private Sub ScrollBar1_Change()
  début = ScrollBar1
  affiche
End Sub

Private Sub Label1_Click()
  p = 1
  ChoixClick p
End Sub

Simulation ComboBox avec éléments de couleurs différentes

ComboBox 1 colonne couleur simule

Saisie de numéro de téléphone avec masque de saisie

-Cliquer dans la cellule
-Saisir le no de tph
-Valider avec la touche Entrée

On peut utiliser les flèches et la touche Suppr

Form Saisie Téléphone Tableur
Form Saisie Téléphone
Form Saisie Code Postal

Gestion de prêts de voitures

Prêt voitures

Formulaire de coloriage

Formulaire coloriage

Evénements endogènes

Evénements endogènes

Option Compare Text
Dim TblBD()
Private Sub UserForm_Initialize()
  Set Rng = [A2:B10]
  TblBD = Rng.Value
  Me.ComboBox1.List = Array("*", "Lyon", "Paris")
  Me.ComboBox1.ListIndex = 0 ' déclenche l'événement Click ComboBox
  'Me.ListBox1.ListIndex = 0 ' déclenche l'événement Click ListBox
End Sub

Private Sub ComboBox1_click()
  Dim Tbl(): n = 0
  For i = 1 To UBound(TblBD)
    If TblBD(i, 2) Like Me.ComboBox1 Then
       n = n + 1: ReDim Preserve Tbl(1 To 2, 1 To n)
       For k = 1 To UBound(TblBD, 2): Tbl(k, n) = TblBD(i, k): Next k
    End If
  Next i
  Me.ListBox1.Column = Tbl
End Sub

Private Sub ListBox1_click()
  MsgBox "coucou"
End Sub

Private Sub B_modif_Click()
  Position = Me.ListBox1.ListIndex
  'Me.ListBox1.ListIndex = -1        ' si on active cette ligne, plus de problème d'événement endogène
  Me.ListBox1.List(Position, 0) = "xx" ' déclenche l'événement Click ListBox
End Sub

Problème de Rowsource

Rowsource

Liste différence dans un combobox

Liste différence dans un combobox

Dim f, f2
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  n = f.[A65000].End(xlUp).Row
  a = f.Range("A2:A" & n)
  Set f2 = Sheets("Choisis")
  b = f2.Range("C2:C" & n)
  Me.ComboBox1.List = Diff(a, b)
End Sub

Private Sub B_ok_Click()
  f2.Cells(f2.[C65000].End(xlUp).Row + 1, "c") = Me.ComboBox1
  n = f.[A65000].End(xlUp).Row
  a = f.Range("A2:A" & n)
  Set f2 = Sheets("Choisis")
  b = f2.Range("C2:C" & n)
  Me.ComboBox1.List = Diff(a, b)
End Sub

Function Diff(a, b)
  Set d1 = CreateObject("Scripting.Dictionary")
  For Each c In b: d1(c) = c: Next c
  Set d2 = CreateObject("Scripting.Dictionary")
  For Each c In a
    If Not d1.Exists(c) Then d2(c) = c
  Next c
  Diff = d2.keys
End Function

Tracé d'un cadre sur un formulaire

Le tracé d'un cadre dans un formulaire peut se faire avec un Frame.
Mais un frame est considéré comme un contrôle, ce qui peut poser des problèmes dans certains cas.
Dans le programme suivant, on trouve un programme de tracé de cadre avec des labels.

Cadre x, y, largeur, hauteur, couleur

Tracé d'un cadre formulaire

ComboBox images

ComboBox images
ListBox images

Formulaire auto-fermant

Formulaire autoFermant