Accueil

Listview avec photo
Menu cascade ComboBox ListView
Choix photo dans Listview
ListView simulation
Simulation ListBox couleur
Treeview Nomenclature
TreeView Hiérarchique

ListView avec tri

Cliquer sur la colonne pour trier.

ListViewTri

Private Sub UserForm_Initialize()
  With Me.ListView1
    With .ColumnHeaders
      .Clear
      .Add , , "Nom", 50
      .Add , , "Ville", 70
      .Add , , "Salaire", 40, lvwColumnRight
      .Add , , "Date", 70
    End With
   .Gridlines = True
   .View = lvwReport
   tblBD = Range("A2:D" & [A65000].End(xlUp).Row).Value
   ligne = 0
   For i = 1 To UBound(tblBD)
     ligne = ligne + 1
    .ListItems.Add , , tblBD(i, 1)
    .ListItems(ligne).ListSubItems.Add , , tblBD(i, 2)
    .ListItems(ligne).ListSubItems.Add , , Format(tblBD(i, 3), "0 €")
    .ListItems(ligne).ListSubItems.Add , , tblBD(i, 4)
  Next i
 End With
End Sub

Private Sub ListView1_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Select Case ColumnHeader.Index
  Case 1 To 3
    ListView1.SortKey = ColumnHeader.Index - 1
    ListView1.SortOrder = lvwAscending
    ListView1.Sorted = True
  Case 4       'Dates
    c = ColumnHeader.Index - 1
    For i = 1 To ListView1.ListItems.Count
      ListView1.ListItems(i).ListSubItems(c).Text = CLng(CDate(ListView1.ListItems(i).ListSubItems(c)))
    Next i
    ListView1.SortKey = c
    ListView1.SortOrder = lvwAsccending
    ListView1.Sorted = True
    For i = 1 To ListView1.ListItems.Count
      ListView1.ListItems(i).ListSubItems(c).Text = _
        Format(CDate(ListView1.ListItems(i).ListSubItems(c)), "dd/mm/yyyy")
    Next i
  End Select
End Sub

Private Sub ListView1_DblClick()      ' Gras et coloriage
  ListView1.SelectedItem.Bold = Not ListView1.SelectedItem.Bold
  ListView1.SelectedItem.ForeColor = _
     IIf(ListView1.SelectedItem.ForeColor = vbRed, vbBlack, vbRed)
  For Each c In ListView1.SelectedItem.ListSubItems
    c.Bold = Not c.Bold
  Next
  ListView1.Refresh
End Sub

Private Sub B_fin_Click()
  Unload Me
End Sub

Private Sub ListView1_Click()
 temp = ListView1.SelectedItem
End Sub

Tri pour numérique avec nombres négatifs

c = ColumnHeader.Index - 1
For i = 1 To ListView1.ListItems.Count
   ListView1.ListItems(i).ListSubItems(c).Text = _
      Format(Val(ListView1.ListItems(i).ListSubItems(c).Text) + 1000000, "0000000")
Next i
ListView1.SortKey = c
ListView1.SortOrder = lvwAsccending
ListView1.Sorted = True
For i = 1 To ListView1.ListItems.Count
    ListView1.ListItems(i).ListSubItems(c).Text = CDbl(ListView1.ListItems(i).ListSubItems(c)) - 1000000
Next i

Récupération des titres et des items

Private Sub B_recup_Click()
  NbCol = Me.ListView1.ColumnHeaders.Count
  Dim Tbl(): ReDim Tbl(1 To NbCol)
  For c = 1 To NbCol
     Tbl(c) = Me.ListView1.ColumnHeaders(c)
  Next c
  [O1].Resize(, NbCol) = Tbl
  '--- items
  NbCol = Me.ListView1.ColumnHeaders.Count
  NbLig = Me.ListView1.ListItems.Count
  Dim TblItems(): ReDim TblItems(1 To NbLig, 1 To NbCol)
  For ligne = 1 To NbLig
     TblItems(ligne, 1) = ListView1.ListItems(ligne)
     For colonne = 1 To Me.ListView1.ColumnHeaders.Count - 1
        TblItems(ligne, colonne + 1) = ListView1.ListItems(ligne).ListSubItems(colonne)
     Next colonne
  Next ligne
  [O2].Resize(NbLig, NbCol) = TblItems
End Sub

Menus en cascade ComboBox/ListView

CascadeComboListView
Recherche intuitive ListView
Filtre Combo ListView Modif Ajout Sup
CascadeComboListView2
CascadeComboListView3
Cascade Combo ListView Choix Colonnes

Dim Tbl(), f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Set d = CreateObject("Scripting.Dictionary")
  Tbl = f.Range("A3:P" & f.[A65000].End(xlUp).Row).Value
  For i = LBound(Tbl) To UBound(Tbl)
    If Tbl(i, 4) <> "" Then d(Tbl(i, 4)) = ""
  Next i
  temp = d.keys
  Call Tri(temp, LBound(temp), UBound(temp))
  Me.ComboBox1.List = temp
End Sub

Private Sub ComboBox1_Click()
  With Me.ListView1
    With .ColumnHeaders
     .Clear
     For k = 1 To 16
      .Add , , f.Cells(2, k), 55
     Next k
   End With
   ligne = 1
   .Gridlines = True
   .View = lvwReport
   .ListItems.Clear
   For lig = 1 To UBound(Tbl)
     If Tbl(lig, 4) = Me.ComboBox1 Then
       .ListItems.Add , , Tbl(lig, 1)
       For k = 2 To 16
         .ListItems(ligne).ListSubItems.Add , , Tbl(lig, k)
       Next k
       ligne = ligne + 1
     End If
   Next lig
  Me.TextBox1 = .ListItems.Count
 End With
End Sub

Recherche intuitive multi-colonnes multi-mots

Recherche intuitive multi-colonnes multi-mots
Recherche intuitive multi-colonnes multi-mots 2

Listview avec photo

ListViewPhoto

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ImageList1.ImageHeight = 60
  Me.ImageList1.ImageWidth = 60 / 1.2
  répertoirePhoto = ThisWorkbook.Path & "\" ' Adapter
  With Me.ListView1
  With .ColumnHeaders
   .Clear
   .Add , , "Nom", 80
   .Add , , "Ville", 70
   .Add , , "Salaire", 40, lvwColumnRight
   .Add , , "Date", 70
  End With
  ligne = 1
  .Gridlines = True
  .View = lvwReport
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    .ListItems.Add , , c
    If Dir(répertoirePhoto & c & ".jpg") <> "" Then
       Me.ImageList1.ListImages.Add , "Img" & ligne, LoadPicture(répertoirePhoto & c & ".jpg")
       Set Me.ListView1.SmallIcons = Me.ImageList1
       Me.ListView1.ListItems(ligne).SmallIcon = "Img" & ligne
    End If
    .ListItems(ligne).ListSubItems.Add , , c.Offset(, 1)
    temp = c.Offset(, 2)
    .ListItems(ligne).ListSubItems.Add , , String(5 - Len(temp), " ") & temp & " €"
    .ListItems(ligne).ListSubItems.Add , , c.Offset(, 3)
     ligne = ligne + 1
   Next c
  End With
End Sub

Choix de photos externes dans un listview

Choix Photo ListstView

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ImageList1.ImageHeight = 60
  Me.ImageList1.ImageWidth = 60 / 1.2
  répertoirePhoto = ThisWorkbook.Path & "\" ' adapter
  With Me.ListView1
    With .ColumnHeaders
      .Clear
      .Add , , "Nom", 80
    End With
    ligne = 1
    .Gridlines = True
    .View = lvwReport
    For Each c In f.Range("A2:A" & f.[a65000].End(xlUp).Row)
      .ListItems.Add , , c
      If Dir(répertoirePhoto & c & ".jpg") <> "" Then
        Me.ImageList1.ListImages.Add , "Img" & ligne, LoadPicture(répertoirePhoto & c & ".jpg")
        Set Me.ListView1.SmallIcons = Me.ImageList1
        Me.ListView1.ListItems(ligne).SmallIcon = "Img" & ligne
      End If
      ligne = ligne + 1
    Next c
  End With
End Sub

Private Sub ListView1_Click()
   nom = Me.ListView1.SelectedItem
   ActiveCell = nom
   For Each s In ActiveSheet.Shapes
     If s.Type = 13 Then
       If s.TopLeftCell.Address = ActiveCell.Offset(0, 1).Address Then s.Delete
     End If
   Next s
   répertoirePhoto = ThisWorkbook.Path & "\"
   Set img = ActiveSheet.Pictures.Insert(répertoirePhoto & nom & ".jpg")
   img.Left = ActiveCell.Offset(, 1).Left + 1
   img.Top = ActiveCell.Offset(, 1).Top + 1
   ech = 0.75
   img.Height = img.Height * ech
   img.Width = img.Width * ech
End Sub

Différentes formes d'un listview

ListstView

Private Sub UserForm_Initialize()
  Set f = Sheets("bd")
  Me.ImageList1.ImageHeight = 60
  Me.ImageList1.ImageWidth = 60 / 1.2
  répertoirePhoto = ThisWorkbook.Path & "\" ' adapter
  With Me.ListView1
  With .ColumnHeaders
    .Clear
    .Add , , "Nom", 80
    .Add , , "Ville", 70
    .Add , , "Salaire", 40, lvwColumnRight
    .Add , , "Date", 70
   End With
   ligne = 1
   .Gridlines = True
   .View = lvwReport
   For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
     .ListItems.Add , , c
     If Dir(répertoirePhoto & c & ".jpg") <> "" Then
        Me.ImageList1.ListImages.Add , "Img" & ligne, LoadPicture(répertoirePhoto & c & ".jpg")
        Set Me.ListView1.SmallIcons = Me.ImageList1
        Me.ListView1.ListItems(ligne).SmallIcon = "Img" & ligne
        Set Me.ListView1.Icons = Me.ImageList1
        Me.ListView1.ListItems(ligne).Icon = "Img" & ligne
      End If
      .ListItems(ligne).ListSubItems.Add , , c.Offset(, 1)
       temp = c.Offset(, 2)
       .ListItems(ligne).ListSubItems.Add , , String(5 - Len(temp), " ") & temp & " €"
       .ListItems(ligne).ListSubItems.Add , , c.Offset(, 3)
       ligne = ligne + 1
    Next c
  End With
  With Me.ListBox1
   .AddItem "lvwIcon"
   .AddItem "lvwSmallIcon"
   .AddItem "lvwList"
   .AddItem "lvwReport"
  End With
End Sub

Private Sub ListBox1_Click()
    Me.ListView1.View = Me.ListBox1.ListIndex
End Sub

Simulation ListView avec photos

Les photos en commentaire sont exportées en jpg à l'ouverture du classeur.

ListViewSimul

'Pour récupérer le formulaire: clic-droit sur Userform1/exporter
Dim début, n, f
Private Sub UserForm_Initialize()
  'RépertoirePhotos est déclaré public dans un module
  Set f = Sheets("BD")
  début = 1
  n = 3
  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("Image" & i).Picture = LoadPicture(répertoirePhotos & f.Cells(i + début, 1) & ".jpg")
    Me("Image" & i).ControlTipText = f.Cells(i + début, 1)
    Me("Image" & i).BorderStyle = 1
    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)
  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
  n = 3
  For i = 1 To n
    Me("Image" & i).Picture = LoadPicture()
    Me("Image" & i).ControlTipText = ""
    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
End Sub

Public répertoirePhotos
Sub auto_open()
  Application.ScreenUpdating = False
  répertoirePhotos = "c:\photos\" ' Adapter
  If Dir(répertoirePhotos, vbDirectory) = "" Then MkDir répertoirePhotos
  Set f = Sheets("BD")
  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

Simulation listBox couleur

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

ListBoxSimul

Treeview simple

Treeview Simple

Private Sub UserForm_Initialize()
  Tbl = Range("A2:B" & [A65000].End(xlUp).Row).Value
  Me.Monarbre.Nodes.Add(, , "NoeudInit", "Début").Expanded = True ' Début arbre
  Set d = CreateObject("scripting.dictionary")
  For i = 1 To UBound(Tbl): d(Tbl(i, 2)) = "": Next i
  For Each c In d.keys ' Noeuds départements
     Me.Monarbre.Nodes.Add("NoeudInit", tvwChild, "NoeudDep" & c, c).Expanded = True
  Next c
  For i = 1 To UBound(Tbl) ' Noeuds noms
    Me.Monarbre.Nodes.Add("NoeudDep" & Tbl(i, 2), tvwChild, "NoeudNom" & Tbl(i, 1), Tbl(i, 1)).Expanded = True
  Next i
End Sub

Treeview nomenclature

Treeview nomenclatureSimple
Treeview nomenclature
Treeview nomenclature2
Treeview nomenclature 3
Treeview généalogie
Treeview hiérarchie

Dim tw As MSComctlLib.TreeView
Dim Tbl, n
Private Sub UserForm_Initialize()
  Tbl = Range("A2:N" & [F65000].End(xlUp).Row).Value
  pere = "0"
  nomPere = Application.VLookup(pere, Tbl, 4, False)
  Set tw = Me.MonArbre
  n = UBound(Tbl)
  tw.Nodes.Add(, , "NoeudMat" & pere, nomPere).Expanded = True ' Racine arbre
  Fils pere
End Sub

Sub Fils(parent) ' procédure récursive
  For i = 2 To n
    cd = Tbl(i, 1)
    niv = Len(cd) - Len(Replace(cd, ".", ""))
    If niv = 0 Then temp = "0" Else temp = Left(cd, Len(cd) - 2)
    If temp = parent Then
      tw.Nodes.Add("NoeudMat" & parent, tvwChild, "NoeudMat" & _
      Tbl(i, 1), Tbl(i, 1) & ": " & Tbl(i, 2) & "-" & Tbl(i, 4)).Expanded = True
      Fils Tbl(i, 1)
    End If
  Next i
End Sub

Private Sub MonArbre_NodeClick(ByVal Node As MSComctlLib.Node)
  If Left(Node.Key, 8) = "NoeudMat" Then
    Me.Niveau = Application.VLookup(Mid(Node.Key, 9), Tbl, 1, False)
    Me.Article = Application.VLookup(Mid(Node.Key, 9), Tbl, 2, False)
    Me.Indice = Application.VLookup(Mid(Node.Key, 9), Tbl, 3, False)
    Me.Désignation = Application.VLookup(Mid(Node.Key, 9), Tbl, 4, False)
    Me.composant = Application.VLookup(Mid(Node.Key, 9), Tbl, 6, False)
  End If
End Sub

TreeView hierarchique

L'objet TreeView permet de visualiser une arborescence dans un formulaire.

TreeView Hierarchie

La syntaxe pour créer un noeud est:
xxx.Nodes.Add(noeud_père,twchild,création_noeud_courant,libellé_noeud)

Dim tw As MSComctlLib.TreeView
Dim Tbl, n

Private Sub UserForm_Initialize()
  Tbl = Range("A2:E" & [A65000].End(xlUp).Row).Value
  pere = Tbl(1, 1)
  Set tw = Me.MonArbre
  n = UBound(Tbl)
  tw.Nodes.Add(, , "NoeudMat" & pere, Tbl(1, 3)).Expanded = True ' Racine arbre
  Fils pere, 1
End Sub

Sub Fils(parent, niv) ' procédure récursive
  For i = 2 To n
    cd = Tbl(i, 2)
    If cd = parent Then
      tw.Nodes.Add("NoeudMat" & parent, tvwChild, "NoeudMat" & Tbl(i, 1), Tbl(i, 1)).Expanded = True
      Fils Tbl(i, 1), niv + 1
    End If
  Next i
End Sub

Private Sub MonArbre_NodeClick(ByVal Node As MSComctlLib.Node)
  If Left(Node.Key, 8) = "NoeudMat" Then
    Me.Nom = Application.VLookup(Mid(Node.Key, 9), Tbl, 1, False)
    Me.Sup = Application.VLookup(Mid(Node.Key, 9), Tbl, 2, False)
    Me.Service = Application.VLookup(Mid(Node.Key, 9), Tbl, 3, False)
    Me.Cmt = Application.VLookup(Mid(Node.Key, 9), Tbl, 4, False)
    tmp = Application.VLookup(Mid(Node.Key, 9), Tbl, 5, False)
    If tmp <> "" Then
      Me.Image1.Picture = LoadPicture("c:\photos\" & tmp & ".jpg")
    Else
      Me.Image1.Picture = LoadPicture
    End If
  End If
End Sub