Complément (Vba Indenter Interface) 2.0 Fx bis

[fanch55]

@fanch55
pour info l'indentation des private function dans un #if/#else ne s'indentent pas
en tout cas avec smart indenter ca le fait pas

mais quand même je fait mieux
tout les modules dans ce fichier (les modules de ton zip sont passé a la moulinnette de vba indenter interface V 3.0
a par celui avec les numéros devant chaque ligne je pense que j'ai un résultat + qu'acceptable

Tests avec le classeur renvoyé
Bizarre, certains #IF ont des indentations qui augmentent ....

 

[patricktoulon]

re
Bonsoir @fanch55
oui c'est le problème du moteur dans la 2.0 xx
si tu regarde la vidéo pour la 3.0 tu verra j'ai réglé le problème
c'est a cause de:
dès qu'il y a un switch private function dans un #if/#else
ça part en sucette
la 3.0 c'est définitivement du passé
je ne peux plus adapter le moteur 3.1 sur la version 2.0 c'est pour ça que je dis dans la vidéo
que le moteur 2.0 /2.4 et 3.0 sont abandonné
dans la version qui arrive interface 3.0 elle est équipé du moteur 3.1(html/string)
et tout ces petits soucis ont disparu
d'ailleurs si tu suis la vidéo je le démontre avec tout tes codes
je n'ai plus aucun de ces soucis

 

[patricktoulon]

la mise à jour 3.0 a été supprimée
cause:
j'en suis à la version 3.1 dans la quelle je réalise le souhait depuis le début de @fanch55
vidéo en préparation
désolé pour l'attente

 

[fanch55]

Un cas que je n'avais pas encore découvert :

 

[patricktoulon]

RE
et oui mais là tu n'a pas cocher la décompilation
sinon pour moi la ligne do qui commence et fini sur la même ligne c'est bon
le reste pour moi est parfaitement indenté sauf si mes yeux me jouent des tours
mais tout ces petits tracas ont disparus sur le 3.0 et maintenant la 3.1
donne moi ce code je te montre et tu me dis

 

[patricktoulon]

pour te mettre l'eau à la bouche
ça ça s'appelle le scroll

 

[fanch55]

RE
et oui mais là tu n'a pas cocher la décompilation
sinon pour moi la ligne do qui commence et fini sur la même ligne c'est bon
le reste pour moi est parfaitement indenté sauf si mes yeux me jouent des tours
mais tout ces petits tracas ont disparus sur le 3.0 et maintenant la 3.1
donne moi ce code je te montre et tu me dis

Option Compare Text
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Declare PtrSafe Function SetForegroundWindow Lib "user32" _
    (ByVal hwnd As LongPtr) As Long
Public Const Attrib_Done = "þ"
Public Const Coché = "ü"
Sub Start_Mao()
    Application.DisplayFullScreen = True
    Start_Onkey
    Start_Usf
    If [JOUEURS_REGULIERS].Cells(1) = "" Then APPEL_LISTE
End Sub
Sub Start_Usf()
    Usf_Mao_Ds.Show 0
End Sub
Sub Start_Onkey()
    Application.OnKey "^f", "Start_Usf" ' ctrl+f
    Application.OnKey "^s", "Save_Xltm" ' ctrl+s
    Application.OnKey "^o", "Svg_Stop"  ' ctrl+o
    Svg_Start
End Sub
Sub Close_Mao()
    ThisWorkbook.BuiltinDocumentProperties("Comments") = ""
    Application.OnKey "^f"
    Application.OnKey "^s"
    Application.OnKey "^o"
    Svg_Stop
End Sub
Sub Svg_Clean()
    
    N = 15:  Mdate = Date - N ' On garde n jours max de sauvegardes
    Set Fso = CreateObject("Scripting.FileSystemObject")
        For Each SVG In Fso.getfolder(ThisWorkbook.Names("Svg_Dir").RefersToRange).subfolders
            If Mdate > SVG.datecreated Then SVG.Delete
        Next
    Set Fso = Nothing

End Sub
Sub Svg_Stop()
On Error Resume Next
With ThisWorkbook
    If IsDate(.Names("Svg_Next").RefersToRange) Then
        Application.EnableEvents = False
        Application.OnTime .Names("Svg_Next").RefersToRange, "Svg_Run", , False
        .Names("Svg_Next").RefersToRange.ClearContents
        Application.EnableEvents = True
    End If
End With
End Sub
Sub Svg_Start()
With ThisWorkbook
    Select Case True
    Case .Names("Svg_Intvl").RefersToRange <= 0:   ' On ne lance pas
    Case Not IsDate(.Names("Svg_Next").RefersToRange)
        Application.EnableEvents = False
        T = TimeValue("00:" & Format(.Names("Svg_Intvl").RefersToRange, "00") & ":00")
        .Names("Svg_Next").RefersToRange = Now + T ' Toutes les Svg_Intvl minutes
        Application.OnTime .Names("Svg_Next").RefersToRange, "Svg_Run"
        Application.EnableEvents = True
    End Select
End With
End Sub
Sub Svg_Run()
Dim SVG    As String, Target As String
With ThisWorkbook
    If IsDate(.Names("Svg_Next").RefersToRange) Then
        Application.EnableEvents = False
        Application.ScreenUpdating = False
                
            Do While Dir(.Names("Svg_Dir").RefersToRange, vbDirectory) = "": Get_Folder_Svg: Loop
            
            Target = .Names("Svg_Dir").RefersToRange & "\" & .Names("Suffixe").RefersToRange & " " & Format(.Names("Date_Concours").RefersToRange, "dd-mm-yyyy") & "\"
            If Dir(Target) = "" Then MkDir Target
            
            SVG = Target & Format(Now, "hh_mm") & ".xlsm"
            If SVG = ThisWorkbook.FullName Then
                ActiveWorkbook.Save
            Else
                [E1].Value = [E1].Value 'FIGER la date d'AUJOURDHUI
                [A1].Select
                Application.DisplayAlerts = False
                    .SaveAs Filename:=SVG, FileFormat:=xlOpenXMLWorkbookMacroEnabled
                Application.DisplayAlerts = True
            End If
            If IsDate(.Names("Svg_Next").RefersToRange) Then .Names("Svg_Next").RefersToRange.ClearContents
            Start_Onkey
        Application.EnableEvents = True
    End If
End With
End Sub

Sub Save_Xltm()
Application.DisplayAlerts = False
    Worksheets("Inscrip").Activate
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim Filename As Variant
        Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
            With Dlg
                .AllowMultiSelect = False
                .Title = "Dossier de Lancement (XLTM)"
                .InitialFileName = [Root] & "*.xltm"
                .Filters.Clear
                .Filters.Add "Fichier de lancement", "*.xltm"
                If .Show Then
                    Application.EnableEvents = False
                        DEVERROU
                        [E1].FormulaR1C1 = "=TODAY()"
                        RAZ vbYes
                    Application.EnableEvents = True
                    Cur_File = ThisWorkbook.FullName
                    xlt_file = .SelectedItems(1)
                    ThisWorkbook.SaveAs Filename:=xlt_file, FileFormat:=xlOpenXMLTemplateMacroEnabled
                    
                    Set Wb_Xlt = ActiveWorkbook
                    D = InStrRev(xlt_file, "\")
                    MsgBox Mid(xlt_file, D + 1) & vbTab & "Saved Err=" & Err.Number, vbOKOnly + vbInformation, Left(xlt_file, D - 1)
                    Workbooks.Open Cur_File ' On ré-ouvre le classeur avant la copie modèle
                    Wb_Xlt.Close False
                    
                End If
            End With
        Set Dlg = Nothing
        
Application.DisplayAlerts = True

End Sub
Sub Print_Preview()
Dim S_Ad As Boolean

    S_Ad = Application.DisplayFullScreen
    Application.DisplayFullScreen = False
        Usf_Mao_Ds.Hide
        ActiveWindow.SelectedSheets.PrintPreview
        Usf_Mao_Ds.Show
    Application.DisplayFullScreen = S_Ad

End Sub


Sub Effacer()

Application.EnableEvents = False
    Set R = Worksheets("Inscrip").Rows(4).Find("Tour " & [Tour])
    If Not R Is Nothing Then
        Colonne = R.Column
        For Each Joueur In [Equipes].Rows(1).Cells ' les rows sont mergées
            If Joueur > 0 Then
            Set R = [TRI_RESU].Columns(1).Find(Joueur)
            Worksheets("Inscrip").Cells(R.Row, Colonne).ClearContents
            End If
        Next
    End If
    [Equipes].Parent.Charge_Cbx_Text
Application.EnableEvents = True

End Sub


Sub TRI_RESU_P_GAGNEES()
 
 If MsgBox("ATTENTION :" & vbLf & _
           "Cette étape nécessite d'avoir enregistré" & vbLf & _
           "TOUS LES RESULTATS de TOUS les tours de jeu " & vbLf & _
           "(voir feuille 'NOTER 1 RESULTAT' en E3 à H3)." & vbLf & vbLf & _
           UCase("AVEZ-VOUS ENREGISTRé TOUS LES RESULTATS  ?"), _
           vbCritical + vbYesNo, _
            "VALIDER pour CONTINUER.") = vbYes Then
 
    Svg_Run 'svg, AVANT TRI, forcée par sécurité
    [R23] = 1  'en jaune si =1 car le tri a été fait ==> les N° sont le classement : voir variable trié§ = _(avant_tri)
    
    Application.Goto Reference:="TRI_RESU"
    DEVERROU
    [TRI_RESU].Resize([NBJR]).Sort _
        Key1:=Range("L5"), Order1:=xlDescending, DataOption1:=xlSortTextAsNumbers, _
        Key2:=Range("P5"), Order2:=xlDescending, DataOption2:=xlSortNormal, _
        Key3:=Range("D5"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    VERROU
    Range("A1").Select
 End If
End Sub

Sub IMPRIMER_RESU()
Dim C As Range
Const Delim = vbTab
    CADRER_INSCRIP
    DEVERROU
    Application.EnableEvents = False
   ' On rajoute le n° de mobile en commentaire au nom
    Set C = [TRI_RESU].Find("*", , xlComments)
    Do While Not C Is Nothing
        If s_address = "" Then s_address = C.Address
        C.Value = C.Value & Delim & C.Comment.Text
        Set C = [TRI_RESU].Find("*", C, xlComments)
        If C.Address = s_address Then Set C = Nothing
    Loop
    
    ActiveSheet.PageSetup.PrintArea = "$B$1:$Q$135" ' = Zone "IMPRIM_RESULTAT"

    With ActiveSheet.PageSetup
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlPortrait
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 2
    End With
    If Usf_Mao_Ds.Visible Then Usf_Mao_Ds.Hide
    Print_Preview
    Usf_Mao_Ds.Show
    
   ' On enlève le n° de mobile en commentaire au nom
    Set C = [TRI_RESU].Find("*", , xlComments)
    s_address = ""
    Do While Not C Is Nothing
        If s_address = "" Then s_address = C.Address
        C.Value = Split(C.Value, Delim)(0)
        Set C = [TRI_RESU].Find("*", C, xlComments)
        If C.Address = s_address Then Set C = Nothing
    Loop
    
   ' Range("A1").Select
    Application.EnableEvents = True
    VERROU
End Sub
Sub Imp_Tirage(Optional Plage)
    If IsMissing(Plage) Then
        Plage_List = Array("*", [C28], [I28], [O28], [U28])
        N = Split(Application.Caller, "_")(2)
        If N > 0 Then
            Set Plage = Plage_List(N)
        Else
            For N = 1 To 4
                Imp_Tirage Plage_List(N)
            Next
            Exit Sub
        End If
    End If

Dim Text As String
Dim I    As Integer, LC As Integer, LR As Integer
Application.ScreenUpdating = False

F_Chiffres = 60
    F_Noms = 40
  F_Cadres = 30
  F_Color = Cells(8, Plage.Column).Interior.Color

Set R = Columns(Plage.Column).Rows(Rows.Count).End(xlUp)
Set Plage = Range(Plage, R).Resize(, 6)

On Error Resume Next
    Worksheets("ImpMao").Visible = True
    If Err() > 0 Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ImpMao"
    Worksheets("ImpMao").Activate
    Cells.Delete
    ActiveWindow.Zoom = 55
        
    Plage.Copy
        Range("D1").PasteSpecial xlPasteValues
        Selection.Interior.Color = F_Color
        Selection.HorizontalAlignment = xlCenter
        Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
        
On Error GoTo 0

    Cells.Font.Name = "Segoe UI"
    Cells.Font.Size = F_Chiffres
    Cells.VerticalAlignment = xlCenter
    
    With Columns("A").Cells(1) ' Colonne Terrain
        .Value = "Terrain"
        .Font.Size = F_Cadres
        .VerticalAlignment = xlBottom
    End With
    
    For Each C In Array("B", "K") ' colonnes Noms
        With Columns(C)
            .ColumnWidth = 200
            .Font.Size = F_Noms
            .HorizontalAlignment = xlRight
        End With
    Next
    For Each C In Array("C", "J") ' colonnes Score
        With Columns(C).Cells(1)
             .Value = "Score"
             .Font.Size = F_Cadres
             .VerticalAlignment = xlBottom
        End With
    Next
    
    LR = ActiveSheet.UsedRange.Rows.Count
    LC = Columns("K").Column
    Cells(1, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Range("A2:A" & LR).Borders(xlEdgeLeft).LineStyle = xlContinuous
    
    For I = LR To 2 Step -1
       ' If I = 3 Then Stop
        Select Case True
        Case Cells(I, 4) Like "Blanc*"
            If Cells(I, 6) > 0 Then
                Set_Joueurs I, 4, 2
                Cells(I, 9).ClearContents
                Cells(I, 4).Resize(, 2).Merge
                Cells(I, 4) = "Blanc:"
                Cells(I, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
            Else
                Cells(I, 4).EntireRow.Delete
            End If
        Case Cells(I, 4) > 0
            Set_Joueurs I, 4, 2
            Set_Joueurs I, 7, 11
            Cells(I, 1).Resize(, LC).Borders(xlEdgeBottom).LineStyle = xlContinuous
        Case Else
            Cells(I, 4).EntireRow.Delete
        End Select
    Next
    
    LR = ActiveSheet.UsedRange.Rows.Count
    
    With Range("D1:I" & LR)
       .BorderAround xlContinuous, xlThick
        With .Rows(1)
            .Merge
            .HorizontalAlignment = xlCenter
            .BorderAround xlContinuous, xlThick
            .Font.Bold = True
        End With
    End With
    Columns("G").Insert Shift:=xlToRight
    With Columns("G")
        .Interior.Pattern = xlNone
        .ColumnWidth = 2
    End With
    
    If WorksheetFunction.CountA([J:J]) = 0 Then Columns("J").ColumnWidth = 1
    If WorksheetFunction.CountA([F:F]) = 0 Then Columns("F").ColumnWidth = 1
    
    Range("A:D").Columns.AutoFit
    Range("K:L").Columns.AutoFit
    
    [A1:L1].Interior.Color = F_Color
    Application.PrintCommunication = False
    Application.ScreenUpdating = True
    With ActiveSheet.PageSetup
        .PrintArea = "A1:L" & LR
        .PrintTitleRows = "R1"
        .LeftMargin = 10:           .RightMargin = 10
        .TopMargin = 10:            .BottomMargin = 10
        .HeaderMargin = 0:          .FooterMargin = 0
        .PrintHeadings = False:     .PrintGridlines = False:  .PrintComments = xlPrintNoComments
        .CenterHorizontally = True: .CenterVertically = False
        .Orientation = xlPortrait:  .PaperSize = xlPaperA4
        .FitToPagesWide = 1:        .FitToPagesTall = False
    End With
    Application.PrintCommunication = True
    If Usf_Mao_Ds.Visible Then Usf_Mao_Ds.Hide
    Print_Preview
    
    Worksheets("Tirages").Activate
    Worksheets("ImpMao").Visible = False
    Usf_Mao_Ds.Show
End Sub

Sub Set_Joueurs(I As Integer, J As Integer, K As Integer)
Dim Text As String
Dim Found As Range

    Text = ""
    For J = J + 2 To J Step -1
        If Val(Cells(I, J)) > 0 Then
            Set Found = [TRI_RESU].Columns(1).Find(Cells(I, J), , xlValues, xlByRows)
            Text = Found.Offset(, 2) & vbLf & Text
'            If Found.Offset(, 3) = "F" Then Stop
            If Found.Offset(, 3) = "F" Then Cells(I, J).Interior.Color = 16764159 ' Femme
        Else
            Cells(I, J).ClearContents
        End If
    Next
'    On Error Resume Next
    Cells(I, K) = Application.WorksheetFunction.Proper(Left(Text, Len(Text) - 1))
    Cells(I, K).BorderAround xlContinuous

End Sub
Sub EnEvents()
    MsgBox "Events=" & Application.EnableEvents
    Application.EnableEvents = True

End Sub

Sub Enlever_Filtre()
    Usf_Mao_Ds.Tbx_Régulier = vbNullString
End Sub
Sub Inscrip_Change(ByVal Target As Range)
Dim Cell As Range
Application.EnableEvents = False
    
    For Each Cell In Target.Cells
        Select Case True
            Case Cell.Address = Worksheets("Inscrip").[Svg_Intvl].Address
                Svg_Stop
                [Svg_Next].ClearContents
                Svg_Start
            Case Not Intersect(Cell, [Zone_Payé]) Is Nothing
                'If Cell <> vbNullString Then
                    nbg = Val(Cell.Offset(, -5))
                    Select Case Cell.Offset(, -5)
                    Case "": Cell = ""
                    Case 0: Cell = Chr(150)
                    Case Else: Cell = Chr(145) & nbg
                    End Select
                    Cell.Characters(Start:=2, Length:=1).Font.Name = "Calibri"
                    Cell.ShrinkToFit = True
                    Cell.HorizontalAlignment = xlGeneral
                    Cell.VerticalAlignment = xlBottom
                    Cell.WrapText = False
                'End If
            Case Not Intersect(Cell, Worksheets("Inscrip").[D2]) Is Nothing _
                And Target.Count = 1 ' Formule de jeu
                VALIDER_formule
            Case Not Intersect(Cell, [A_inscrire_si_1]) Is Nothing
                If [Tirage_Done] = "Ok" Then
                    If MsgBox("Le tirage a été fait" & vbLf & _
                              "Voulez-vous le casser ?", _
                              vbCritical + vbQuestion + vbYesNo) = vbYes Then
                        [Tirage_Done] = ""
                        [Attrib] = False
                    Else
                        Cell = IIf(Cell = Coché, "", Coché)
                        Exit For
                    End If
                End If
                If Cell <> "" And Cell <> Coché Then Cell = Coché

            Case Not Intersect(Cell, [Ordre_Liste]) Is Nothing _
                And Target.Count = 1 ' Formule de jeu
                If Target = vbNullString _
                Then Application.Undo _
                Else Tri_Joueurs_Reguliers
                
            Case Not Intersect(Cell, [Joueurs_en_D5].Columns(1).Cells) Is Nothing
                ' Un joueur en zone D5 a été modifié manuellement
                If Cell = "" Then 'Joueur supprimé
                    If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
                    Cell.Offset(, 1).ClearContents
                   ' Le joueur a été supprimé, on doit remonter tous les suivants
                    If Cell.Offset(1) <> "" Then
                        Cell.Offset(1).Resize(, 2).Copy
                        Cell.PasteSpecial xlPasteValues
                        Cell.PasteSpecial xlPasteComments
                        Application.EnableEvents = True
                        Cell.Offset(1).Resize(, 2).ClearContents
                        Application.EnableEvents = False
                    End If
'                    Set R = [Joueurs_Reguliers].Find(Old_Man, , xlValues, xlWhole)
'                    If Not R Is Nothing Then R.Offset(, -2) = ""
                Else
                    Do While InStr(Cell.Value, "  "): Cell.Value = Replace(Cell.Value, "  ", ""): Loop
                    Cell.Value = Trim(Replace(StrConv(Replace(Cell.Value, "-", "- "), vbProperCase), "- ", "-"))
                    
                    Set R = [Joueurs_en_D5].Find(Cell.Value, , xlValues, xlWhole, xlByColumns, xlNext, False, False)
                    If Not R Is Nothing Then 'le joueur entré est en double
                        If R.Address <> Cell.Address Then
                            MsgBox Cell.Value & vbLf & " est déjà inscrit", vbExclamation + vbOKOnly
                            Cell.ClearContents
                            Exit For
                        End If
                    End If
                    
                    Set R = [JOUEURS_REGULIERS].Columns(1).Find(Cell.Value, , xlValues, xlWhole, xlByColumns, xlNext, False, False)
                    If Not R Is Nothing Then ' le nom entré est un joueur régulier
                        R.Offset(, -2) = Coché
                        Cell.Offset(, 1) = R.Offset(, 1)
                        MsgBox Cell.Value & vbLf & " est un joueur régulier", vbInformation + vbOKOnly
                        If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
                    Else ' joueur externe
                        DEVERROU ' Indispensable pour ajouter un commentaire
                        If Cell.Comment Is Nothing Then Cell.AddComment
                        mobile = InputBox("N° de Mobile ou de Licence :", "Joueur externe " & Cell, Cell.Comment.Text)
                        Cell.Comment.Text IIf(mobile = "", "Externe", mobile)
                        Cell.Comment.Shape.TextFrame.AutoSize = True
                        Cell.Offset(, 1) = "M"
                        VERROU
                    End If
                End If
                L = Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1))
                If [Joueurs_en_D5].SpecialCells(xlCellTypeVisible).Rows.Count = L _
                Then [Joueurs_en_D5].RowHeight = 28.5
                
            Case Not Intersect(Cell, [JOUEURS_REGULIERS]) Is Nothing
                If Target.Count = 1 Then Application.Undo
            Case Not Intersect(Cell, [A_inscrire_si_1]) Is Nothing
                If Target.Count = 1 And Cell.Offset(, 2) = "" Then Application.Undo
        End Select
    Next

Application.EnableEvents = True
End Sub
'Sub AJOUTER_NOM()
'Dim Lig As Integer
'If Trim([D4]) <> vbNullString Then
'    MsgBox [Joueurs_En_d5].Row
'    Lig = [NBJR] + 5 '1ère ligne libre
'    If Lig >= 30 Then AJOUTER_JRS
'
'    Range("D" & Lig) = [D4]
'    Set F = [Joueurs_reguliers].Columns(1).Find([D4], , xlValues)
'    If Not F Is Nothing Then
'        Range("E" & Lig) = F.Offset(0, 1)
'    Else
'        mobile = InputBox("N° de Mobile:")
'        Range("D" & Lig).AddComment mobile
'        Range("D" & Lig).Comment.Shape.TextFrame.AutoSize = True
'        Range("E" & Lig).Select
'        Selection.Value = "M"
'    End If
'    [D4].ClearContents
'    VERROU
'End If
'
'End Sub
'Sub AJOUTER_JRS()
'    [Joueurs_En_d5].RowHeight = 28.5
'End Sub


Sub ATTRIB_NUM()
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim Title As String

    Worksheets("INSCRIP").Activate
    If ActiveSheet.FilterMode Then Enlever_Filtre
    REPORT_DES_NOMS_AVEC_1 ' on force ce report car l'ordre a pu changer entre temps

    Select Case True
    Case Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1)) < 8 '12
        MsgBox "Trop peu de joueurs pour un tirage efficace", vbCritical + vbOKOnly
        Exit Sub
    Case [Attrib]
        If MsgBox("L'affectation des N° est déjà faite !" & vbLf & vbLf & _
                   "(à refaire si un nom a été rajouté)" & vbLf & vbLf & _
                   "Voulez-vous refaire l'attribution ?", vbExclamation + vbYesNo, "Attribution") = vbNo Then
            Exit Sub
        Else
            [Attrib] = False
        End If
    End Select
    
    Title = "VALIDER pour CONTINUER"
    If [Formule] = 2 Then 'cas doublettes maximoises :
        If Range("S3") = 0 Then 'cas doublettes maximoises et trop de Femmes : CAS=0
            If MsgBox(Range("T4") & vbLf & "    OK    ? ", _
                vbQuestion & vbYesNo) <> vbYes Then Exit Sub
        End If
    Else
        If MsgBox("Préparation de la liste des équipes :" & vbLf & _
                  "Voulez-vous donner aux équipes un N° " & vbLf & _
                  "DIFFERENT de celui de l'ORDRE D'INSCRIPTION ?" & vbLf & vbLf & _
                  "Répondre NON si étiquettes déjà distribuées.", vbQuestion + vbYesNo, Title) <> vbYes Then GoTo Listes
    End If
    
    [Tirage_Done].ClearContents
    [Tours_Resultats].ClearContents
    Worksheets("Noter 1 RESULTAT").Cbx_Noms.Clear
            
    [TRI_noms].Sort Key1:=Range("C5"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Listes:
    ' on masque les colonnes C et G
    Columns("C").Hidden = True
    Columns("G").Hidden = True
    [Attrib] = True
    
    '****************** transfert en fixe + tri num puis copie pour TRI alpha
    [Joueurs_en_D5].Copy:                             [AL5].PasteSpecial Paste:=xlPasteValues
    [AK5].Resize([Joueurs_en_D5].Rows.Count, 2).Copy: [AC5].PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    ' Tri des Noms de la liste Alpha
    [AC5].Resize([Joueurs_en_D5].Rows.Count, 2).Sort _
        Key1:=Range("AD5"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
        Key2:=Range("AC5"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
        Header:=xlNo, Orientation:=xlTopToBottom

'   Les numéros étant attribués les "NOMS" sont figés et
'   protégés des fausses manoeuvres (sauf si on déverrouille la feuille)
    With [Joueurs_en_D5]
        .Locked = True
        .FormulaHidden = False
    End With
    
Application.EnableEvents = True
Application.ScreenUpdating = True
Usf_Mao_Ds.Show_Repaint
    
End Sub
Sub DEVERROU(Optional Sh As Worksheet)
    ' ATTENTION l'unprotect fait perdre le contenu du  COPY
    If Sh Is Nothing Then Set Sh = ActiveSheet
        Sh.Unprotect
    Set Sh = Nothing
End Sub
Sub VERROU(Optional Sh As Worksheet)
    If Not [NoLock] Then
        If Sh Is Nothing Then Set Sh = ActiveSheet
            Sh.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, UserInterfaceOnly:=True
        Set Sh = Nothing
    End If
End Sub
Sub Saisir_En_D5(Optional Ajouter As Boolean = True)
    CADRER_INSCRIP
    Select Case True
    Case [NBJR] >= 131: MsgBox "Nombre maximum de joueurs atteint", vbCritical + vbOKOnly
    Case Not Ajouter
    Case Else
        If [Tirage_Done] = "OK" Then _
            If MsgBox("Tirage effectué" & vbLf & _
            "Ajouter un joueur quand même ?", vbCritical + vbOKCancel) = vbCancel Then Exit Sub
            
        With [Joueurs_en_D5].SpecialCells(xlCellTypeBlanks).Cells(1)
            .Rows.Hidden = False
            .Select
        End With
        Usf_Mao_Ds.Cmd_Add_Click
    End Select
End Sub
Function Get_File_Liste() As Boolean
Set Dlg = Application.FileDialog(msoFileDialogFilePicker)
    With Dlg
        .AllowMultiSelect = False
        .Title = "Dossier des Joueurs Habituels"
        .InitialFileName = [Dir_Liste] & "\" & [Nom_Liste] & ".xls"
        .Filters.Clear
        .Filters.Add "Liste(s) des joueurs", "*.xls"
        .Show
        If .SelectedItems.Count > 0 Then
            Z = Dir(.SelectedItems(1))
            [Nom_Liste] = Left(Z, InStrRev(Z, ".") - 1)
            [Dir_Liste] = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), Application.PathSeparator) - 1)
            Get_File_Liste = True
        Else
            Get_File_Liste = False
        End If
    End With
Set Dlg = Nothing

End Function
Sub CADRER_A_INSCRIRE()
    Application.Goto [Zone_Réguliers], True
    [A_inscrire_si_1].Cells(1).Activate
End Sub
Sub GOTO_NOTER()
    If Not [Attrib] Then
        MsgBox "Les numéros n'ont pas été attribués", vbCritical
    Else
        Worksheets("Noter 1 RESULTAT").Activate
    End If
End Sub
Sub VOIR_TABL_N() ' en provenance de "INSCRIP"
    If Not [Attrib] Then
        MsgBox "Les numéros n'ont pas été attribués", vbCritical
        Exit Sub
    End If
    
    If Range("E141") >= 1 And Not [Attrib] Then 'Fem+Z>=1 et TRI déjà fait
        If MsgBox(Title:="VALIDER pour CONTINUER.", _
            Prompt:="Cette étape nécessite d'avoir au préalable cliqué sur 'ATTRIBUER 1 N° à chaque joueur'" & _
            " (par tirage au sort) sinon les N° resteront dans l'ordre des inscriptions" & _
            " et surtout les informations de la colonne 'SEXE' resteront inefficaces !!!  Voulez-vous néanmoins CONTINUER ?" _
            , Buttons:=4) <> 6 Then
            MsgBox "Alors veuillez SVP cliquer sur le bouton '5. ATTRIBUER 1 N° ... " & vbLf & _
                   " puis recommencer votre dernière opération seulement. MERCI."
        Exit Sub
    End If
    
    End If
    
    Application.ScreenUpdating = False
 
    Svg_Run 'sauvegarde forcée par sécurité
        
    [NT] = Worksheets("INSCRIP").Range("L1") 'transfert du NB JRS en NT
    Worksheets("Noter 1 RESULTAT").Cbx_Noms.Clear
    TRANSFERT
    
    If [Formule] <> 2 Then MAJ_BLANCS
    CADRER_TIRAGES

End Sub
Sub Tirage_COL67()
    With Worksheets("TIRAGES") ' pour appel depuis INSCRIP bouton 7 "vers TOUR de JEU"
        .Columns("I:N").ColumnWidth = 0
        .Columns("U:Z").ColumnWidth = 0
        .Columns("AG:AL").ColumnWidth = 0
        .Columns("AS:AX").ColumnWidth = 0
    End With
End Sub
Sub Tirage_COL131()
    With Worksheets("TIRAGES") ' pour appel depuis INSCRIP bouton 7 "vers TOUR de JEU"
        .Columns("I:N").ColumnWidth = 2.71
        .Columns("U:Z").ColumnWidth = 2.71
        .Columns("AG:AL").ColumnWidth = 2.71
        .Columns("AS:AX").ColumnWidth = 2.71
    End With
End Sub
Sub Tmfc()

    DEVERROU ' Nécessaire pour les MFC
    For I = Worksheets("Tirages").Cells.FormatConditions.Count To 1 Step -1
        With Worksheets("Tirages").Cells.FormatConditions(I)
            If .Font.Strikethrough Then Debug.Print .Formula1
        End With
    Next
End Sub

Sub TRANSFERT() '[NT] (de feuille TIRAGES) est supposé alimenté et >=8 sinon nn négatif

Application.ScreenUpdating = False
Worksheets("Tirages").Visible = True
Worksheets("Tirages").Activate

    [TIRAGE_appelé].FormulaR1C1 = ""
    Range("C25") = Range("A22") 'valeur initiale nb Fem mises en relief ?
    
'************* CALCUL ADR du tableau à copier
    Dim nn As Integer, lig_suppl As Integer, taille As Integer, DECAL_30 As Integer
    DECAL_30 = IIf(Worksheets("INSCRIP").Range("S3") = 2, 30, 0) 'décalage de 30 colonnes pour accéder à la variante en F2
 
    If [NT] > 68 And [Formule] = 2 Then Tirage_COL131 Else Tirage_COL67
    Tirage_COL131
    
    If [NT] >= 68 And [Formule] = 2 Then
        lig_suppl = ([NT] - 68) * 16
        taille = 21 + 16
    Else
        lig_suppl = 0
        taille = 21
    End If
    
    nn = 22 * [NT] - 176 + lig_suppl
'************* FIN du CALCUL ADR du tableau à copier

' Comme on va copier toute une plage du fichier des tables,
' les MFC en cours risquent d'être découpées au profit de celles de la plage copiée
' On les détruit

'    DEVERROU ' Nécessaire pour les MFC
'    For I = Worksheets("Tirages").Cells.FormatConditions.Count To 1 Step -1
'        With Worksheets("Tirages").Cells.FormatConditions(I)
'            If .Font.Strikethrough Then .Delete
'        End With
'    Next
        
    '******************ouverture fichier TABLE concernée et copy :
    Set Fso = CreateObject("Scripting.FileSystemObject")
        Do While Not Fso.FolderExists([Dir_Tables])
            Get_Folder_Tables
        Loop
    Set Fso = Nothing
    

    With Workbooks.Open(Filename:=[Dir_Tables] & "\" & [Nom_TABLE], ReadOnly:=True)
        Application.EnableEvents = False
        Worksheets("F2").Range(Cells(1 + nn, 1 + DECAL_30), Cells(taille + nn, 26 + DECAL_30)).Copy
'        ThisWorkbook.Worksheets("Tirages").Range("A27").PasteSpecial xlPasteAll
        ThisWorkbook.Worksheets("Tirages").Range("A27").PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
        .Close SaveChanges:=False
        Application.EnableEvents = True
    End With
        
'supprimer lignes 5 et/ou 6 et/ou 7 inutiles car VIDES
    If Range("E5") = 0 Then Rows(5).RowHeight = 0
    If Range("C6") = 0 Then Rows(6).RowHeight = 0
    If Range("C7") = 0 Then Rows(7).RowHeight = 0
    
' On reconstitue les MFC pour le suivi des parties terminées
    Worksheets("Tirages").Mfc_TIRAGES
'    DEVERROU ' Nécessaire pour les MFC
'    On Error Resume Next
'    Pl = Array("C30", "I30", "O30", "U30")
'    L = [Tour_1].Rows.Count - 2
'    For I = 0 To UBound(Pl)
'        f = "RECHERCHEV(" & Pl(I) & ";TRI_RESU;" & I + 7 & ")"
'        With Range(Pl(I)).Resize(L, 6).FormatConditions.Add(Type:=xlExpression, _
'            Formula1:="=OU(" & f & "=""G"";SI(ESTNUM(" & f & ");" & f & ">0;FAUX))")
'            .Font.Strikethrough = True
'            .Font.Color = vbRed
'            .Interior.Color = 14277081
'            .StopIfTrue = False
'            .SetFirstPriority
'        End With
'        With Range(Pl(I)).Resize(L, 6).FormatConditions.Add(Type:=xlExpression, _
'            Formula1:="=OU(" & f & "=""P"";SI(ESTNUM(" & f & ");" & f & "<0;FAUX))")
'            .Font.Strikethrough = True
'            '.Font.Color = vbRed
'            .Interior.Color = 14277081
'            .StopIfTrue = False
'            .SetFirstPriority
'        End With
'    Next
  
    ' Re-init noter un résultat
    Application.EnableEvents = False
    [N_Joueur] = 1
    [Tour] = 1
    Application.EnableEvents = True
    Is_Tirage_Done
    Range("C1").Select
    Usf_Mao_Ds.Show_Repaint
    
End Sub

Sub Edit_Liste()
Dim NomListe As String
    NomListe = [Nom_Liste].Value & ".xls"

    Set Fso = CreateObject("Scripting.FileSystemObject")
        Do While Not Fso.FileExists([Dir_Liste] & "\" & NomListe)
            Get_File_Liste
        Loop
    Set Fso = Nothing
    
    NomListe = [Nom_Liste].Value & ".xls"
    Msgtext = NomListe & " est ouvert en écriture" & vbLf & vbLf & _
             "Si vous le modifiez," & vbLf & _
             "n'oubliez pas de recharger la liste dans DS Pétanque"
    
    On Error Resume Next
    If Workbooks(NomListe) Is Nothing Then
        Workbooks.Open ([Dir_Liste] & "\" & [Nom_Liste])
    Else
        Workbooks(NomListe).Activate
    End If
    Workbooks(NomListe).Worksheets("Modif").Unprotect
    MsgBox Msgtext, vbInformation + vbOKOnly, "Liste des joueurs Habituels"
        
End Sub
Sub S_APPEL_LISTE()
If MsgBox("Etes-vous sûr(e) de vouloir recharger la liste des habitué(e)s ?", vbCritical + vbYesNo) = vbYes Then
    If WorksheetFunction.CountA([A_inscrire_si_1]) = 0 Then
        APPEL_LISTE
    Else
        APPEL_LISTE MsgBox("Avec préservation des Inscrits ?", vbQuestion + vbYesNo) = vbYes
    End If
End If
End Sub

Sub APPEL_LISTE(Optional Preserver As Boolean = False)
Dim Joueurs_Inscrits
Dim R           As Range
Dim F_Address   As String
Dim Fso         As Object
Application.ScreenUpdating = False

' Intégration de la liste des joueurs

Set Inscrip = ThisWorkbook.Worksheets("Inscrip")
    Enlever_Filtre
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
        Do While Not Fso.FileExists([Dir_Liste] & "\" & [Nom_Liste] & ".xls")
            Get_File_Liste
        Loop
    Set Fso = Nothing
    
    If Preserver Then
        ' sauvegarde des joueurs inscrits
         Set Joueurs_Inscrits = CreateObject("Scripting.Dictionary")
         F_Address = ""
         Set R = [A_inscrire_si_1].Columns(1).Cells([A_inscrire_si_1].Rows.Count)
        ' on cherche les joueurs cochés
         Set R = [A_inscrire_si_1].Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
         Do While Not R Is Nothing
             If F_Address = "" Then F_Address = R.Address
             Joueurs_Inscrits.Add R.Offset(, 4) & " " & R.Offset(, 5), 1
             Set R = [A_inscrire_si_1].FindPrevious(R)
             If R.Address = F_Address Then Set R = Nothing
         Loop
    End If
    
    Application.EnableEvents = False
    [A_inscrire_si_1].FormulaR1C1 = ""
    [JOUEURS_REGULIERS].EntireRow.Hidden = False
    [JOUEURS_REGULIERS].Offset(, 1).ClearContents
 
    Filename = [Dir_Liste] & "\" & [Nom_Liste] & ".xls"
    With Workbooks.Open(Filename:=Filename, ReadOnly:=True)
        [Inscrits[#Data]].Copy
            Inscrip.Range("E147").PasteSpecial Paste:=xlValues
        Application.CutCopyMode = False
        .Close SaveChanges:=False
    End With
    Application.EnableEvents = True
      
    If Preserver Then
        For Each Joueur In Inscrip.Range("F" & 147 & ":G" & [A_inscrire_si_1].Rows.Count).Rows
            If Joueurs_Inscrits.exists(Joueur.Cells(1) & " " & Joueur.Cells(2)) Then Range("B" & Joueur.Row) = "1"
        Next
        Set Joueurs_Inscrits = Nothing
    End If
    
    Tri_Joueurs_Reguliers
    
    [JOUEURS_REGULIERS].Columns(2).SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
    Usf_Mao_Ds.Tbx_Régulier_Change
    Application.Goto Inscrip.[B144], True

Set Inscrip = Nothing

End Sub
Function Get_Folder_Tables() As Boolean
Dim Fd As FileDialog
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
    With Fd
        .AllowMultiSelect = False
        .Title = "Dossier des Tables de Tirages"
        .InitialFileName = [Dir_Tables].Value & IIf(Right([Dir_Tables], 1) = "\", "", "\")
        .Show
        If .SelectedItems.Count > 0 Then
            Application.EnableEvents = False
            [Dir_Tables].Value = .SelectedItems(1)
            Application.EnableEvents = True
            Get_Folder_Tables = True
        Else
            Get_Folder_Tables = False
        End If
    End With
Set Fd = Nothing
End Function

Function Get_Folder_Svg() As Boolean
Dim Fd As FileDialog
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
    With Fd
        .AllowMultiSelect = False
        .Title = "Dossier des Sauvegardes [ RESULTATS ]"
        .InitialFileName = [Svg_Dir].Value & IIf(Right([Svg_Dir], 1) = "\", "", "\")
        .Show
        If .SelectedItems.Count > 0 Then
            Application.EnableEvents = False
            [Svg_Dir].Value = .SelectedItems(1)
            Application.EnableEvents = True
            Get_Folder_Svg = True
        Else
            Get_Folder_Svg = False
        End If
    End With
Set Fd = Nothing
End Function
Sub RAZ_Joueurs_Réguliers_Inscrits()
    [A_inscrire_si_1].ClearContents
End Sub
Sub RAZ(Optional SansConfirmer = vbNo)
    
    If SansConfirmer = vbNo Then _
        SansConfirmer = MsgBox("Voulez-vous lancer" & vbLf & "l'effacement de la liste", _
               vbYesNo + vbQuestion, _
               "VALIDER pour CONTINUER")
              
    If SansConfirmer = vbYes Then
    
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        
            [E1].FormulaR1C1 = "=TODAY()" 'initialiser avec date=AUJOURDHUI
            [AL5:AL135].FormulaR1C1 = "=IF(RC[-34]="""","""",RC[-34])"
            [AC5:AD135].ClearContents
            [RAZ_LISTE].ClearContents
            [NT] = vbNullString
            [TIRAGE_appelé].ClearContents
            [R23].ClearContents
            
            For Each Cell In [Joueurs_en_D5].Cells
                If Not Cell.Comment Is Nothing Then Cell.Comment.Delete
            Next
          
           ' on peut saisir directement (jusqu'à atrribution des N°) en D5 à E135, même si la feuille est verrouillée.
            [Zone_Payé].Locked = False
            [D5:E135].Locked = False
            [D5:E135].FormulaHidden = False
                          
            APPEL_LISTE ' On recharge la liste des joueurs habitués
            REDUIRE
            
            Enlever_Filtre
            [Attrib] = False
                  
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Usf_Mao_Ds.Show_Repaint
    End If
    
'    MsgBox "CONSIGNES DE SAISIE :" & _
'           "  Cliquer au besoin sur le bouton (changer)'ordre LISTE' situé en D3 pour pouvoir, ensuite, CHOISIR (en cliquant sur la flèche en " & _
'    "D4/E4) soit dans une liste NOM-Prénom soit dans une liste Prénom-NOM," & _
'    " MAIS on peut aussi, pour les joueurs occasionnels, TAPER DIRECTEMENT un nom-prénom en D4.   Dans les 2 cas, il faut " & _
'    " toujours terminer par CLIQUER sur le bouton 'Ajouter' et, ensuite, saisir le sexe=F en col.E  si 'Féminin' ou assimilé."

End Sub
Sub Tri_Joueurs_Reguliers()
Dim Plage As Range
    Set Plage = Worksheets("Inscrip").Range([A_inscrire_si_1], [JOUEURS_REGULIERS])
    If [Ordre_Liste] Like "P*" Then ' tri par Prénom
        Plage.Sort _
            Key1:=[JOUEURS_REGULIERS].Cells(4), Order1:=xlAscending, _
            Key2:=[JOUEURS_REGULIERS].Cells(3), Order1:=xlAscending, _
            Key3:=[JOUEURS_REGULIERS].Cells(5), Order1:=xlAscending, _
            Header:=xlNo
    Else
        Plage.Sort _
            Key1:=[JOUEURS_REGULIERS].Cells(3), Order1:=xlAscending, _
            Key2:=[JOUEURS_REGULIERS].Cells(4), Order1:=xlAscending, _
            Key3:=[JOUEURS_REGULIERS].Cells(5), Order1:=xlAscending, _
            Header:=xlNo
    End If
End Sub
Sub IMPRIM_LISTE_2col()
    Application.Goto Reference:="LISTE_2cols"
    Z = [LISTE_2cols].Offset(2).Columns(2).Resize(, 6).Address
    ActiveSheet.PageSetup.PrintArea = Z
    Print_Preview
    [A_inscrire_si_1].Cells(1).Select
End Sub

Sub CADRER_INSCRIP()
Application.EnableEvents = False
    Worksheets("INSCRIP").Select
    REDUIRE 'les lignes inutilisées
    
    Columns("C").Hidden = True
    Columns("G").Hidden = True
    Columns("A:R").Select: ActiveWindow.Zoom = True
    
    [Joueurs_en_D5].Cells(1).Select

Application.EnableEvents = True
End Sub
Sub CADRER_NOTER()
    Worksheets("NOTER 1 RESULTAT").Activate
    [A1].Select
    Application.Goto Reference:="CADRE_NOTER", Scroll:=True
    ActiveWindow.Zoom = True
    VERROU
    [E9].Select
    Usf_Mao_Ds.Show_Repaint
    Suivi_Tour
End Sub
Sub Set_Score()
    Worksheets("Noter 1 RESULTAT").Activate
    For Each Sh In ActiveSheet.Shapes
        If Sh.Name Like "Score_*" Then Sh.Delete
    Next
    H = 12
    W = 12
    Wmax = W * 14
    X = ([Resultat].Left + [Resultat].MergeArea.Width) - Wmax
    Y = [Resultat].Top - H
    For I = 0 To 13
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
        With shp
            .Name = "Score_P_" & I
            .Line.Weight = 0.25
            With .OLEFormat.Object
                .Interior.Color = 4697456
                .Font.Color = vbWhite
                .Font.Size = 6
                .Font.Bold = True
            End With
            With .TextFrame2
                .VerticalAnchor = msoAnchorMiddle
                .TextRange.Characters.Text = IIf(I = 0, "G", Format(I, "+##;-##"))
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .MarginLeft = 0
                .MarginTop = 0
                .MarginRight = 0
                .MarginBottom = 0
            End With
            .OnAction = "Click_Score"
        End With
        X = X + W
    Next
    X = ([Resultat].Left + [Resultat].MergeArea.Width) - Wmax
    Y = [Resultat].Top + [Resultat].Height
    For I = 14 To 1 Step -1
        Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
        With shp
            .Name = "Score_N_" & I
            .Line.Weight = 0.25
            With .OLEFormat.Object
                .Interior.Color = vbRed
                .Font.Color = vbWhite
                .Font.Size = 6
                .Font.Bold = True
            End With
            With .TextFrame2
                .VerticalAnchor = msoAnchorMiddle
                .TextRange.Characters.Text = IIf(I = 14, "P", Format(-I, "+##;-##"))
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .MarginLeft = 0
                .MarginTop = 0
                .MarginRight = 0
                .MarginBottom = 0
            End With
            .OnAction = "Click_Score"
        End With
        X = X + W
    Next

End Sub
Sub showactive()
    Debug.Print Selection.Interior.Color
End Sub
Sub Set_Btn(X, Y, W, H, V)
Dim C As Long
Static Id: Id = IIf(Id > 999, 1, Id + 1)
    
    With ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, X, Y, W, H)
        .Name = "Joueur_" & Id
        .Line.Weight = 0.25
        Select Case True
            Case V Like "tour*":                            C = 2316088  ' vert foncé
            Case Not IsNumeric(V):                          C = 5287936  ' Vert Pastel
            Case V = Val(ActiveSheet.Cbx_Numéros):          C = 8696052
            Case Not V.DisplayFormat.Font.Strikethrough:    C = 10855845 ' Gris
            Case V.DisplayFormat.Interior.Color = vbRed:    C = vbRed
            Case Else:                                      C = 3506772 ' vert foncé
        End Select
        .Fill.ForeColor.RGB = C
        With .TextFrame2
            .VerticalAnchor = msoAnchorMiddle
            .TextRange.Characters.Text = V
            .TextRange.ParagraphFormat.Alignment = msoAlignCenter
            .TextRange.Font.Size = 10
            .TextRange.Font.Bold = True
            .MarginLeft = 0
            .MarginTop = 0
            .MarginRight = 0
            .MarginBottom = 0
        End With
        .OnAction = "Click_Result"
    End With
    X = X + W

End Sub
Public Function IsRegistered() As Boolean
    IsRegistered = [Supprimer].Visible
End Function
Public Function IsWin() As Boolean
    Select Case True
        Case [Resultat] = "G": IsWin = True
        Case [Resultat] > 0: IsWin = True
    End Select
End Function

Sub Suivi_Tour()
Dim Nrows As Long, N As Long, NP As Long

If [Tirage_Done] = "OK" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Set Rt = Worksheets("Tirages").Range("Tour_" & [Tour])
    With Rt
        .Parent.Activate
        .EntireRow.Hidden = False
        .EntireColumn.Hidden = False
        NP = WorksheetFunction.CountIf(.Columns(1), ">0") ' Nombre de Parties en tout pour le tour
        N = 0
        Nrows = 3
        For I = 2 To .Rows.Count
            If .Cells(I, 1).Value > 0 Then
                If .Cells(I, 1).DisplayFormat.Font.Strikethrough Then N = N + 1
                Nrows = Nrows + 1
            End If
            If WorksheetFunction.CountA(.Rows(I)) = 0 Then Exit For
        Next
    End With

    With Worksheets("Noter 1 RESULTAT")
        .Activate
        DEVERROU
        On Error Resume Next
            For Each Ctl In .Shapes
                If Ctl.Name Like "*Joueur*" Then Ctl.Delete
            Next
        On Error GoTo Error_Trap
        Dim BL, BT, BH, BW, R
        BT = .[J3].Top
        BH = 15
        BW = 15
        Id = 1
        For R = 1 To Nrows
            BL = .[J3].Left
            Select Case True
            Case R = 1 ' Titre
                Set_Btn BL, BT, (BW * 6) + 2, BH, Rt.Cells(1, 1)
                BT = BT + 2
            Case R = 2 ' Blanc
                If Rt.Cells(R, 3) <> "" Then
                    Set_Btn BL, BT, BW * 2, BH, Rt.Cells(R, 1)
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 3)
                Else
                    BT = BT - BH
                End If
            Case R = 3 ' Tête à tête
                If Rt.Cells(R, 1) <> "" Then
                    Set_Btn BL, BT, BW * 2, BH, "TaT :"
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
                    Set_Btn BL + 2, BT, BW, BH, Rt.Cells(R, 4)
                 Else
                    BT = BT - BH
                End If
            Case R = 4 ' Doublette sup
                If Rt.Cells(R, 1) <> "" Then
                    BL = BL + BW
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 2)
                    BL = BL + 2
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 4)
                    Set_Btn BL, BT, BW, BH, Rt.Cells(R, 5)
                 Else
                    BT = BT - BH
                End If
                BT = BT + 2
            Case Worksheets("Tirages").[AM2] Like "*tête*"
                BL = .[J3].Left + BW * 2
                Set_Btn BL, BT, BW, BH, Rt.Cells(R, 1)
                Set_Btn BL + 2, BT, BW, BH, Rt.Cells(R, 4)
            Case Else
                For C = 1 To 6
                    If Rt.Cells(R, C) <> "" Then
                        Set_Btn BL, BT, BW, BH, Rt.Cells(R, C)
                    Else
                        BL = BL + BW
                    End If
                    If C = 3 Then BL = BL + 2
                Next
            End Select
            BT = BT + BH
        Next
        
        .[J2] = "Parties restantes : " & NP - N
        If N = NP Then
            Application.EnableEvents = True
            If [Tour] < 4 Then
                If MsgBox("Le tour " & [Tour] & " est terminé" & vbLf & vbLf & _
                            "Oui = passer au tour suivant" & vbLf & _
                            "Non = rester sur le tour", vbQuestion + vbYesNo) = vbYes _
                Then [Tour] = [Tour] + 1
            Else
                If MsgBox("Le concours est terminé" & vbLf & _
                    "Voulez-vous  procéder au paiement ?", vbInformation + vbYesNo) = vbYes Then _
                    Worksheets("Inscrip").Activate
            End If
        End If
    End With
    Application.EnableEvents = True
    '[N_joueur].Activate
End If
Exit Sub
Error_Trap:
    MsgBox Err.Number & vbLf & Err.Description
    Resume Next
    
End Sub
Sub Click_Score()
    V = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Caption
  '  If IsNumeric(V) Then [Resultat] = V
    [Resultat] = V
End Sub
Sub Click_Result()
    V = ActiveSheet.Shapes(Application.Caller).OLEFormat.Object.Caption
    If IsNumeric(V) Then
        ActiveSheet.Cbx_Numéros = Val(V)
    End If
    [Tour].Activate
End Sub

Sub REDUIRE() 'les lignes inutilisées ou MONTRER les lignes utilisées >=30
Dim Lig As Integer
    If [NBJR] < [Joueurs_en_D5].Rows.Count Then
        Lig = Application.Max(28, [Joueurs_en_D5].Rows([Joueurs_en_D5].Rows.Count).End(xlUp).Row + 1)
        With Worksheets("INSCRIP").Rows(Lig & ":" & "135")
            If .RowHeight > 0 Then .RowHeight = 0
        End With
        VERROU
    End If
End Sub

Sub PAIEMENTS()
    Dim Largeur 'actuelle
    Cells(2, 19) = IIf(Cells(2, 19) = 0, 5.29, 0)
    Range("M:O").ColumnWidth = Cells(2, 19)
    
    CADRER_INSCRIP
End Sub
Sub REPORT_DES_NOMS_AVEC_1()
Dim J As Integer
    Worksheets("Inscrip").Activate
    Enlever_Filtre
    Application.EnableEvents = False
    
    [Joueurs_en_D5].RowHeight = 28.5
    [Joueurs_en_D5].Offset(, -1).Resize(, 1).FormulaR1C1 = "=IF(RC[-1]="""",3,IF(RC[2]=""F"",0,IF(RC[2]=""Z"",2,1))+RAND())"
    [Joueurs_en_D5].Offset(, -2).Resize(, 1).FormulaR1C1 = "=IF(RC4="""","""",ROW()-ROW(R4C4))"
      
  ' On supprime toutes les lignes de joueurs_en_d5 qui n'ont pas de commentaires
    For Each Cell In [Joueurs_en_D5]
        If Cell.Comment Is Nothing And Cell <> vbNullString Then
            Cell.Resize(, 2).ClearContents
        End If
    Next
    
    N = Application.WorksheetFunction.CountA([Joueurs_en_D5].Columns(1)) _
      + Application.WorksheetFunction.CountA([Joueurs_liste].Columns(1))
    If N > [MAX_JR] Then
        MsgBox "Trop de joueurs" & vbLf & _
                N & " Inscrits" & vbLf & _
                "pour " & [MAX_JR] & " autorisés", vbCritical + vbOKOnly
    Else
        Nl = 0
        'Debug.Print Application.WorksheetFunction.CountA([Joueurs_liste].Columns(1))
        ' on démarre la recherche à partir de la derniere cellule de la plage
         F_Address = ""
         Set R = [Joueurs_liste].Columns(1).Cells([Joueurs_liste].Rows.Count)
         Set R = [Joueurs_liste].Columns(1).Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
         Do While Not R Is Nothing
             If F_Address = "" Then F_Address = R.Address
              Nl = Nl + 1
             ' If Nl = 54 Then Stop
             ' Debug.Print Nl, " On cherche " & R.Offset(0, 2);
             Set s = [Joueurs_en_D5].Find(R.Offset(0, 2))
             If s Is Nothing Then
                 J = ([Joueurs_en_D5].Find(vbNullString, Range("D135")).Row - [Joueurs_en_D5].Row) + 1
                 [Joueurs_en_D5].Cells(J) = StrConv(R.Offset(0, 2), vbProperCase)
                 [Joueurs_en_D5].Cells(J).Offset(0, 1) = R.Offset(0, 3)
             Else
                 Debug.Print " Not found"
             End If
             'R.Activate
             Set R = [Joueurs_liste].Columns(1).Find(Coché, R, xlValues, xlWhole, xlByColumns, xlPrevious)
             If R.Address = F_Address Then Set R = Nothing
         Loop
    End If
    
    [TRI_noms].Sort _
        Key1:=Range("E5"), Order1:=xlAscending, _
        Key2:=Range("D5"), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        
    Usf_Mao_Ds.Show_Repaint
        
Application.EnableEvents = True
Application.Goto [A1], True
CADRER_INSCRIP

End Sub
Sub ShowTip(ByVal Caption As String, B As Object, ByVal X As Single, ByVal Y As Single)
'On Error Resume Next
Dim TT As TextBox
Set TT = ActiveSheet.Shapes("TipText").OLEFormat.Object
    
    With TT
        Select Case True
        Case Not B.Enabled: .Visible = False
        Case (X > 2 And X < B.Width - 4) And (Y > 2 And Y < B.Height - 4)
            If .Visible = False Then
                .Caption = Caption
                .Interior.Color = 13434879
                .Left = B.Left + 1
                .Top = B.Top - .Height - 1
                .AutoSize = True
                .Visible = True
           End If
        Case Else
            .Visible = False
        End Select
    End With
    
    DoEvents

End Sub
Sub IMPRIMER_LISTE_joueurs() 'LISTE forme ALPHA + forme NUMERIQUE
Dim L As Range
Sheets("Inscrip").Activate
    If Not [Attrib] Then
        MsgBox "L'attribution des N° n'ayant pas été faite," & vbLf _
             & "Une liste simple des Joueurs Inscrits va être éditée", _
               vbCritical, "Important"
        IMPRIMER_LISTE_joueurs_Seuls
    Else
        Set L = [Joueurs_en_D5].Columns(1).Find("*", SearchDirection:=xlPrevious)
        REDUIRE ' hauteur =0 si ligne vide
        With ActiveSheet.PageSetup '=standard DS
            .CenterHorizontally = True
            .CenterVertically = False
            .Orientation = xlPortrait
            .Zoom = False
            .LeftMargin = Application.InchesToPoints(0.196850393700787)
            .RightMargin = Application.InchesToPoints(0.196850393700787)
            .TopMargin = Application.InchesToPoints(0.196850393700787)
            .FitToPagesWide = 1
            .PrintArea = "$AC$3:$AL$" & L.Row
        End With
        Print_Preview
    End If
    
    Range("A1").Select
End Sub
Sub IMPRIMER_LISTE_joueurs_Seuls() 'LISTE forme ALPHA
Dim L As Range, Simple As Boolean
    With Sheets("Inscrip")
        Set L = [Joueurs_en_D5].Find("*", SearchDirection:=xlPrevious)
        Set Plage = [Joueurs_en_D5].Rows("1:" & L.Row - [Joueurs_en_D5].Row + 1)
        N1 = WorksheetFunction.RoundUp(Plage.Rows.Count / 2, 0)
        Worksheets("Temp").Visible = True
        Worksheets("Temp").Select
        Cells.Delete
        Cells.Font.Size = 14
        Cells.Font.Name = "Calibri"
        [A1] = "Nom Prénom"
        With [A2].Resize(N1)
            .Value = Plage.Resize(N1).Value
            With .Parent.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes)
                .Name = "Tableau1"
                .TableStyle = "TableStyleMedium6"
            End With
            .Columns.AutoFit
        End With
        N2 = Plage.Rows.Count - N1
        [C1] = "Nom Prénom"
        With [C2].Resize(N2)
            .Value = Plage.Offset(N1).Resize(N2).Value
            With .Parent.ListObjects.Add(xlSrcRange, .CurrentRegion, , xlYes)
                .Name = "Tableau2"
                .TableStyle = "TableStyleMedium6"
            End With
            .Columns.AutoFit
        End With
        Rows(1).RowHeight = Rows(1).RowHeight * 2
        Columns("B").ColumnWidth = 5
        H = Application.Max(Columns("A").ColumnWidth, Columns("C").ColumnWidth)
        Columns("A").ColumnWidth = H
        Columns("C").ColumnWidth = H
    
        With ActiveSheet.PageSetup
            .CenterHorizontally = True
            .CenterVertically = False
            .Orientation = xlPortrait
            .Zoom = False
            .LeftMargin = Application.InchesToPoints(0.196850393700787)
            .RightMargin = Application.InchesToPoints(0.196850393700787)
            .TopMargin = Application.InchesToPoints(0.196850393700787)
            .LeftFooter = "&""Calibri,Gras italique""&12 " & Plage.Rows.Count & " joueurs"
            .PrintArea = [A:C].Resize(WorksheetFunction.Max(N1, 12) + 1).Address
        End With
        Print_Preview
        Worksheets("Temp").Visible = False
    End With
End Sub

 

[fanch55]

pour te mettre l'eau à la bouche
ça ça s'appelle le scroll
Regarde la pièce jointe 1197107

En attendant, J'ai déjà intégré la solution de gitHub

VBA-UserForm-MouseScroll/src at master · cristianbuse/VBA-UserForm-MouseScroll

Use the Mouse Scroll Wheel to scroll VBA UserForms and Controls - cristianbuse/VBA-UserForm-MouseScroll

github.com

 

[patricktoulon]

c'est le do/loop en one line qui n’était pas fermé
je regarderais mais je l'ai intégré avec ma fonction perso roultambour elle presque 15 ans celle là

l'erreur vient de là
je testais avec les balises sur le tbl2 qui ne contient que le code pur (sans commentaire)
il faut enlever la fermeture de balise (ce qui est en vert )
If Tbl2(i) Like "*: loop*</p>" Then TbL(i) = TbL(i) & "</DIV>"
et il y a aussi celle ci
If Tbl2(i) Like "*: Wend*</p>" Then TbL(i) = TbL(i) & "</DIV>"

 

[patricktoulon]

re
c'est bien ce que je pensais c'est une véritable usine a gaz le truc
et pour la combo et le textbox ça marche pas si bien que ça
la sortie n'est pas détectée

 

[fanch55]

Je like, je like ....

Super, je vais attendre la version 3 .

Monsieur plus : un textbox pour faire une recherche dans textbox2 ....

 

[fanch55]

re
c'est bien ce que je pensais c'est une véritable usine a gaz le truc
et pour la combo et le textbox ça marche pas si bien que ça
la sortie n'est pas détectée

C'est vrai , si on ne reclique pas sur le textbox avant d'actionner la molette, on perd l'index du textbox si on sort de celui-ci et qu'on y revient.
Je n'ai pas trouvé ton rouletambour dans les ressources ...

 

[fanch55]

J'ai essayé d'intégrer le rouletambour trouvé dans

Microsoft 365 - Molette souris dans TextBox et ComboBox

Bonjour le Forum, Le sujet a déjà sans doute été évoqué mais j'y reviens tout de même... Y-a-t-il un moyen de pouvoir utiliser la molette de la souris dans une combobox et une TextBox ? J'ai trouvé plusieurs codes mais soit ça marche pour l'un et pas pour l'autre, soit cela fait beuguer mon...

excel-downloads.com

Mais il ne semble pas pouvoir fonctionner correctement en 64bits, il me fait planter violemment excel .

 

[patricktoulon]

non tu la trouve dans des vielles discussion celle là c'est un truc compliqué


a tu corrigé les deux erreur toute bêtes ,comme je te l'ai expliqué?

alors comment j'ai fait pour le scroll
au départ
1° je met mes deux textbox dans une frame
2°dans mes boutons (partout a chaque fois q"un menu doit apparaitre je le met ".Zorder 0"
par ce que comme la frame contenant les deux textbox est nouvelle elle passe par dessus

3°ensuite puisque tu veux automatique je lâche le keydown sur touche CTRL pour le mouse move sur les deux textboxs
4°quand je load un module je met le scrollheight de la frame au nombre de ligne *15(ya un peu de marge)
quand j'indente forcement aussi
le reste pour la sortie on reprend ma fonction magique du calendar (voir aussi infobulle)
et par pitié sans do/loop(petite dédicace à dudu )
comme on a le levelmouse qui tourne en boucle en addressof
ben on fait le test dedans c'est tout
terminé
le code du scroll a tester dans un userform vierge

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'*******************************************
'muti hook mouse simplifié (molete souris sur frame)
'défilement dans controls liste frame
'author:patricktoulon

'Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

#End If

Private Type POINTAPI: X As Long: Y As Long: End Type
Private Type MSLLHOOKSTRUCT: pt As POINTAPI: mouseData As Long: flags As Long: time As Long: dwExtraInfo As Long: End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private udtlParamStuct As MSLLHOOKSTRUCT
Public plHooking As Long         ' permet de savoir si le hook est activé ou pas
Public CtrlHooked As Object         ' sera associé à la ListBox

Public pos As POINTAPI
Public EpC As Variant


'**********************************
'à mettre dans la frame ou le control qui est sensé le déclencher
'ce peut être un control à l'interieur de la frame
'Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************

Sub rouletambour(obj)
    'si ca n'a pas démarrer on demarre  le hook
    If Not CtrlHooked Is Nothing Then If CtrlHooked.Name <> obj.Name Then UnHookMouse
    Call HookMouse(obj)
End Sub
'
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next    'en cas de mouvement très rapide,'évitons les crash en désactivant les erreurs
    Dim Criter
    GetCursorPos pos
    Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)    'recupère les coordonnée en pixel (left/top/right/bottom du control)
    If Not Criter Then UnHookMouse  'quand on est plus dans le périmètre du control bye bye !!
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
            End With
        End If
        Exit Function
    End If
    LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
    If plHooking < 1 Then    ' active le hook s'il n'avait pas déjà été activé
        EpC = EmplacementControl(ControlToScroll)    'on choppe le rectangle du control par raport à l'ecran(pas du parent!!!!) du control dans un array
        Set CtrlHooked = ControlToScroll
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    End If
End Sub
Public Sub UnHookMouse()
    ' désactive le hook s'il existe
    If plHooking <> 0 Then UnhookWindowsHookEx plHooking: plHooking = 0: Set CtrlHooked = Nothing
End Sub
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, K As Double, PPx, A, z
        Lft = obj.Left: Ltop = obj.Top: Set P = obj.Parent    ' Normalement Page, Frame ou UserForm
        PPx = 0.75    'utilisez ici la méthode pour choper votre coeff point/pixel
        Do
            PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight        ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf P Is MSForms.Page Then Set P = P.Parent        ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): Ltop = (Ltop + P.Top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
            Set P = P.Parent
        Loop
        EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height) / PPx)

    End If
End Function