Selection listbox

Le 22/03/2019 à 19:03

Salut forum!

quelqu'u aurait un idée?

J'ai un listbox multiselect

Quand je click sur un choix lors du tout premier clic, le premier item de la box se sélectionne en plus de celui cliqué ... quelqu'un aurait une explication?

wj0zrk2
Le 22/03/2019 à 19:21

Bonjour,

pas d'explication!

A voir dans le code s'il y a quelque chose qui ferait réagir comme ça.

A+

Le 22/03/2019 à 19:26
Option Explicit
Dim Buttons() As New Boutons

Private IsHooked As Boolean

Private Sub CheckBox1_Click()
If Me.CheckBox1.Value = True Then
Me.LabelClient.Caption = Me.TextBox3.Value & "     -     " & Me.TextBox9.Value
Me.ListBox2.enabled = False
End If
If Me.CheckBox1.Value = False Then
Me.LabelClient.Caption = "Client"
Me.ListBox2.enabled = True
End If
End Sub

Private Sub Browse1_Click()
Call FileBrowser.StartIt
End Sub
Private Sub Browse2_Click()
Call FileBrowser.StartIt2
End Sub
Private Sub Browse3_Click()
Call FileBrowser.StartIt3
End Sub
Private Sub CommandButton113_Click()

End Sub

Private Sub CommandButton114_Click()
Tri_Bibli_Clients
End Sub

Private Sub CommandButton115_Click()
Call DossierMUC
End Sub
Sub DossierMUC()
Application.ScreenUpdating = False
Dim NomClient As String
Dim MonRepertoire As String
Dim RepertoireEnCours As String
Dim Repertoire_Client
Dim Repertoire_Soumissions As String
Dim Repertoire_Soumissions_Avec_Prix As String
Dim Repertoire_Plans As String
Dim Repertoire_Depenses As String
Dim Repertoire_SousTraitants_Soumissions As String
Dim Repertoire_Suivi As String
Dim Repertoire_Planning As String
Dim Repertoire_Devis As String
Dim Repertoire_Devis_PDF As String
Dim Repertoire_Factures As String
Dim Repertoire_Factures_PDF As String
Dim Profil As String
Profil = Environ("username")
NomClient = TextBox3.Value

'MonRepertoire = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\"
'RepertoireEnCours = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\"
Repertoire_Client = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\"
Repertoire_Soumissions = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Soumissions pour envoi\"
Repertoire_Soumissions_Avec_Prix = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Soumissions pour envoi\Avec_Prix"
Repertoire_Plans = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Plans\"
Repertoire_Depenses = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Dépenses\"
Repertoire_SousTraitants_Soumissions = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Sous-Traitants Soumissions\"
Repertoire_Suivi = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Suivi\"
Repertoire_Planning = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Planning\"
Repertoire_Devis = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Devis\"
Repertoire_Devis_PDF = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Devis\PDF"
Repertoire_Factures = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Factures\"
Repertoire_Factures_PDF = "C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Factures\PDF"

On Error Resume Next
'MkDir MonRepertoire
'MkDir RepertoireEnCours
MkDir Repertoire_Client
MkDir Repertoire_Soumissions
MkDir Repertoire_Soumissions_Avec_Prix
MkDir Repertoire_Plans
MkDir Repertoire_Depenses
MkDir Repertoire_SousTraitants_Soumissions
MkDir Repertoire_Suivi
MkDir Repertoire_Planning
MkDir Repertoire_Devis
MkDir Repertoire_Devis_PDF
MkDir Repertoire_Factures
MkDir Repertoire_Factures_PDF
Call Suivi
Call Planning
Unload Me

Workbooks("GestionFactureBD.xlsm").Sheets("Feuil1").Select
End Sub

Private Sub CommandButton116_Click()
Call FileBrowser.StartIt
End Sub

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function
Private Sub ChoixCompte()

    Dim OutApp As Outlook.Application
    Dim I As Long

    Set OutApp = CreateObject("Outlook.Application")

    For I = 1 To OutApp.Session.Accounts.Count
        MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
    Next I

End Sub
Private Sub CommandButton118_Click()
Dim I As Long
Me.TextBox16.Value = ""
Me.TextBox17.Value = ""
For I = 0 To ListBox2.ListCount - 1
    ListBox2.Selected(I) = False
Next I

Me.filenameinput.Value = ""
Me.filenameinput2.Value = ""
Me.filenameinput3.Value = ""

End Sub

Private Sub CommandButton119_Click()
 If IsHooked Then UnhookListBoxScroll
Unload Me
Sheets("Clients").Range("DD2:DD100").ClearContents
Sheets("Feuil1").Select
End Sub

Private Sub CommandButton120_Click()
UserForm12.Hide
UserFormAjoutContact12.Show
End Sub

Private Sub Label1_Click()

End Sub

Private Sub Label13_Click()

End Sub

Private Sub Label20_Click()

End Sub

Private Sub ListBox2_Click()

End Sub

Private Sub OptionButton1_Click()
Me.TextBox2.enabled = True
End Sub

Private Sub TextBox11_Exit(ByVal Cancel As MSForms.ReturnBoolean)

    TextBox11.Text = Format$(TextBox11.Text, "0,00")

End Sub
Private Sub CommandButton112_Click()
Call GetDistance
End Sub
Sub GetDistance()
Application.ScreenUpdating = False
Sheets("Feuil1").Unprotect
Sheets("Feuil1").Range("J142").Value = Me.TextBox4.Text
Application.ScreenUpdating = True
Me.TextBox11.Value = Sheets("Feuil1").Range("J146").Text
Sheets("Feuil1").Protect
End Sub

Private Sub ListBox1_MouseMove( _
             ByVal Button As Integer, ByVal Shift As Integer, _
             ByVal x As Single, ByVal y As Single)
' start the hook
     HookListBoxScroll
      IsHooked = True
End Sub

Private Sub TextBox12_Change()
Me.TextBox3.Text = Me.TextBox12.Text
End Sub
Private Sub TextBox13_Change()
Me.TextBox3.Text = Me.TextBox12.Text & " " & Me.TextBox13.Text
End Sub
Private Sub TextBox14_Change()
Me.TextBox3.Text = Me.TextBox12.Text & " " & Me.TextBox13.Text & " et " & Me.TextBox14.Text
End Sub
Private Sub TextBox15_Change()
Me.TextBox3.Text = Me.TextBox12.Text & " " & Me.TextBox13.Text & " et " & Me.TextBox14.Text & " " & Me.TextBox15.Text
End Sub

Private Sub TextBox17_Change()

End Sub

Private Sub TextBox3_Change()
'Me.TextBox2.Text = Me.TextBox13.Text & "_" & Me.TextBox15.Text
End Sub
Private Sub TextBox4_AfterUpdate()
Call GetDistance
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, _
  CloseMode As Integer)
    If IsHooked Then UnhookListBoxScroll
    Unload Me
    Workbooks("GestionFactureBD.xlsm").Activate
    Sheets("Clients").Range("DD2:DD100").ClearContents
    Sheets("Feuil1").Select
End Sub
'=============================================================
Private Sub CommandButton12_Click() 'Aide
AjoutercontactsOutlook
End Sub

Private Sub Label11_Click()

End Sub

Private Sub Label5_Click()

End Sub

Private Sub TextBox10_Change()

End Sub

Private Sub TextBox5_Change()

End Sub

Private Sub TextBox8_Change()

End Sub
Sub Listbox2Depart()
Dim nB%, I%, x%, NomDest$, EmailDest$, Montant$
Dim A As String

Me.ListBox2.ColumnCount = 2
ListBox2.ColumnWidths = "120;160"

Sheets("Clients").Activate
nB = Sheets("Clients").Range("cx1").Value
x = 2 'Seuil de départ de la liste

For I = 1 To nB

NomDest = Sheets("Clients").Range("CZ" & I + x).Value
    EmailDest = Sheets("Clients").Range("DA" & I + x).Value

    Me.ListBox2.AddItem
    ListBox2.List(I - 1, 0) = NomDest
    ListBox2.List(I - 1, 1) = EmailDest
 Next I

End Sub

Private Sub CommandButton117_Click()

Application.ScreenUpdating = False
Sheets("Clients").Range("DD2:DD100").ClearContents
If Me.CheckBox1.Value = True Then
Sheets("Clients").Range("DD65536").End(xlUp)(2, 1) = Me.TextBox9.Value
End If
Dim SigString As String
Dim Signature As String
SigString = Environ("appdata") & _
                "\Microsoft\Signatures\CRFLIX.htm"
                If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    On Error Resume Next

Dim OutApp As Outlook.Application
Dim lItem As Long
    For lItem = 0 To ListBox1.ListCount - 1
        If ListBox2.Selected(lItem) = True Then
            Sheets("Clients").Range("DD65536").End(xlUp)(2, 1) = ListBox2.List(lItem)
            ListBox2.Selected(lItem) = False
        End If
    Next
    Sheets("Clients").Select

  '--- Envoi par mail
  Dim olapp As Outlook.Application
  Set OutApp = CreateObject("Outlook.Application")

  Sheets("Clients").Select
  Range("DD2").Select
  Do While Not IsEmpty(ActiveCell)
     Dim msg As MailItem
     Set olapp = New Outlook.Application
     Set msg = olapp.CreateItem(olMailItem)

     msg.To = ActiveCell.Value
     msg.Subject = Me.TextBox16.Value
     msg.Body = Me.TextBox17.Value
         msg.Attachments.Add Source:=Me.filenameinput.Value
         msg.Attachments.Add Source:=Me.filenameinput2.Value
         msg.Attachments.Add Source:=Me.filenameinput3.Value
     msg.SendUsingAccount = OutApp.Session.Accounts.Item(1)
     msg.Send
     ActiveCell.Offset(1, 0).Select
  Loop
  On Error GoTo 0

    Set olapp = Nothing
   Set OutApp = Nothing
   Set msg = Nothing
Sheets("Clients").Range("DD2:DD100").ClearContents

End Sub

'=============================================================
Private Sub Userform_Initialize()
Call Initialisation

'Call Listbox2Depart
'Dim DestinatairesNom As String
'Dim DestinatairesEmail As String
'
'DestinatairesNom = Range("CZ" & Rows.Count).End(xlUp)
'DestinatairesEmail = Range("DA" & Rows.Count).End(xlUp)

'Range("CZ2", Range("CZ" & Rows.Count).End(xlUp)).Name = "DestinatairesNom"

'--bonne
Sheets("Clients").Activate
    Range("DA2", Range("DA" & Rows.Count).End(xlUp)).Name = "Destinataires"
    Me.ListBox2.RowSource = "Destinataires"
    '-------------

End Sub

'=============================================================
Sub Initialisation()
Dim nB%, I%
Dim Client$
Dim Etat As Variant

nB = Sheets("Clients").Range("AQ3").Value
Label9.Caption = "Liste Clients   ( Q = " & nB & " )"
If nB = 0 Then Exit Sub 'si bibli vide
Call Tri_Bibli_Clients_2
'------------------- Chargement Listbox1 ---------------
For I = 1 To nB
    Client = Sheets("Clients").Range("AR" & 3 + I).Value
    ListBox1.AddItem (Client)
Next I
'----------------------------- Choix -------------------------------
Etat = Array("-------", "Particulier", "Entreprise", "Docteur", "Me")
For I = 0 To 4
    ComboBox1.AddItem Etat(I)
Next I
Sheets("Feuil1").Select
Me.ListBox1.SetFocus
End Sub

'=============================================================
Sub Tri_Bibli_Clients()
Dim nB%, LD%
Dim AdDebut$, AdFin$
Dim Motif$

Sheets("Clients").Select
nB = Sheets("Clients").Range("AQ3").Value
LD = 3 'Ligne départ du traitement

'----------------------- adresse tri -----------------
AdDebut = "AR3"
AdFin = ("BA" & nB + LD) 'Nb(nombre d'articles)
'-----------------------------------------------------
Motif = UserForm12.CommandButton114.Caption 'Récupère le texte du bouton

'-------- TRI ALPHABETIQUE EN ORDRE CROISSANT  A > Z DE LA BIBLI ------
    If Motif = "Tri  Z-A" Then 'Texte du bouton
    Range(AdDebut, AdFin).Select
    ActiveCell.Sort key1:=Range("AR3"), order1:=xlAscending, header:=xlGuess
    Range("AR2").Select
    End If

'-------- TRI ALPHABETIQUE EN ORDRE DECROISSANT  Z > A DE LA BIBLI ------
If Motif = "Tri  A-Z" Then  ' Texte du bouton
    Range(AdDebut, AdFin).Select
    ActiveCell.Sort key1:=Range("AR3"), order1:=xlDescending, header:=xlGuess
    Range("AR2").Select

End If
Sheets("Clients").Select
End Sub

'================================================================================
Sub Ligne_Vide_Bibli_Clients()
Dim nB%, x%
Dim Lp%, Lv%, LD%

'------------ Initialisation ----------------------
nB = Sheets("Clients").Range("AQ3").Value
Lp = 0 'Compteur lignes pleines
Lv = 0 'Compteur lignes vides
LD = 4 'ligne de départ du traitement ici ---> "AR4"

'------------ Suppression des Lignes vides qq soient leurs nombres ---------------
Do While Lp <= nB - 1
    If Range("AR" & LD + Lp + Lv).Value = "" Then
        Lv = Lv + 1
        ElseIf Range("AR" & LD + Lp + Lv).Value <> "" And Lv >= 1 Then
            For x = 0 To 9
                Range("AR" & LD + Lp).Offset(0, x) = Range("AR" & LD + Lp).Offset(Lv, x).Value
                Range("AR" & LD + Lp).Offset(Lv, x).Value = ""
            Next
        Lp = Lp + 1
        Lv = 0
    Else
        Lp = Lp + 1
    End If
Loop
End Sub

'=============================================================
Sub Effacer_Textbox() 'effacer les textbox
Dim I%

For I = 0 To 9
    Controls("Textbox" & I + 2).Value = ""
Next I
End Sub
Private Sub Listbox1_Change()
Application.ScreenUpdating = False

Dim nB%, y%, x%, I%
Dim Element_Select As Boolean
Element_Select = False
nB = Sheets("Clients").Range("AQ3").Value
x = 4
If nB = 0 Then Exit Sub 'si bibli vide
'---------------- Chargement Textbox ------------------------
For I = 0 To nB - 1
    If UserForm12.ListBox1.Selected(I) = True Then
        Element_Select = True
        Sheets("Clients").Activate
        Sheets("Clients").Range("AR" & I + x).Select
        For y = 0 To 9
            Controls("TextBox" & y + 2).Value = Range("AR" & I + x).Offset(0, y).Value
        Next y
        End If
        Next I
        '----------- DETECTION D'ERREUR (PAS DE SELECTION)---------------
If Element_Select = False Then
    'MsgBox "vous n'avez rien sélectionné: fin du programme", , "FACTURE DEVIS"
    Exit Sub
End If
Sheets("Feuil1").Select
Me.Label11.Caption = Me.TextBox2.Value
Call Tri_Bibli_Clients_2

End Sub
Private Sub CommandButton111_Click()
Call Suivi
End Sub
Sub Suivi()
Application.ScreenUpdating = False
Dim Profil As String
Dim NomClient As String
Dim NomClientFeuille As String
Dim Adresse As String
Dim Telephone As String
Dim Modele As String
Dim Km As String
Dim src As Workbook
Dim fname As Variant

NomClientFeuille = TextBox2.Value
Km = TextBox11.Value
NomClient = TextBox3.Value
Adresse = "Actuelle: " & TextBox6.Value & "  /  Projet: " & TextBox4.Value
Telephone = TextBox7.Value & "  /  " & TextBox8.Value
Modele = TextBox10.Value
Profil = Environ("username")
Application.DisplayAlerts = False
'VBAProject.UserForm12.Hide
Set src = Workbooks.Open("C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\SUIVI.xlsm", IgnoreReadOnlyRecommended:=True)
Sheets(1).Activate
ActiveSheet.Name = NomClientFeuille
Range("D2").Value = NomClient
Range("D3").Value = Adresse
Range("D4").Value = Telephone
Range("D6").Value = Modele
Range("D7").Value = Km
Sheets(2).Activate
ActiveSheet.Name = NomClientFeuille & " - Notes"
Range("D2").Value = NomClient
Range("D3").Value = Adresse
Range("D4").Value = Telephone
Range("D6").Value = Modele
Range("D7").Value = Km
Sheets(1).Select
'Workbooks ("GestionFactureBD.xlsm").Select
  ActiveWorkbook.SaveAs fileName:="C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Suivi\" & NomClient & "-SUIVI.xlsm"
   ActiveWorkbook.Close

End Sub
Sub Planning()
Application.ScreenUpdating = False
Dim Profil As String
Dim NomClient As String
Dim NomClientFeuille As String
Dim Adresse As String
Dim Telephone As String
Dim Modele As String
Dim Km As String
Dim src As Workbook
Dim fname As Variant

NomClientFeuille = TextBox2.Value
Km = TextBox11.Value
NomClient = TextBox3.Value & " " & TextBox2.Value
Adresse = "Actuelle: " & TextBox6.Value & "  /  Projet: " & TextBox4.Value
Telephone = TextBox7.Value & "  /  " & TextBox8.Value
Modele = TextBox10.Value
Profil = Environ("username")
Application.DisplayAlerts = False
'VBAProject.UserForm12.Hide
Set src = Workbooks.Open("C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\Planning.xlsm", IgnoreReadOnlyRecommended:=True)
Range("G3") = NomClient
'Workbooks ("GestionFactureBD.xlsm").Select
  ActiveWorkbook.SaveAs fileName:="C:\Users\" & Profil & "\OneDrive - ETS\Gestion CRB\____DOSSIER EN COURS____\" & NomClient & "\Planning\" & NomClient & "-Planning.xlsm"
ActiveWorkbook.Close
'UserForm12.Show
Workbooks("GestionFactureBD.xlsm").Activate
Unload Me
'ActiveWorkbook.Close

End Sub
'=============================================================
Private Sub CommandButton1_Click() 'Sélectionner
Dim nB%, y%, x%, I%
Dim Element_Select As Boolean

Element_Select = False
nB = Sheets("Clients").Range("AQ3").Value
x = 4
If nB = 0 Then Exit Sub 'si bibli vide

'---------------- Chargement Textbox ------------------------
For I = 0 To nB - 1
    If UserForm12.ListBox1.Selected(I) = True Then
        Element_Select = True
        Sheets("Clients").Activate
        Sheets("Clients").Range("AR" & I + x).Select
        For y = 0 To 9
            Controls("TextBox" & y + 2).Value = Range("AR" & I + x).Offset(0, y).Value
        Next y
    End If
Next I
'----------- DETECTION D'ERREUR (PAS DE SELECTION)---------------
If Element_Select = False Then
    MsgBox "vous n'avez rien sélectionné: fin du programme", , "FACTURE DEVIS"
    Exit Sub
End If
Sheets("Feuil1").Select
End Sub

'=============================================================
Private Sub CommandButton2_Click() 'Modifier
Dim nB%, y%, x%, I%
Dim Element_Select As Boolean

Element_Select = False
nB = Sheets("Clients").Range("AQ3").Value
x = 4
If nB = 0 Then Exit Sub 'si bibli vide

'------------- Modification coordonnées client ------------------
For I = 0 To nB - 1
    If UserForm12.ListBox1.Selected(I) = True Then
        Element_Select = True
        Sheets("Clients").Activate
        Sheets("Clients").Range("AR" & I + x).Select
        For y = 0 To 9
            Range("AR" & I + x).Offset(0, y).Value = Controls("Textbox" & y + 2).Value
        Next
    End If
Next I

'----------- DETECTION D'ERREUR (PAS DE SELECTION)---------------
If Element_Select = False Then
    MsgBox "vous n'avez rien sélectionné: fin du programme", , "FACTURE DEVIS"
    Exit Sub
End If
Sheets("Feuil1").Select
End Sub

'=============================================================
Private Sub CommandButton3_Click() 'Ajouter
Dim nB%, y%, z%, I%
Dim Nom$, Prénom$
Dim Client$, PrénomClient$
'Call AjoutercontactsOutlook
Sheets("Clients").Select
nB = Sheets("Clients").Range("AQ3").Value
Nom = UCase(UserForm12.TextBox2.Value)
Prénom = UCase(UserForm12.TextBox3.Value)
z = 0

'--------------- Vérifie la présence d'un nom ------------
If Nom = "" Then
    MsgBox "Veuillez mettre un nom"
    Exit Sub
End If

'------------------- Vérification -------------------------
For I = 1 To nB
    Client = UCase(Range("AR" & 3 + I).Value)
    PrénomClient = UCase(Range("AS" & 3 + I).Value)
'    MsgBox Client
    If Nom = Client And Prénom = PrénomClient Then
        MsgBox "Vous avez déjà ce client, veuillez modifier"
        z = 1
        Exit Sub
    End If
Next I

'-------------------------- Ajouter ------------------------
If z = 0 Then
    For y = 0 To 9
        Range("AR" & 4 + nB).Select
        Range("AR" & nB + 4).Offset(0, y).Value = Controls("Textbox" & y + 2).Value
    Next
End If
Call Tri_Bibli_Clients
UserForm12.ListBox1.Clear
Call Initialisation
Sheets("Feuil1").Select
Call Tri_Bibli_Clients_2
End Sub

'=============================================================
Private Sub CommandButton4_Click() 'Supprimer
Dim KillAccept%
KillAccept = MsgBox("Voulez-vous vraiment supprimer la fiche: " & Me.TextBox2.Text & " ?", vbYesNo + vbCritical)
    If KillAccept = vbYes Then
    Call SupprimerFiche
    End If
End Sub
Sub SupprimerFiche()
Dim Element_Select As Boolean
Dim x%, I%, nB%, y%

Element_Select = False
nB = Sheets("Clients").Range("AQ3").Value
x = 4
If nB = 0 Then Exit Sub 'si bibli vide

'----------- Supprimer Client de la liste Bibli ---------------
For I = 0 To nB - 1
    If UserForm12.ListBox1.Selected(I) = True Then
        Element_Select = True
        Sheets("Clients").Activate
        Sheets("Clients").Range("AR" & I + x).Select
        For y = 0 To 9
            Range("AR" & I + x).Offset(0, y).Value = ""
        Next
    End If
Next I

'----------- DETECTION D'ERREUR (PAS DE SELECTION)---------------
If Element_Select = False Then
    MsgBox "vous n'avez rien sélectionné: fin du programme", , "FACTURE DEVIS"
    Exit Sub
End If

UserForm12.ListBox1.Clear
Call Ligne_Vide_Bibli_Clients
Call Initialisation
Call Effacer_Textbox
Sheets("Feuil1").Select
End Sub
'=============================================================
Private Sub CommandButton5_Click() 'Transfert vers devis
Dim Nom$
Dim NbDonnée%, x%, nB%, I%
Dim Element_Select As Boolean
Application.ScreenUpdating = True
Sheets("Feuil1").Select
Nom = Range("B9").Value
NbDonnée = Range("A7").Value

'------------------ Vérification Feuille Soumissdion ---------------

Element_Select = False
nB = Sheets("Clients").Range("AQ3").Value
x = 4
If nB = 0 Then Exit Sub 'si bibli vide

'------------------ Transfert Données vers Devis -------------
For I = 0 To nB - 1
    If UserForm12.ListBox1.Selected(I) = True Then
        Element_Select = True
        Sheets("Feuil1").Unprotect
        Range("B9").Value = UserForm12.TextBox2.Value
        Range("D4").Value = UserForm12.TextBox3.Value
        Range("D5").Value = UserForm12.TextBox4.Value
        Range("D6").Value = UserForm12.TextBox5.Value
        Sheets("Feuil1").Unprotect
        Range("E9").Value = UserForm12.TextBox10.Value

    End If
Next I

'----------- DETECTION D'ERREUR (PAS DE SELECTION)---------------
If Element_Select = False Then
    MsgBox "vous n'avez rien sélectionné: fin du programme", , "FACTURE DEVIS"
    Exit Sub
End If
Sheets("Feuil1").Range("A9").Select
End Sub

'=============================================================
Private Sub CommandButton6_Click() 'Quitter
 If IsHooked Then UnhookListBoxScroll
Unload Me
Sheets("Clients").Range("DD2:DD100").ClearContents
Sheets("Feuil1").Select

End Sub

'=============================================================
Private Sub CommandButton7_Click() 'Effacer
Call Effacer_Textbox
End Sub

'=============================================================
Private Sub CommandButton8_Click() 'Visu Archive
UserForm32.Show

End Sub

'=============================================================
Private Sub CommandButton9_Click() 'Afficher les devis ou factures en pdf
UserForm16.Show

End Sub

'=============================================================
Private Sub CommandButton10_Click() 'Valider
Dim y%

'--------------------- Choix ----------------------
Sheets("Feuil1").Unprotect
y = UserForm12.ComboBox1.ListIndex
'----------- cas ou la listindex est vide ---------
If y = -1 Then
    Exit Sub
End If

Sheets("Feuil1").Range("A8").Value = UserForm12.ComboBox1.List(y)
Sheets("Feuil1").Protect
End Sub

'=============================================================
Private Sub CommandButton11_Click()
Sheets("Clients").Range("DC6").Value = Me.TextBox3.Value
Sheets("Clients").Range("DC7").Value = Me.TextBox4.Value
TextBox16.Value = Sheets("Clients").Range("DC4").Value
TextBox17.Value = Sheets("Clients").Range("DC5").Value

End Sub

'=============================================================
Private Sub AjoutercontactsOutlook()
Application.ScreenUpdating = False
Dim emptyRow As Long

Sheets("Feuil1").Select
    Sheets.Add
    ActiveSheet.Name = "ContactsADD"
    Sheets("ContactsAdd").Activate
'Determine emptyRow
emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1

'Transfer information
Cells(emptyRow, 1).Value = TextBox3.Value
Cells(emptyRow, 2).Value = TextBox2.Value
Cells(emptyRow, 3).Value = TextBox4.Value
Cells(emptyRow, 4).Value = TextBox5.Value
Cells(emptyRow, 5).Value = TextBox6.Value
Cells(emptyRow, 6).Value = TextBox7.Value
Cells(emptyRow, 7).Value = TextBox8.Value
Cells(emptyRow, 8).Value = TextBox9.Value
Cells(emptyRow, 9).Value = TextBox10.Value

'Macro ves outlook
Call AjouterContactsExcel
Sheets("ContactsADD").Select
Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
End Sub
Sub AjouterContactsExcel()

    Dim oApplOutlook As Object
    Dim oNsOutlook As Object
    Dim oCFolder As Object
    Dim oDelFolder As Object
    Dim oCItem As Object
    Dim oDelItems As Object
    Dim lLastRow As Long, I As Long, n As Long, c As Long

    'Derniere rangée
    lLastRow = Sheets("ContactsADD").Cells(Rows.Count, "A").End(xlUp).Row

    'Démarrer Outlook
    On Error Resume Next
    Set oApplOutlook = GetObject(, "Outlook.Application")

    'Si une instance d'un objet Oulook n'Est pas dispo (Err.Number = 0 r):
    If Err.Number <> 0 Then
        Set oApplOutlook = CreateObject("Outlook.Application")
    End If

    'Pas de controle D'erreur
    On Error GoTo 0

    'GetNameMethod
    Set oNsOutlook = oApplOutlook.GetNamespace("MAPI")

    '----------------------------

    '
    Set oDelFolder = oNsOutlook.GetDefaultFolder(3)
    'Collection Items
    Set oDelItems = oDelFolder.Items

    'Nombre Ditem
    c = oDelItems.Count

    'Supprime a partir de la fin
    For n = c To 1 Step -1
        oDelItems(n).Delete
    Next n

    '----------------------------

    'Setup de la reference
    Set oCFolder = oNsOutlook.GetDefaultFolder(10)

    'Chaque post diffenrents formulaifes
    For I = 1 To lLastRow

        Set oCItem = oCFolder.Items.Add
        'Affichef Outlook
        'oCItem.Display

        'On rempli ca
        With oCItem
            .FullName = Sheets("ContactsADD").Cells(I, 1)
            '.FirstName = Sheets("ContactsADD").Cells(i, 2)
            .OtherAddress = Sheets("ContactsADD").Cells(I, 3)
            .Email2Address = Sheets("ContactsADD").Cells(I, 4)
            .HomeAddress = Sheets("ContactsADD").Cells(I, 5)
            .MobileTelephoneNumber = Sheets("ContactsADD").Cells(I, 6)
            .HomeTelephoneNumber = Sheets("ContactsADD").Cells(I, 7)
            .Email1Address = Sheets("ContactsADD").Cells(I, 8)

            .Body = "Modèle de Maison: " + Sheets("ContactsADD").Cells(I, 9)
        End With

        'On ferme

        oCItem.Close 0

    Next I

    'oApplOutlook.Quit

    'Nettoyer Variables
    Set oApplOutlook = Nothing
    Set oNsOutlook = Nothing
    Set oCFolder = Nothing
    Set oDelFolder = Nothing
    Set oCItem = Nothing
    Set oDelItems = Nothing

    'MsgBox "Contact ajouté au carnet d'adresse"

      'Shell ("OUTLOOK")

End Sub

Sub ImprimerBibliClientBackUP()
Dim nB%

Sheets("Clients").Activate
nB = Range("AQ3").Value

With ActiveSheet.PageSetup
    .PrintTitleRows = "$1:$3"
    .PrintTitleColumns = ""
    .CenterFooter = "Page - &P - sur  - &N - "
    .LeftMargin = Application.InchesToPoints(0.4)
    .RightMargin = Application.InchesToPoints(0.4)
    .TopMargin = Application.InchesToPoints(0.75)
    .BottomMargin = Application.InchesToPoints(0.75)
    .Orientation = xlLandscape
    .Zoom = 90
End With
    ActiveSheet.PageSetup.PrintArea = "AR4:BA" & (nB + 3)
    ActiveWindow.SelectedSheets.PrintOut copies:=1
'    ActiveSheet.PrintPreview
Sheets("Feuil1").Select
End Sub
Sub Tri_Bibli_Clients_2()
'
' Macro1 Macro
'

'Sheets("Clients").Select
Application.ScreenUpdating = False
    Range("AR3:BA9999").Select
    ActiveWorkbook.Worksheets("Clients").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Clients").Sort.SortFields.Add Key:=Range("AR3"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Clients").Sort
        .SetRange Range("AR4:BA9999")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Clients").Select
End Sub
Le 22/03/2019 à 20:48

Avez vous essayé sans la gestion du scroll avec la souris sur les listbox ?

Le 22/03/2019 à 21:13

bonsoir

mettre ton MultiSelect a 0 ' =fmMultiSelectSingle

A+

Maurice

Le 22/03/2019 à 23:14

merci mais je cherche justement une sélection multiple(voir code).

mise a jour; on dirait que le probleme a soudainement disparu

Rechercher des sujets similaires à "selection listbox"