Création d'un objet ListBox modifiable et dynamique

Question

Bonjour, 
 
Pour ce projet j'ai besoin d'un gros coup de main.
Il consiste à créer, via une classe, un objet listbox modifiable. Pour cela, l'objet mListBox va être composé de trois contrôles :
1 ListBox, 1 Frame et 1 TextBox.
Voilà ou j'en suis :
1- code de l'userform :
Option Explicit

Private Sub UserForm_Initialize()
Dim i As Integer, monTop As Single, monLeft As Single

Me.Height = 450
   Me.Width = 420
   Set monUsf = Me   'ligne indispensable
   For i = 0 To 3
      monTop = IIf(i < 2, 5, 205)
      monLeft = IIf(i And 1, 205, 5)
      maList(i).Affiche i, monLeft, monTop, 200, 200   'ligne indispensable
   Next
End Sub

2- Code du module (Module1)
Option Explicit

Public monUsf As Object
Public maList(3) As New mListBox

3- Code du Module de Classe (mListBox)
Option Explicit

Public WithEvents mTextB As MSForms.TextBox  'événements des textbox
Public WithEvents mListB As MSForms.ListBox  'événements des listbox

Private mLeft As Single, mTop As Single

Private Sub Class_Initialize()
'Un objet "mListBox" est composé de trois contrôles :
   '- 1 listbox appelée "mListBox_" & Num
   '- 1 Frame appelé "mFrame_" & Num
   '- 1 textbox appelé "mTextBox_" & Num
End Sub

Sub Affiche(ByVal Num As Integer, ByVal L As Single, ByVal T As Single, ByVal W As Single, ByVal H As Single)
'dessine les 3 contrôles composant l'objet mListBox dans l'userform (monUsf)
'et affecte les propriétés événementielles (mListB et mTextB)
Dim ListB As Object, TextB As Object, Frme As Object

'ajout du contrôle ListBox
   Set ListB = monUsf.Controls.Add("forms.ListBox.1")
   Set maList(Num).mListB = ListB
   With ListB
      .Move L, T, W, H
      .Name = "mListBox_" & Num
   End With
   'Ajout du contrôle Frame
   Set Frme = monUsf.Controls.Add("forms.Frame.1")
   With Frme
      .Visible = False
      .Name = "mFrame_" & Num
      .Move L, T + H, 50, 20
      .BorderStyle = 0
   End With
   'ajout du contrôle TextBox
   Set TextB = Frme.Controls.Add("forms.TextBox.1")
   Set maList(Num).mTextB = TextB
   With TextB
      .Name = "mTextBox_" & Num
      .Move 0, 0, 46, 16
   End With
   'libération des variables
   Set ListB = Nothing
   Set Frme = Nothing
   Set TextB = Nothing
End Sub

Private Sub mListB_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'événement MouseDown du contrôle listbox
   '=> Si Frame.Visible Alors on passe la valeur du textbox dans la listbox
      'puis (dans tous les cas) on affiche le Frame
Dim Num As Integer

'si clic gauche
   If Button = 1 Then
      'on récupère le numéro de la mListBox
      Num = CInt(Split(mListB.Name, "_")(1))
      'interception de la sortie du textbox par la souris
      If monUsf.Controls("mFrame_" & Num).Visible = True Then
         'on enregistre la saisie du textbox dans la listbox
         Call Corrige_Liste(monUsf.Controls("mTextBox_" & Num).Value, X, Y)
      End If
      'stockage des X et Y pour préparer la restitution des données lors de la sortie du textbox
      mLeft = X
      mTop = Y
      'on affiche le Frame au bon endroit
      Affiche_Frame Num, True, X, Y
   End If
End Sub

Private Sub Affiche_Frame(ByVal Num As Integer, ByVal Visib As Boolean, ByVal X As Single, ByVal Y As Single)
'changement de la propriété Visible du Frame (=> Affichage vrai ou faux au bon endroit)
   With monUsf.Controls("mFrame_" & Num)
      .Visible = Visib 'rend visible ou invisible le Frame
      'positionne le Frame en fonction du numéro
      .Move monUsf.Controls(mListB.Name).Left + X, monUsf.Controls(mListB.Name).Top + Y, .Width, .Height
      'Positionne le Frame par dessus la ListBox
      .ZOrder msoBringToFront
       'si visible attribue le focus au textbox
      If Visib Then .Controls("mTextBox_" & Num).SetFocus
   End With
End Sub

Private Sub mTextB_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'interception de la sortie du textbox par le clavier
Dim Num As Integer
   'quel textbox?
   Num = CInt(Split(mTextB.Name, "_")(1))
   'Qu'elle touche?
   Select Case Asc(UCase(Chr(KeyCode)))
      Case 9, 13 'touche TAB, Entrée
         Corrige_Liste mTextB.Value, mLeft, mTop 'Saisie de la valeur du textbox dans la listbox
         Affiche_Frame Num, False, 0, 0 'masque le Frame
      Case Else 'Autres
   End Select
End Sub

Private Sub Corrige_Liste(ByVal maVal As String, ByVal X As Single, ByVal Y As Single)
'passe mTextB.Value dans mListB

End Sub

Private Sub Class_Terminate()

End Sub

Pour l'instant, plutôt que de vous poser les 1000 questions qui me brulent les doigts, je préfères vous demander simplement si le début vous semble correct.

En second lieu, j'aimerais voir quelques points avec vous et, notamment, qu'elles sont les propriétés indispensables à ajouter, et des petits détails qui viendront en cours de développement...

Merci de votre première lecture.

ucfoutu · Answer

Bonjour, Franck
Qu'entends-tu exactement par "modifiable" ?
Si, comme je le pense, tu veux superposer la textbox de "modif" à l'article concerné de la listbox, puis affecter à la cellule concernée de la listbox la valeur de la textbox, je crains fort que tu n'aies à te diriger sans attendre vers des calculs assez complexes de hauteurs de textes accompagnés d'autres calculs si listbox de plusieurs colonnes.
VBA n'offre pas à ce propos ce qu'offre VB6 (pour les hauteurs de texte). Tu trouveras toutefois parmi mes sources de quoi te permettre de déterminer cela sous VBA.
Il ne va certes pas s'agir d'une tâche simple. Très loin de là  !
Question : pourquoi ne pas plutôt travailler avec des MSFLEXGRID, qui présentent l'énorme avantage de permettre de déterminer (par MouseRow et MouseCol) la cellule sur laquelle on place la souris ?
Ce serait très nettement plus sage.

pijaku · Answer

Concernant le MSFLEXGRID, il ne s'agit pas d'un contrôle disponible en VBA. Il n'est pas, non plus sauf erreur de ma part, disponible dans les contrôles supplémentaires.
Donc, si je ne m'abuse, il va falloir créer et installer un ocx ou une dll?

Ce n'est donc pas le but de mon sujet. Il serait plus simple d'utiliser le contrôle ListView.

Le but attendu ici est de disposer d'un contrôle simple d'utilisation, comme la listbox, mais pouvant être modifiée cellule par cellule.
Je pense vouloir continuer dans ce sens.
Qu'en dis tu?

ucfoutu · Answer

Il est toujours possible de télécharger, enregistrer et utiliser MSFLEXGRID sous VBA.
Ce serait plus simple de faire ce que tu veux à partir de ce contrôle.

Mais bon ... on va prendre le travail sur une listbox comme un défi.
Mais cela va être dur.

Si tu veux bien, dans ce cas, nous allons travailler pas à pas.
- pas de classe ni création dynamique pour l'instant (cela ne se fera qu'in fine, lorsque nous aurons su maîtriser. Pas avant.
- une seule listbox à une seule colonne pour l'instant
 
Le pas 1, donc : placer une textbox en superposition (et premier plan) d'un article sélectionné dans cette listbox.
Ce qui signifie : réussir à déterminer les coordonnées à donner au coin supérieur gauche de la textbox, et ceci, même si nous avons déroulé pour choisir un article.
Je vais commencer par cela.
________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

pijaku · Answer

Il est toujours possible de télécharger, enregistrer et utiliser MSFLEXGRID sous VBA.
Ce serait plus simple de faire ce que tu veux à partir de ce contrôle. 
Oui. Mais pour l'utilisateur lambda, je souhaite qu'il n'ai rien à télécharger, ni à installer de manière spécifique sur sa machine, ou encore sur chaque machine susceptible d'utiliser son fichier.
Ce n'est (une fois n'est pas coutume), pas pour moi ou pour un classeur sur lequel je travaille, mais pour la communauté.

on va prendre le travail sur une listbox comme un défi.
Mais cela va être dur.
Si tu veux bien, dans ce cas, nous allons travailler pas à pas
Je ne le concevais pas autrement.
Parfait.

Par contre, pas question de te laisser faire tout seul!
Je veux me "retrousser le code" également.
Je vais donc tenter, de mon côté, de suivre chaque étape et fournir un code systématiquement.

ucfoutu · Answer

Par contre, pas question de te laisser faire tout seul!
Je veux me "retrousser le code" également.
Je vais donc tenter, de mon côté, de suivre chaque étape et fournir un code systématiquement.

Bien (va falloir préparer l'aspirine).
J'ai déjà commencé, mais depuis VB6 pour l'instant.
Tu vas commencer à comprendre ce premier brouillon :
La textbox : pour l'instant : sans bordures.
  Option ExplicitPrivate ht As Integer, acacher As Integer, Lbord As SinglePrivate Sub Form_Activate()  Me.ScaleMode = vbPoints  Lbord = ScaleX(20, vbTwips, ScaleMode) ' ===>>> va falloir transposer (mon source)  Dim i As Integer  Set Font = List1.Font  ht = TextHeight("Coucou") '====>>> je vais devoir transposer (avec mon propre code du source que j'ai déposé)  For i = 1 To 20     List1.AddItem i & " aaa " & i  NextEnd SubPrivate Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)   acacher = List1.ListIndex   positionnonsEnd SubPrivate Sub List1_Scroll() positionnonsEnd SubPrivate Sub positionnons()  Set Text1.Font = List1.Font  Text1.ForeColor = vbRed  Select Case List1.ListIndex   Case List1.TopIndex    Text1.Top = List1.Top   Case Else      Text1.Top = List1.Top + ((acacher - List1.TopIndex - 0) * ht) _       + (Lbord * (List1.Appearance + 1))  End Select  Text1.Left = List1.Left + Lbord  Text1.Width = (List1.Width - Lbord * 2)  Text1.Height = ht  If Text1.Top >= List1.Top Then Text1.Visible = True Else Text1.Visible = False    Text1.ZOrderEnd Sub

Marche bien, sauf pour le tout premier article (je vais voir ce détail après déjeuner). Quelle que soit la taille des caractères de la listbox.

EDIT te casse pas la tête en ce qui concerne le petit défaut (sélection du premier article) / Déjà solutionné ===>> j'ai corrigé la procédure positionnons.

EDIT 2 :
sous VBA/Excel, on peut s'affanchir de ce :
Lbord = ScaleX(20, vbTwips, ScaleMode) ' ===>>> va falloir transposer (mon source)
Car :
  Lbord = 1
Je ne reviendrai que ce soir, pour continuer. Bonne sieste.
________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

pijaku · Answer

Bien (va falloir préparer l'aspirine). 
Après m'être penché sur l'adaptation à VBA de ton code VB6, je confirme...

Bon.
Pas mal de difficultés, VBA n'est pas VB6...
Je te les liste et après te parle des pistes que j'ai exploré.

1- Appearance n'existe pas. A remplacer, en VBA par SpecialEffect
Valeurs de SpecialEffect :
0 : fmSpecialEffectFlat
1 : fmSpecialEffectRaised
2 : fmSpecialEffectSunken
3 : fmSpecialEffectEtched
6 : fmSpecialEffectBump

2- Pas de ZOrder pour les TextBox en VBA. Enfin si, il existe mais, dans tous les cas, un TextBox ne peut pas "passer par dessus" les contrôles suivants : Frame, MultiPage et... ListBox.

3- Je ne sais pas si cela à une importance, mais ScaleMode n'existe pas pour les UserForms VBA. Je ne trouve aucune propriété ressemblante. 

Pistes explorées :
1- solutionné.
2- Il convient de placer le TextBox dans un Frame.
Cela ne pose pas de souci.

3- Je me demande s'il ne faut pas convertir les calculs (notamment celui du Frame1.Top) en Twips?

En fait, le gros souci est dans le calcul du Top du Frame.
On observe un décalage systématique.
Je vais me repencher sur le sujet.

Je ne reviendrai que ce soir, pour continuer.
Je te dis donc à demain. Ce soir, je suis seul avec mon fils...

pijaku · Answer

Voici le code réalisé à partir du tien, et qui fonctionne, à coups surs, en VBA quelque soit la police, gras, italique, taille...

On y retrouve les types, structures, constantes et appels aux fonctions API, mais également tes fonctions de calcul (celles de ta source).
La seule adaptation que j'ai faite est d'ajouter le coeff de 1.333333333333 à tes calculs.

Option Explicit

Private Type hv
   X As Long
   Y As Long
End Type
Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type

#If VBA7 Then
   Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#Else
   Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
#End If

Private vba_font As New StdFont

Private Const vbapoints As Integer = 20
Private Const vbapixels As Integer = 999 ' n'importe quoi sauf les autres valeurs
Private Const vbainches As Integer = 1440
Private Const vbatwips As Integer = 1
Private Const vbaCharacters As Integer = 120
Private Const coeff As Single = 1.333333333333

Private mHeight As Single, mWidth As Single

Private Sub UserForm_Initialize()
Dim i As Integer

With Me.Frame1
      .Visible = False
      .Caption = ""
      .BorderStyle = fmBorderStyleNone
   End With
   ListBox1.Font.Size = 19
   Set vba_font = ListBox1.Font
   mHeight = vba_TextHeight("Coucou", vba_font)
   For i = 1 To 100
     ListBox1.AddItem i & " aaa " & i
   Next
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   positionnons
End Sub

Private Sub positionnons()
   With Frame1
      .Top = ListBox1.Top + (ListBox1.ListIndex - ListBox1.TopIndex) * (mHeight / coeff)
      .Left = ListBox1.Left + 1
      .Width = (ListBox1.Width - 2)
      .Height = (mHeight / coeff) + ListBox1.SpecialEffect + 1
      If .Top >= ListBox1.Top Then .Visible = True Else .Visible = False
      .ZOrder
      .TextBox1.Font.Size = ListBox1.Font.Size
      .TextBox1.Move 0, 0, Frame1.Width - 2, Frame1.Height - 2
   End With
End Sub

Private Function vba_TextWidth(texte As String, la_font As StdFont) As Single
    vba_TextWidth = dimt(texte, la_font).X
End Function
Private Function vba_TextHeight(texte As String, la_font As StdFont) As Single
    vba_TextHeight = dimt(texte, la_font).Y
End Function
Private Function dimt(ch As String, ByVal pol As StdFont) As hv
    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.Size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline
    lgf.lfWeight = 400
    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteDC cdc: DeleteObject ccb
    dimt = tch
End Function

ucfoutu · Answer

C'est très bien, Franck,
Dommage que le scroll n'existe pas.
Je vais voir comment le remplacer au retour de la pêche
J'apporterai également quelques petits ajustements d'affichage/cadrage de la textbox(trois fois rien. Tu as fait l'essentiel)
A plus

ucfoutu · Answer

Bon ...
Quelques problèmes du fait que le Frame de VBA garde une bordure y compris si on dit qu'il ne doit pas en avoir !. Il va donc falloir faire avec ... et ... calculer avec !
Pour le Scroll, je n'ai rien trouvé de mieux (ou moins gourmand) que de substituer notre propre scrollbar à celle de la listbox !
Essaye ceci :
ajoute sur ton userform un contrôle scrollbar scrollbar1 placé dans un Frame Frame2, n'importe où ailleurs que dans le Frame1
Et ce code :
Option ExplicitPrivate Type hv   X As Long   Y As LongEnd TypePrivate Type LOGFONT  lfHeight As Long  lfWidth As Long  lfEscapement As Long  lfOrientation As Long  lfWeight As Long  lfItalic As Byte  lfUnderline As Byte  lfStrikeOut As Byte  lfCharSet As Byte  lfOutPrecision As Byte  lfClipPrecision As Byte  lfQuality As Byte  lfPitchAndFamily As Byte  lfFaceName As String * 32End Type#If VBA7 Then   Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long   Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long   Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long   Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long   Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long   Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long   Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long   Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long   Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long   Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long   Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long#Else   Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long   Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long   Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long   Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long   Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long   Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long   Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long   Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long   Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long   Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long   Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long#End IfPrivate vba_font As New StdFontPrivate Const vbapoints As Integer = 20Private Const vbapixels As Integer = 999 ' n'importe quoi sauf les autres valeursPrivate Const vbainches As Integer = 1440Private Const vbatwips As Integer = 1Private Const vbaCharacters As Integer = 120Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As LongConst SM_CYVSCROLL = 20 'hauteur d'une flèche d'ascenseur verticalConst SM_CXHSCROLL = 21 'largeur d'une flèche d'ascenseur verticalConst SM_CXBORDER = 5Private Const coeff As Single = 1.333333333333Private mHeight As Single, mWidth As Single, bord As SinglePrivate Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)'Label1.Caption = YEnd SubPrivate Sub ScrollBar1_Change()  ListBox1.TopIndex = ScrollBar1.Value  positionnonsEnd SubPrivate Sub ScrollBar1_Scroll()  ListBox1.TopIndex = ScrollBar1.Value  positionnonsEnd SubPrivate Sub TextBox1_Change()  ListBox1.List(ListBox1.ListIndex) = TextBox1.TextEnd SubPrivate Sub UserForm_Initialize()   Dim i As Integer, lAscLst As Single, lfleche As Single   bord = GetSystemMetrics(SM_CXBORDER) / 1.3333   lfleche = GetSystemMetrics(SM_CXHSCROLL) / 1.3333   lAscLst = (bord + bord + lfleche)   With Me.Frame1      .Visible = False      .Caption = ""      .BorderStyle = fmBorderStyleNone   End With   ListBox1.Font.Size = 11   'ListBox1.SpecialEffect = 1   Set vba_font = ListBox1.Font   With vba_font     .Bold = ListBox1.Font.Bold     .Italic = ListBox1.Font.Italic   End With   mHeight = vba_TextHeight("Coucou", vba_font)   For i = 1 To 100     ListBox1.AddItem i & " aaa " & i   Next  Dim corr_effect As Integer  corr_effect = IIf(ListBox1.SpecialEffect = 0, 1, 0)  With TextBox1    .ForeColor = vbRed    .Move 0, -bord - bord - corr_effect, Frame1.Width - bord - bord, Frame1.Height - (bord * 2)    .Font.Size = ListBox1.Font.Size    .Font.Bold = ListBox1.Font.Bold    .Font.Italic = ListBox1.Font.Italic  End With  With Frame2    .Caption = ""    .BorderStyle = fmBorderStyleNone    .Move ListBox1.Left + ListBox1.Width - lAscLst, ListBox1.Top, lAscLst, ListBox1.Height    .ZOrder  End With  With ScrollBar1    .SmallChange = 1    .LargeChange = 1    .Move 0, 0, Frame2.Width - (bord * 4), Frame2.Height - (bord * 2)    .Max = ListBox1.Height    .Value = 0    .Min = 0    .ZOrder  End WithEnd SubPrivate Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)   positionnons   TextBox1.SetFocusEnd SubPrivate Sub positionnons()  If ListBox1.ListIndex >= 0 Then TextBox1.Text = ListBox1.List(ListBox1.ListIndex)  Dim corr_effect As Byte   With Frame1      .Top = ListBox1.Top + (ListBox1.ListIndex - ListBox1.TopIndex) * (mHeight / coeff) '+ 1      .Left = ListBox1.Left + bord      .Width = (ListBox1.Width - (bord * 2)) - ScrollBar1.Width      If ListBox1.SpecialEffect = 0 Then corr_effect = 1 Else corr_effect = ListBox1.SpecialEffect      .Height = (mHeight / coeff) + corr_effect + (bord * 1)      If .Top >= ListBox1.Top And .Top <= ListBox1.Top + ListBox1.Height Then .Visible = True Else .Visible = False      .ZOrder         End WithEnd SubPrivate Function vba_TextWidth(texte As String, la_font As StdFont) As Single    vba_TextWidth = dimt(texte, la_font).XEnd FunctionPrivate Function vba_TextHeight(texte As String, la_font As StdFont) As Single    vba_TextHeight = dimt(texte, la_font).YEnd FunctionPrivate Function dimt(ch As String, ByVal pol As StdFont) As hv    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv    cdc = CreateDC("DISPLAY", "", "", ByVal 0)    ccb = CreateCompatibleBitmap(cdc, 1, 1)    DeleteObject SelectObject(cdc, ccb)    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.Size, GetDeviceCaps(GetDC(0), 90), 72)    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline    lgf.lfWeight = 400    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2    cfi = CreateFontIndirect(lgf)    DeleteObject SelectObject(cdc, cfi)    GetTextExtentPoint32 cdc, ch, Len(ch), tch    DeleteObject cfi: DeleteDC cdc: DeleteObject ccb    dimt = tchEnd Function
J'ai apporté quelques petites corrections et ai traité la modif dans la textbox
Ce code reste encore brouillon du fait que certaines valeurs sont "en dur". On les transformera comme il se doit en phase finale.

 EDIT modifié.

EDIT2 : Nous avons bien avancé.
J'ai entre temps préparé (fait et on y viendra ensuite) le traitement du cas d'une listbox à choix multiple. Ne t'y attarde donc pas maintenant.
L'étape suivante (que tu as j'en suis certain devinée) est( à mon avis celle que nous allons devoir maintenant "approcher".
Pour t'y préparer (d'autant que je vais retourner à la pêche) ===>> regarde ce que fait ceci sur un userform neuf avec une listbox ===>>
Private Sub UserForm_Activate()  ListBox1.ColumnCount = 3  ListBox1.ColumnWidths = "25;40;50"  ListBox1.Width = (25 + 40 + 50) + ListBox1.ColumnCount  For i = 0 To 20    For j = 0 To ListBox1.ColumnCount - 1      ListBox1.AddItem "aaaa"      ListBox1.List(i, j) = "b"    Next  NextEnd SubPrivate Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Select Case X   Case Is >= 65     colonne = 2   Case Is >= 25     colonne = 1   Case Is >= 0     colonne = 0 End Select MsgBox "tu a cliqué dans la colonne " & colonne & " de la ligne " & ListBox1.ListIndexEnd Sub
Tu "vois" de suite où il va falloir placer le Frame, non ?
on en connait la largeur (celle de la colonne), la hauteur (le ht que nous avons déjà calculée plus haut), la position verticale (que nous avons déjà calculée plus haut) et la position horizontale (la somme des largeurs des nb colonnes précédentes + nb fois 1 point (la séparation) )
Allez ===>> je vais voir si la louvine veut bien attaquer


________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

ucfoutu · Answer

Point 1 : ne surtout pas changer l'évènement déclencheur. Le click ne relève pas la position X de la souris (et on va en avoir sacrément besoin pour des multicolonnes).
Ne t'inquiète pas (je te l'ai dit plus haut)  : je sais déjà gérer (tu verras comment) la multisélection. C'est déjà dans la poche, chez moi.
 point 2 : je ne vois pas comment un click sur l'ascenseur (que ce soit sur les flêches ou en utilisant le curseur) permettrait de faire face à toutes les situations.
Point 3 : ce n'est pas un problème. Si création dynamique, on connaît ce nombre (par construction). Si création manuelle, on sait déterminer également ce nombre. Idem pour ce qui est de la largeur de chaque colonne. Peut donc être vu in fine.

pijaku · Answer

Bon.
Voici ou j'en suis.
Je ne suis pas pleinement satisfait car :
- la gestion du multi-colonnes ne me semble pas top top  au niveau du code,
- la const coeff
- une nouvelle constante Const UNITE pour déterminer si la largeur de la colonne est exprimée en point ou en cm. Il doit bien y avoir une constante générique vb pour ça aussi???

Mon nouveau code :
Option Explicit

Private Type hv
   X As Long
   Y As Long
End Type

Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type

#If VBA7 Then
   Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
   Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Const vbapoints As Integer = 20
Private Const vbapixels As Integer = 999 ' n'importe quoi sauf les autres valeurs
Private Const vbainches As Integer = 1440
Private Const vbatwips As Integer = 1
Private Const vbaCharacters As Integer = 120
Private Const SM_CYVSCROLL = 20 'hauteur d'une flèche d'ascenseur vertical
Private Const SM_CXHSCROLL = 21 'largeur d'une flèche d'ascenseur vertical
Private Const SM_CXBORDER = 5

Private Const coeff As Single = 1.333333333333
Private Const UNITE As String = " pt"

Private mHeight As Single, mWidth() As Single, mLeft() As Single, bord As Single
Private colonne As Byte
Private vba_font As New StdFont

Private Sub UserForm_Initialize()
Dim i As Integer, j As Integer, corr_effect As Integer, Col As Integer

bord = GetSystemMetrics(SM_CXBORDER) / 1.3333
   '-------PROPRIETES FRAME1
   With Me.Frame1
      .Visible = False
      .Caption = ""
      .BorderStyle = fmBorderStyleNone
   End With
   '------------------------------
   '-------GESTION HAUTEUR DE LIGNES en fonction POLICE
   ListBox1.Font.Size = 11
   Set vba_font = ListBox1.Font
   With vba_font
     .Bold = ListBox1.Font.Bold
     .Italic = ListBox1.Font.Italic
   End With
   mHeight = vba_TextHeight("Coucou", vba_font)
   '------------------------------
   '-------PROPRIETES ET REMPLISSAGE LISTBOX
   ListBox1.ColumnCount = 3
   ListBox1.ColumnWidths = "50;40;50"
   For i = 0 To 50
      ListBox1.AddItem "aaaa"
      For j = 1 To ListBox1.ColumnCount - 1
        ListBox1.List(i, j) = "b"
      Next
   Next
   '------------------------------
   '-------GESTION MULTI-COLONNES
   ReDim Preserve mLeft(ListBox1.ColumnCount - 1)
   ReDim Preserve mWidth(ListBox1.ColumnCount - 1)
   mLeft(0) = 1
   If ListBox1.ColumnCount > 1 Then
      mWidth(0) = CSng(Replace(Split(ListBox1.ColumnWidths, ";")(Col), UNITE, ""))
      For Col = 1 To ListBox1.ColumnCount - 1
         mLeft(Col) = CDbl(Replace(Split(ListBox1.ColumnWidths, ";")(Col - 1), UNITE, "")) + mLeft(Col - 1) + 1
         mWidth(Col) = CSng(Replace(Split(ListBox1.ColumnWidths, ";")(Col), UNITE, ""))
      Next
      ListBox1.Width = mLeft(UBound(mLeft)) + ListBox1.ColumnCount
   Else
      If ListBox1.ListCount * (mHeight / coeff) > ListBox1.Height Then
         mWidth(0) = ListBox1.Width - Largeur_Scrollbar
      Else: mWidth(0) = ListBox1.Width - 2
      End If
   End If
   '------------------------------
   '-------PROPRIETES TEXTBOX1
   corr_effect = IIf(ListBox1.SpecialEffect = 0, 1, 0)
   With TextBox1
     .ForeColor = vbRed
     .Move 0, -(bord * 2) - corr_effect, Frame1.Width, Frame1.Height - (bord * 2)
     .Font.Size = ListBox1.Font.Size
     .Font.Bold = ListBox1.Font.Bold
     .Font.Italic = ListBox1.Font.Italic
   End With
   '------------------------------
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'enregistrement, à chaque "clic" souris, de la colonne
Dim i As Integer
   For i = UBound(mLeft) To LBound(mLeft) Step -1
      If X >= mLeft(i) Then colonne = i: Exit For
   Next i
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   positionnons
End Sub

Private Sub ListBox1_Enter()
'GESTION DU SCROLL LISTBOX1
   If Frame1.Visible Then Frame1.Visible = False
End Sub

Private Sub positionnons()
Dim corr_effect As Byte
   With Frame1
      .Top = ListBox1.Top + (ListBox1.ListIndex - ListBox1.TopIndex) * (mHeight / coeff)
      .Left = ListBox1.Left + 1 + mLeft(colonne)
      .Width = mWidth(colonne)
      If ListBox1.SpecialEffect = 0 Then corr_effect = 1 Else corr_effect = ListBox1.SpecialEffect
      .Height = (mHeight / coeff) + corr_effect + (bord * 1)
      If .Top >= ListBox1.Top Then
         .Visible = True
         .ZOrder
         With .TextBox1
            Set .Font = ListBox1.Font
            .Value = ListBox1.List(ListBox1.ListIndex, colonne)
            .SetFocus
         End With
       Else: .Visible = False
       End If
   End With
End Sub

Private Function Largeur_Scrollbar() As Single
Dim Larg As Single
   Larg = Val(Str$(GetSystemMetrics(SM_CXBORDER))) * 2
   Larg = Larg + (Val(Str$(GetSystemMetrics(SM_CXHSCROLL))) + Larg)
   Largeur_Scrollbar = Larg / coeff
End Function
Private Function vba_TextHeight(texte As String, la_font As StdFont) As Single
   vba_TextHeight = dimt(texte, la_font).Y
End Function
Private Function dimt(ch As String, ByVal pol As StdFont) As hv
    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.Size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline
    lgf.lfWeight = 400
    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteDC cdc: DeleteObject ccb
    dimt = tch
End Function

pijaku · Answer

Je ne suis pas mécontent du résultat.

A prévoir : un avertissement pour la non prise en compte du scrollbar horizontal.

A modifier : la Const COEFF = 1.333333333333

Sinon, le code, pour l'instant :
1 userform, 1 frame, 1 textbox et 1 listbox.

Option Explicit

Private Type hv
   X As Long
   Y As Long
End Type

Private Type LOGFONT
  lfHeight As Long
  lfWidth As Long
  lfEscapement As Long
  lfOrientation As Long
  lfWeight As Long
  lfItalic As Byte
  lfUnderline As Byte
  lfStrikeOut As Byte
  lfCharSet As Byte
  lfOutPrecision As Byte
  lfClipPrecision As Byte
  lfQuality As Byte
  lfPitchAndFamily As Byte
  lfFaceName As String * 32
End Type

#If VBA7 Then
   Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#Else
   Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
   Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
   Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
   Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
   Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
   Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
   Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
   Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
   Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
   Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As hv) As Long
   Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
   Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
#End If

Private Const vbapoints As Integer = 20
Private Const vbapixels As Integer = 999 ' n'importe quoi sauf les autres valeurs
Private Const vbainches As Integer = 1440
Private Const vbatwips As Integer = 1
Private Const vbaCharacters As Integer = 120
Private Const SM_CYVSCROLL = 20 'hauteur d'une flèche d'ascenseur vertical
Private Const SM_CXHSCROLL = 21 'largeur d'une flèche d'ascenseur vertical
Private Const SM_CYHSCROLL = 3 'hauteur d'une barre de défilement horizontale
Private Const SM_CXBORDER = 5

Private Const COEFF As Single = 1.333333333333

Private mHeight As Single, mWidth() As Single, mLeft() As Single, bord As Single
Private colonne As Byte
Private vba_font As New StdFont

Private Sub UserForm_Initialize()
Dim i As Integer, j As Integer, corr_effect As Integer, Col As Integer
Dim echelle As String, largeurs(), strColWidths As String, oldListWidth As Double

bord = GetSystemMetrics(SM_CXBORDER) / COEFF
   '-------PROPRIETES FRAME1
   With Me.Frame1
      .Visible = False
      .Caption = ""
      .BorderStyle = fmBorderStyleNone
   End With
   '------------------------------
   '-------GESTION HAUTEUR DE LIGNES en fonction POLICE
   ListBox1.Font.Size = 11
   Set vba_font = ListBox1.Font
   With vba_font
     .Bold = ListBox1.Font.Bold
     .Italic = ListBox1.Font.Italic
   End With
   mHeight = vba_TextHeight("Coucou", vba_font)
   '------------------------------
   '-------PROPRIETES ET REMPLISSAGE LISTBOX
   oldListWidth = ListBox1.Width
   ListBox1.ColumnCount = 3
   echelle = " cm"
   largeurs = Array(3, 2, 4)
   strColWidths = largeurs(0)
   For i = 1 To UBound(largeurs)
      strColWidths = strColWidths & echelle & ";" & largeurs(i)
   Next
   ListBox1.ColumnWidths = strColWidths & " " & echelle
      '-------GESTION MULTI-COLONNES
      ReDim Preserve mLeft(ListBox1.ColumnCount - 1)
      ReDim Preserve mWidth(ListBox1.ColumnCount - 1)
      mLeft(0) = 1
      If ListBox1.ColumnCount > 1 Then
         mWidth(0) = CSng(Replace(Split(ListBox1.ColumnWidths, ";")(0), " pt", ""))
         For Col = 1 To ListBox1.ColumnCount - 1
            mLeft(Col) = CDbl(Replace(Split(ListBox1.ColumnWidths, ";")(Col - 1), " pt", "")) + mLeft(Col - 1)
            mWidth(Col) = CSng(Replace(Split(ListBox1.ColumnWidths, ";")(Col), " pt", ""))
         Next
         ListBox1.Width = mLeft(UBound(mLeft)) + mWidth(UBound(mWidth)) + ListBox1.ColumnCount
         DoEvents
      Else
         If ListBox1.ListCount * (mHeight / COEFF) > ListBox1.Height Then
            mWidth(0) = ListBox1.Width - Largeur_Scrollbar
         Else: mWidth(0) = ListBox1.Width - 2
         End If
      End If
      Me.Width = Me.Width + ListBox1.Width - oldListWidth
      '------------------------------
   For i = 0 To 50
      ListBox1.AddItem "aa " & i
      For j = 1 To ListBox1.ColumnCount - 1
         ListBox1.List(i, j) = Chr(97 + j) & Chr(97 + j) & " - " & i
      Next
   Next
   '------------------------------
   '-------PROPRIETES TEXTBOX1
   corr_effect = IIf(ListBox1.SpecialEffect = 0, 1, 0)
   With TextBox1
     .ForeColor = vbRed
     .Move 0, -(bord * 2) - corr_effect, Frame1.Width, Frame1.Height - (bord * 2)
     .Font.Size = ListBox1.Font.Size
     .Font.Bold = ListBox1.Font.Bold
     .Font.Italic = ListBox1.Font.Italic
   End With
   '------------------------------
End Sub

Private Sub ListBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'enregistrement, à chaque "clic" souris, de la colonne
Dim i As Integer
   For i = UBound(mLeft) To LBound(mLeft) Step -1
      If X >= mLeft(i) Then colonne = i: Exit For
   Next i
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'EVENEMENT DECLENCHEUR
   positionnons
End Sub

Private Sub ListBox1_Enter()
'GESTION DU SCROLL LISTBOX1
   If Frame1.Visible Then Frame1.Visible = False
End Sub

Private Sub positionnons()
Dim corr_effect As Byte
   With Frame1
      .Top = ListBox1.Top + (ListBox1.ListIndex - ListBox1.TopIndex) * (mHeight / COEFF)
      .Left = ListBox1.Left + 1 + mLeft(colonne)
      .Width = IIf(colonne < ListBox1.ColumnCount - 1, mWidth(colonne), mWidth(colonne) - (GetSystemMetrics(SM_CXHSCROLL) / COEFF))
      If ListBox1.SpecialEffect = 0 Then corr_effect = 1 Else corr_effect = ListBox1.SpecialEffect
      .Height = (mHeight / COEFF) + corr_effect + (bord * 1)
      If .Top >= ListBox1.Top Then
         .Visible = True
         .ZOrder
         With .TextBox1
            Set .Font = ListBox1.Font
            .Value = ListBox1.List(ListBox1.ListIndex, colonne)
            .Width = Frame1.Width
            .SetFocus
         End With
       Else: .Visible = False
       End If
   End With
End Sub

Private Function Largeur_Scrollbar() As Single
Dim Larg As Single
   Larg = Val(Str$(GetSystemMetrics(SM_CXBORDER))) * 2
   Larg = Larg + (Val(Str$(GetSystemMetrics(SM_CXHSCROLL))) + Larg)
   Largeur_Scrollbar = Larg / COEFF
End Function
Private Function vba_TextHeight(texte As String, la_font As StdFont) As Single
   vba_TextHeight = dimt(texte, la_font).Y
End Function
Private Function dimt(ch As String, ByVal pol As StdFont) As hv
    Dim cdc As Long, ccb As Long, cfi As Long, lgf As LOGFONT, tch As hv
    cdc = CreateDC("DISPLAY", "", "", ByVal 0)
    ccb = CreateCompatibleBitmap(cdc, 1, 1)
    DeleteObject SelectObject(cdc, ccb)
    lgf.lfFaceName = pol.Name & Chr$(0): lgf.lfHeight = -MulDiv(pol.Size, GetDeviceCaps(GetDC(0), 90), 72)
    lgf.lfItalic = pol.Italic: lgf.lfStrikeOut = pol.Strikethrough: lgf.lfUnderline = pol.Underline
    lgf.lfWeight = 400
    If pol.Bold = True Then lgf.lfWeight = lgf.lfWeight * 2
    cfi = CreateFontIndirect(lgf)
    DeleteObject SelectObject(cdc, cfi)
    GetTextExtentPoint32 cdc, ch, Len(ch), tch
    DeleteObject cfi: DeleteDC cdc: DeleteObject ccb
    dimt = tch
End Function

pijaku · Answer

Bonjour,

Après échange de nos fichiers, il s'avère que nos deux versions différent. En effet, la tienne, Jacques, utilise l'événement déclencheur Mouse_Up tandis que la mienne utilise le double-clic.
Nous conviendrons qu'il faille les conserver toutes deux afin de laisser le choix à l'utilisateur final.
Il suffira d'ajouter un paramètre, ou une propriété supplémentaire avec un réglage par défaut.

Ceci étant dit, nous avons toujours le problème du scroll horizontal.
Nous avions vu qu'il convenait de le traiter, peut-être, en forçant l'affichage de la listBox en "toute largeur".
Malheureusement ce ne sera pas toujours aisé, selon la taille de l'UserForm par rapport aux données de la liste...

Comment faire dans ce cas?

Ta suggestion finale est "d'encapsuler" la listbox dans un Frame.
En effet, ceci permet d'avoir accès au scroll horizontal (et vertical) du Frame.

Le Hic est que je ne connais pas l'événement Scroll des Frame, ces paramètres m'ont l'air assez "chaud". Je vais me pencher là-dessus.

Seconde chose à valider, l'encapsulation de la listbox dans le Frame. 
Comment vois tu la chose?

ucfoutu · Answer

Bonjour, Franck,
1) J'ai déjà réglé la" chose" avec l' "encapsulage" dans un Frame.
Il me faut simplement faire le ménage dans mon code (à l'état de brouillon).
Je t'enverrai ce soir un premier jus avec cet encapsulage. Il te donnera des idées, y compris pour ton approche de traitement..

2) A propos d' "approche de traitement", toutefois, j'ai cette nuit beaucoup pensé à plusieurs aspects qui vont nous obliger à revoir tant mon aspect que le tien. Je t'en parlerai plus tard, lorsqu'aura été définitivement arrêtée la méthode du défilement horizontal (ce soir, donc).

pijaku · Answer

Ok.
En attendant ton "jus", je vais me pencher sur les paramètres du Scroll :
ByVal ActionX As MSForms.fmScrollAction, 
ByVal ActionY As MSForms.fmScrollAction, 
ByVal RequestDx As Single, 
ByVal RequestDy As Single, 
ByVal ActualDx As MSForms.ReturnSingle, 
ByVal ActualDy As MSForms.ReturnSingle

Du boulot en perspective...

ucfoutu · Answer

Je vais t'y aider : les paramètres requestdx et requestdy permettent de savoir ce que tu as "scrollé" : - si scroll horizontal, requestdx <> 0 (=6) et requestdy = 0 - si scroll vertical, requestdy <> 0 (=6) et requestdx = 0 actionx et actiony te permettent de savoir sur quelle flêche du scrollbar (déterminé par requestdx ou requestdy) tu as cliqué - ne te préoccupe pas de actualdx et actualdy (tu n'en as pas vraiment besoin). Ils ne sont en fait que les distances parcourues dans le sens utilisé, exprimées en points. Attends de recevoir mon fichier. Tu vas très vite comprendre. ________________________ Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

ucfoutu · Answer

Mon petit (tout petit mais nécessaire) apport de ce soir :

 Nous avons jusqu'à présent travaillé sur une simulation de listbox créée en mode création.
Et nous avons défini 
- le nombre de colonnes
- les largeurs de ces colonnes
Bien ... Mais le développeur peut toujours (toujours en mode création) déclarer le nombre de colonnes, mais ne pas définir leurs largeurs. Ce genre de développeur non minutieux existe !
La propriété Columnwidths, dans ce cas, reste = "", bien que chaque colonne se voie attribuer une largeur = largeur_totale/nombre_colonnes
Or, notre code à, lui, besoin de cette précision (sinon : plantage !)
Ah ===>>> simple, pour s'en sortir ===>>>
  If ListBox1.ColumnWidths = "" Then    Dim zut As Single    zut = ListBox1.Width / ListBox1.ColumnCount    For i = 0 To ListBox1.ColumnCount - 1      ListBox1.ColumnWidths = ListBox1.ColumnWidths & ";" & zut    Next    ListBox1.ColumnWidths = Mid(ListBox1.ColumnWidths, 2)  End If  MsgBox ListBox1.ColumnWidths
Je ne doute pas une seule fraction de seconde de ce que tu sais déjà où placer ce petit bout de code (change-moi ce "zut", quand-même)
A plus
________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

pijaku · Answer

Bonjour,

J'ai décidé d'abandonner la méthode du double-clic.
Pourquoi?
Parce qu'elle mobilisait 3 événements : Mouse_Down, Mouse_Up et DoubleClick.
Pour les futurs utilisateurs, il me semble totalement incohérent de les priver d'autant d'événements.

Par conséquent, si tu le veux bien, nous allons continuer avec ta méthode du simple-clic.

Je vais tenter de refaire un fichier aujourd'hui ou demain.

ucfoutu · Answer

Bonjour, Franck,
C'est l'une (pas l'unique) des raisons pour lesquelles il m'est apparu souhaitable de m'accrocher au MouseDown ou au MouseUp.
D'autant que ces deux évènements permettent de savoir (leur paramètre X) l'abscisse du curseur (ce qui est très utile en cas de multicolonnes).
Rien n'empêche, en plus, de définir le bouton utilisé (le paramètre Button de ces évènements). Cela peut être également très utile...
Je me bats en ce moment pour arriver à solutionner un autre problème, non vraiment rédhibitoire en ce qui concerne notre projet, mais que j'aimerais vraiment résoudre : l'extraction avec assurance du handle d'une textbox sous VBA. J'y parviens sans peine lorsqu'il n'y en a qu'une seule, mais me trouve totalement désemparé lorsqu'il y en a plusieurs ... Très curieusement, elles se retrouvent toutes avec le même handle.
Tu sais que nous avons  la solution (une propriété cachée) en ce qui concerne le handle de toute fenêtre windows à part entière (un Frame, par exemple). Elle ne s'applique malheureusement pas à une textbox qui, sous VBA, n'est pas une fenêtre Windows à part entière.
Voilà ... c'est à la compréhension de CE point et à sa résolution éventuelle que je consacre en ce moment toute mon énergie.
Pourquoi ? ===>> pour tout créer dynamiquement, de sorte à ce que l'utilisateur n'ait, lui, aucune autre intervention que l'ajout, in fine, d'un module de classe.


 
________________________
Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

pijaku · Answer

Bonjour Jacques,

Je suis très curieux de voir le résultat que tu espères, à savoir : faire en sorte à ce que l'utilisateur n'ait, lui, aucune autre intervention que l'ajout, in fine, d'un module de classe. 

Par contre, je ne saisis pas l'importance de déterminer le Handle du TextBox. Mais là dessus, tu as toute ma confiance, il doit y avoir une raison.
Je pensais créer le textbox (et son Frame) dans le module de classe. Ceci permet d'être dynamique et invisible...

Création d'un objet ListBox modifiable et dynamique

26 réponses

Votre réponse

Discussions similaires