Ressources EXCEL

Exemples

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

Boutons Suivant/Précédent

Affiche la fiche suivante/précédente

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

Private Sub ChoixNom_Change()
  ligne = .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é
  Select Case maBD.Cells(ligne, 1)
    Case "Mme"
      Me.Civilité.Controls(0) = True
    Case "Mle"
      Me.Civilité.Controls(1) = True
    Case "M."
     Me.Civilité.Controls(2) = True
  End Select
  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

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 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..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 est remplie avec la liste des fichiers jpg du répertoire.

- FormPhotoRep -

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

Autre version

La liste des photos est dans la colonne A

FormPhotoNom

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

Private Sub ChoixPhoto_Change()
  répertoire = ThisWorkbook.Path
  If Dir(répertoire & "\" & Me.ChoixPhoto & ".jpg") <> "" Then
    Me.Image1.Picture = LoadPicture(répertoire & "\" & ChoixPhoto & ".jpg")
  Else
    Me.Image1.Picture = LoadPicture
  End If
End Sub

Affichage des photos d'un répertoire

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

FormImageInterne
Form Image Interne Stephen Bullen

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
  f.ChartObjects.Add(0, 0, s.Width, s.Height).Chart.Paste
  f.ChartObjects(1).Chart.Export Filename:="monimage.jpg"
  f.Shapes(f.Shapes.Count).Delete
  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

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(, .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(, .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
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").
    '-- 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").
   ligne = Sheets("BD").[A:A].Find(Me.nom, LookIn:=xlValues).Row
   majChoixNom
End Sub

Private Sub B_ajout_Click()
   ligne = Sheets("BD")..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")..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")., Sheets("BD")..End(xlUp))
      Me.choixnom.AddItem c
    Next c
  Else
      For Each c In Range(Sheets("BD")., Sheets("BD")..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")..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")., Sheets("BD")..End(xlUp))
          F_Lettre2.choixnom.AddItem c
        Next c
      Else
        For Each c In Range(Sheets("BD")., Sheets("BD")..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()
End Sub

Private Sub CommandButton1_Click()
  If Not IsNumeric(Me.TextBox1) Then
     MsgBox "Saisir du num!"
  Else
     Application.Index(, 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

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 = .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
SurvolListBoxPhotoInterne2
SurvolListBoxPhotoInterne3

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 = .Find(c, LookAt:=xlWhole).Row
    col = .Column + 1
    For Each s In f.Shapes
      If s.TopLeftCell.Address = Cells(lig, col).Address Then
        H = s.Height
        L = s.Width
        s.Copy
        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
     End If
   Next s
  Next c
  UserForm1.Show
End Sub

Private Sub UserForm_Initialize()
  Me.ListBox1.List = .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
     photo = ListBox1.List(ligne + Me.ListBox1.TopIndex, 0) & ".jpg"
     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..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..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..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..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

Sur cet exemple, l'opérateur choisit le répertoire.

ListeFichiersRépertoireListBox

Private Sub CommandButton1_Click()
  racine = ChoixDossier() ' ou un répertoire C:\xxx e.g.
  If racine = "" Then Exit Sub
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dossier = fs.getfolder(racine) 'DossierRacine
  Me.TextBox1 = racine
  i = 0
  Me.ListBox1.Clear
  For Each f In dossier.Files
    Me.ListBox1.AddItem
    Me.ListBox1.List(i, 0) = f.Name
    Me.ListBox1.List(i, 1) = String(10 - Len(f.Size), " ") & f.Size
    Me.ListBox1.List(i, 2) = Format(f.Datecreated, "dd/mm/yy")
    Me.ListBox1.List(i, 3) = Format(f.DatelastModified, "dd/mm/yy")
    i = i + 1
  Next
  Me.TextBox2 = Me.ListBox1.ListCount
End Sub

Function ChoixDossier()
  If Val(Application.Version) >= 10 Then
    With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = ActiveWorkbook.Path & "\"
      .Show
     If .SelectedItems.Count > 0 Then
        ChoixDossier = .SelectedItems(1)
     Else
        ChoixDossier = ""
     End If
    End With
   Else
    ChoixDossier = InputBox("Répertoire?")
   End If
End Function

Choix de la colonne de tri dans un combobox

FormTri

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

Private Sub ComboBox1_Change()
  .CurrentRegion.Sort Key1:=.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(, , 1))
    Me("produit" & i).List = TriChamp(Range(, .End(xlDown)))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("libellé" & no) = Application.VLookup(Me("Produit" & no), , 2, False)
  Me("Prix" & no) = Application.VLookup(Me("Produit" & no), , 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()
   = Me.nom
   = Me.Rue
   = Me.Ville
  .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(, , 1))
  Next i
End Sub

Sub ChoixProduit(no)
  Me("couleur" & no).Clear
  For Each c In Range(, .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 .Rows.Count
     If Me("produit" & no) = .Cells(i, 1) _
        And Me("couleur" & no) = .Cells(i, 2) Then
          Me("total" & no) = .Cells(i, 3) * Val(Me("qte" & no))
     End If
  Next i
End Sub

Private Sub B_ok_Click()
   = Me.nom
   = Me.Rue
   = Me.Ville
  .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).
    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 = .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..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 = .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

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

FormListeFichiers

Private Sub UserForm_Initialize()
  ChDir CurDir()
  Me.Dossier = CurDir()
  Dim Tbl()
  nf = Dir("*.*")
  n = 0
  Do While nf <> ""
    n = n + 1
    ReDim Preserve Tbl(1 To 2, 1 To n)
    Tbl(1, n) = nf
    Tbl(2, n) = Format(FileDateTime(nf), "yyyy/mm/dd hh:mm")
    nf = Dir
  Loop
  Me.ListBox1.List = Application.Transpose(Tbl)
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
  Me.TypeFich.AddItem "*.*"
  Me.TypeFich.AddItem "*.xls"
  Me.TypeFich.AddItem "*.jpg"
  Me.TypeFich.AddItem "*.mdb"
  Me.TypeFich.AddItem "*.txt"
  Me.TypeFich.ListIndex = 0
End Sub

Private Sub B_triNom_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call TriCroissant(a(), UBound(a, 1), 0, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Private Sub B_triDate_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call TriCroissant(a(), UBound(a, 1), 1, True)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = Me.ListBox1.ListCount - 1
End Sub

Private Sub b_tridatedec_Click()
  Dim a()
  a = Me.ListBox1.List ' 0 To n,0 To x
  Call TriCroissant(a(), UBound(a, 1), 1, False)
  Me.ListBox1.List = a
  Me.ListBox1.ListIndex = 0
End Sub

Sub TriCroissant(table(), xn, col, ordre)
  ecart = xn ' tri shell
  Do While ecart >= 1
    ecart = ecart \ 2
    inv = True
    Do While inv
      inv = False
      For i = 0 To xn - ecart
        j = i + ecart
       If ordre Then
         X = (table(i, col) > table(j, col))
       Else
         X = (table(i, col) < table(j, col))
       End If
       If X Then
         temp = table(j, 0)
         table(j, 0) = table(i, 0)
         table(i, 0) = temp
         '--
         temp = table(j, 1)
         table(j, 1) = table(i, 1)
         table(i, 1) = temp
         inv = True
       End If
     Next
   Loop
  Loop
End Sub

Private Sub TypeFich_Change()
  Dim Tbl()
  nf = Dir(Me.TypeFich)
  n = 0
  Do While nf <> ""
    n = n + 1
    ReDim Preserve Tbl(1 To 2, 1 To n)
    Tbl(1, n) = nf
    Tbl(2, n) = Format(FileDateTime(nf), "yyyy/mm/dd hh:mm")
    nf = Dir
  Loop
  Me.ListBox1.List = Application.Transpose(Tbl)
  Me.TextBox1 = Me.ListBox1.ListCount & " Fichiers"
End Sub

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. = "*" & 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"), , 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. = "*" & 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..CurrentRegion.Offset(1)
  ncol = plageBD.Columns.Count
  Application.ScreenUpdating = False
  fRech..Resize(100, ncol + 1).ClearContents
  Set plageRech = IIf(Me.CheckBox1, plageBD, Range(fbd., fbd..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..Cells(LigRech, col) = plageBD.Cells(ligBD, col)
      Next col
      fRech..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