patricktoulon
XLDnaute Barbatruc
je vais vérifier la fx au cas ou je la change en attendant la validation de la modé pour la 3.0
edit c'est fait c'est changer 2.0 Fx bis
edit c'est fait c'est changer 2.0 Fx bis
Complément (Vba Indenter Interface) V3.1.C Fx4
- Initiateur de la discussion patricktoulon
- Date de début
fanch55
XLDnaute Barbatruc
Tests avec le classeur renvoyé
Bizarre, certains #IF ont des indentations qui augmentent ....
patricktoulon
XLDnaute Barbatruc
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
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
XLDnaute Barbatruc
patricktoulon
XLDnaute Barbatruc
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
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
XLDnaute Barbatruc
pour te mettre l'eau à la bouche
ça ça s'appelle le scroll
ça ça s'appelle le scroll
fanch55
XLDnaute Barbatruc
VB:
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 Subfanch55
XLDnaute Barbatruc
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
XLDnaute Barbatruc
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>"
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
XLDnaute Barbatruc
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 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
XLDnaute Barbatruc
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
XLDnaute Barbatruc
J'ai essayé d'intégrer le rouletambour trouvé dans
excel-downloads.com
Mais il ne semble pas pouvoir fonctionner correctement en 64bits, il me fait planter violemment excel .
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
patricktoulon
XLDnaute Barbatruc
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
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
VB:
'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
'*******************************************
'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 FunctionDiscussions similaires
