Option Explicit

Public Const Valeur_Idtrk As Integer = 2000
Public Const Nb_Feuille As Integer = 6
Public Const Rayon As Integer = 6415

Public Nom_Rando As String
Public Dossier As String
Public Distance As Single
Public Dnivell As Integer
Public Premier As Boolean
Public Rep_Base As String
Private Sub Cration_des_Feuilles()

    Dim i As Integer
    Dim j As Integer
    Dim Nom() As String
    Dim Nb As Integer
    Dim Trouver As Boolean
    
    ReDim Nom(Nb_Feuille)
    Nom(1) = "Liste_des_Randos"
    Nom(2) = "Dossier"
    Nom(3) = "Rando"
    Nom(4) = "Trac_1"
    Nom(5) = "Trac_2"
    Nom(6) = "Temp"
    
    For i = 1 To Nb_Feuille
        Trouver = False
        For j = 1 To Sheets.Count
            If Sheets(j).Name = Nom(i) Then
                Trouver = True
                j = Sheets.Count
            End If
        Next j
        
        If Not Trouver Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets(Sheets.Count).Name).Name = Nom(i)
            
        Else
            Sheets(Nom(i)).Select
            Cells.Select
            Selection.Clear
            Range("A1").Select
        End If
    Next i
    
    Sheets("Liste_des_Randos").Select
    Cells(1, 1).Value = " Dossier "
    Cells(1, 2).Value = " Nom de la Rando "
    Cells(1, 3).Value = " Distance en km "
    Cells(1, 4).Value = " Dnivell en m "
    Columns("C:C").Select
    Selection.NumberFormat = "0.000"
    Range("A1").Select

    Columns("C:D").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Columns("A:B").Select
    With Selection
        .HorizontalAlignment = xlRight
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Sheets("Liste_des_Randos").Select

    On Error Resume Next
    With ActiveWorkbook.Sheets("Liste_des_Randos").Tab
        .Color = 15773696
        .TintAndShade = 0
    End With
    Sheets("Menu_Gnral").Select
    With ActiveWorkbook.Sheets("Menu_Gnral").Tab
        .Color = 5287936
        .TintAndShade = 0
    End With

    On Error GoTo 0
    Sheets("Menu_Gnral").Select
    Range("A1").Select
End Sub
Private Sub Rcupration_des_Dossiers()

    Sheets("Dossier").Select
    Cells.Select
    Selection.Clear

    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DSN=MS Access Database;DBQ=" & Rep_Base & ";DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;")), _
        Destination:=Range("A1"))
        .CommandText = Array( _
        "SELECT DOSSIER.IDDOS, DOSSIER.NOM" & Chr(13) & "" & Chr(10) & "FROM `" & Rep_Base & "`.DOSSIER DOSSIER" & Chr(13) & "" & Chr(10) & "ORDER BY DOSSIER.IDDOS" _
        )
        .Name = "Lancer la requte  partir de MS Access Database"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A1").Select

End Sub
Private Sub Rcupration_des_Randonnes()

    Sheets("Rando").Select
    Cells.Select
    Selection.Clear

    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DSN=MS Access Database;DBQ=" & Rep_Base & ";DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;")), _
        Destination:=Range("A1"))
        .CommandText = Array( _
        "SELECT TRACE.IDTRK, TRACE.IDDOS, TRACE.IDENT" & Chr(13) & "" & Chr(10) & "FROM `" & Rep_Base & "`.TRACE TRACE" & Chr(13) & "" & Chr(10) & "ORDER BY TRACE.IDTRK" _
        )
        .Name = "Lancer la requte  partir de MS Access Database"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A1").Select

End Sub
Private Sub Rcupration_Tracs_des_Randonnes()

    Sheets("Trac_1").Select
    Cells.Select
    Selection.Clear

    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DSN=MS Access Database;DBQ=" & Rep_Base & ";DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;")), _
        Destination:=Range("A1"))
        .CommandText = Array( _
        "SELECT PT_TRK.IDTRK, PT_TRK.ORDRE, PT_TRK.LAT, PT_TRK.LON, PT_TRK.ALT" & Chr(13) & "" & Chr(10) & "FROM `" & Rep_Base & "`.PT_TRK PT_TRK" & Chr(13) & "" & Chr(10) & "WHERE (PT_TRK.IDTRK<" & Valeur_Idtrk & ")" & Chr(13) & "" & Chr(10) & "ORDER BY PT_TRK.IDTRK, PT_TRK" _
        , ".ORDRE")
        .Name = "Lancer la requte  partir de MS Access Database"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A1").Select
    
    Sheets("Trac_2").Select
    Cells.Select
    Selection.Clear

    With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
        "ODBC;DSN=MS Access Database;DBQ=" & Rep_Base & ";DriverId=25;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;")), _
        Destination:=Range("A1"))
        .CommandText = Array( _
        "SELECT PT_TRK.IDTRK, PT_TRK.ORDRE, PT_TRK.LAT, PT_TRK.LON, PT_TRK.ALT" & Chr(13) & "" & Chr(10) & "FROM `" & Rep_Base & "`.PT_TRK PT_TRK" & Chr(13) & "" & Chr(10) & "WHERE (PT_TRK.IDTRK>" & Valeur_Idtrk & ")" & Chr(13) & "" & Chr(10) & "ORDER BY PT_TRK.IDTRK, PT_TRK" _
        , ".ORDRE")
        .Name = "Lancer la requte  partir de MS Access Database"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A1").Select

End Sub
Private Function Recherche_Dossier(Num As Integer) As String
    
    Sheets("Dossier").Select
    
    Cells.Find(What:=Num, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    ).Activate
    
    Recherche_Dossier = Cells(ActiveCell.Row, 2).Value

End Function
Private Sub Recherche_Trace_Rando(Num_Rando)

    Dim i As Integer
    Dim Lg_Deb As Long
    Dim Lg_Fin As Long
    Dim Der_Lg As Long
    Dim Feuille As String
    

    If Num_Rando < 2000 Then
        Feuille = "Trac_1"
    Else
        Feuille = "Trac_2"
    End If
    Sheets(Feuille).Select
   
    Der_Lg = Range("A1").End(xlDown).Row
    
    Columns("A:A").Select
    Selection.Find(What:=Num_Rando, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        ).Activate
    
    
    Lg_Deb = ActiveCell.Row
    
    i = 0
    While Cells(Lg_Deb + i, 1) = Num_Rando And Lg_Deb + i <= Der_Lg
        Cells(Lg_Deb + i, 1).Select
        i = i + 1
    Wend
    Lg_Fin = ActiveCell.Row
    
    
    Sheets("Temp").Select
    Cells.Select
    Selection.Clear

    Sheets(Feuille).Select
    Range("A" & Lg_Deb & ":E" & Lg_Fin).Select
    Selection.Copy
    
    Sheets("Temp").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select

End Sub
Private Function Calcul_Dnivell()
    
    Dim Der_Lg As Integer
    Dim Der_Col As Integer
    
    Sheets("Temp").Select
    Der_Lg = Range("A1").End(xlDown).Row
    Der_Col = Range("A" & Der_Lg).End(xlToRight).Column
    
    Cells(2, Der_Col + 1).Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]-R[-1]C[-1]>0,RC[-1]-R[-1]C[-1],0)"

    Cells(2, Der_Col + 1).Select
    Selection.Copy
    Range(Cells(2, Der_Col + 1), Cells(Der_Lg, Der_Col + 1)).Select
    ActiveSheet.Paste

    Cells(Der_Lg + 1, Der_Col + 1).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-" & Der_Lg & "]C:R[-1]C)"

    Calcul_Dnivell = ActiveCell.Value
    
End Function
Private Function Calcul_Distance()

    Dim a As Long
    Dim b As Long
    Dim c As Single

    Dim Der_Lg As Integer
    Dim Der_Col As Integer
    
    Sheets("Temp").Select
    Der_Lg = Range("A1").End(xlDown).Row
    Der_Col = Range("A" & Der_Lg).End(xlToRight).Column

    Cells(2, Der_Col + 1).Select
    ActiveCell.FormulaR1C1 = _
        "=" & Rayon & "*ACOS(COS(R[-1]C[-4])*COS(RC[-4])*COS(R[-1]C[-3]-RC[-3])+SIN(R[-1]C[-4])*SIN(RC[-4]))"

    Cells(2, Der_Col + 1).Select
    Selection.Copy
    Range(Cells(2, Der_Col + 1), Cells(Der_Lg, Der_Col + 1)).Select
    ActiveSheet.Paste

    Cells(Der_Lg + 1, Der_Col + 1).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-" & Der_Lg & "]C:R[-1]C)"


    a = ActiveCell.Value * 1000 / 100
    b = CLng(a) * 100
    c = b / 1000

    Calcul_Distance = c
   
End Function
Private Sub Mise_en_Mmoire()
    
    Dim Der_Lg As Integer
    
    Sheets("Liste_des_Randos").Select
    If Not Premier Then
        Der_Lg = 1
        Premier = True
    Else
        If Range("A1").End(xlDown).Row = 65536 Then
            Der_Lg = 1
        Else
            Der_Lg = Range("A1").End(xlDown).Row
        End If
    End If
    
    Cells(Der_Lg + 1, 1).Value = Dossier
    Cells(Der_Lg + 1, 2).Value = Nom_Rando
    Cells(Der_Lg + 1, 3).Value = Distance
    Cells(Der_Lg + 1, 4).Value = Dnivell

End Sub
Private Sub Calcul_Caractristiques()

    Dim i As Integer
    Dim Der_Lg As Integer
    Dim Num_Dossier As Integer
    Dim Num_Rando As Integer
    
    Sheets("Rando").Select
    Der_Lg = Range("A1").End(xlDown).Row
    
    For i = 2 To Der_Lg
        Num_Rando = Cells(i, 1).Value
        Num_Dossier = Cells(i, 2).Value
        Nom_Rando = Cells(i, 3).Value
        
        UpdateProgressBar_Secondaire (i / Der_Lg) * 100, "Calcul dnivell et kilomtrage : " & Format(i / Der_Lg, "0%") & "   ", i & "/" & Der_Lg & " : " & Nom_Rando
        
        Dossier = Recherche_Dossier(Num_Dossier)
        
        If InStr(1, UCase(Nom_Rando), "TRK") = 0 Then
            Recherche_Trace_Rando (Num_Rando)
            
            Dnivell = Calcul_Dnivell
            
            Distance = Calcul_Distance
            
            Mise_en_Mmoire
        End If
        
        Sheets("Rando").Select
    Next i
End Sub
Sub Tri_des_Randos()
    
    Dim Der_Lg As Integer
    Dim Der_Col As Integer
    
    Sheets("Liste_des_Randos").Select
    Der_Lg = Range("A1").End(xlDown).Row
    Der_Col = Range("A1").End(xlToRight).Column
    
    
    Range(Cells(1, 1), Cells(Der_Lg, Der_Col)).Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
        , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom

    Range("A1").Select
    
End Sub
Sub Liste_de_toutes_les_Randos()

    Dim Der_Lg As Integer
    Dim i As Integer
    Dim Dossier As String
    Dim Lg_Deb As Integer
    Dim Lg_Fin As Integer
    

    Tri_des_Randos

    Sheets("Liste_des_Randos").Select
    Der_Lg = Range("A1").End(xlDown).Row

    Dossier = Cells(1, 1).Value
    Lg_Deb = 1
    For i = 2 To Der_Lg
        If Cells(i, 1).Value = Dossier Then
            Cells(i, 1).Select
            Selection.ClearContents
        Else
            Lg_Fin = i - 1

            If Lg_Fin <> Lg_Deb Then
                Call Mise_en_Forme_Dossier(Lg_Deb, Lg_Fin)
                Call Mise_en_Forme_Nom_Rando_Distance_Denivell(Lg_Deb, Lg_Fin)
            End If

            Dossier = Cells(i, 1).Value
            If i <> Der_Lg Then
                Lg_Deb = i
            End If
        End If
    Next i

    Lg_Fin = Der_Lg
    Call Mise_en_Forme_Dossier(Lg_Deb, Lg_Fin)
    Call Mise_en_Forme_Nom_Rando_Distance_Denivell(Lg_Deb, Lg_Fin)
    
    Mise_en_Forme_Final_Liste_des_Randos
''''    Suppression_des_Feuilles

    Sheets("Liste_des_Randos").Select
    Columns("A:F").EntireColumn.AutoFit

        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Range("A1").Select
    
End Sub
Sub Mise_en_Forme_Final_Liste_des_Randos()
    Dim Der_Lg As Integer
    
    Columns("A:D").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Range("A1:D1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Rows("1:1").RowHeight = 26.25
    
    Range("A1:D1").Select
    With Selection.Interior
        .ColorIndex = 20
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Range("A1").Select
    
    Der_Lg = Range("A1").End(xlDown).Row
    Columns("C:C").Select
    Selection.NumberFormat = "0.000"
    
''''    Range("A2:C" & Der_Lg).Select
''''    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
''''    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
''''
''''    On Error Resume Next
''''    With Selection.Borders(xlEdgeLeft)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlMedium
''''    End With
''''
''''    With Selection.Borders(xlEdgeTop)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlMedium
''''    End With
''''
''''    With Selection.Borders(xlEdgeBottom)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlMedium
''''    End With
''''
''''    With Selection.Borders(xlEdgeRight)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlMedium
''''    End With
''''
''''    With Selection.Borders(xlInsideVertical)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlThin
''''    End With
''''
''''    With Selection.Borders(xlInsideHorizontal)
''''        .LineStyle = xlContinuous
''''        .ColorIndex = 0
''''        .TintAndShade = 0
''''        .Weight = xlHairline
''''    End With
''''
''''    On Error GoTo 0
    
    Columns("A:D").EntireColumn.AutoFit
    Range("A1").Select


End Sub
Sub Mise_en_Forme_Final_Feuille_Rando()
    Dim Der_Lg As Integer
    
    Columns("A:C").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Range("A1:C1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Rows("1:1").RowHeight = 26.25
    
    Range("A1:C1").Select
    With Selection.Interior
        .ColorIndex = 20
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    Range("A1").Select
    
    Der_Lg = Range("A1").End(xlDown).Row
    Columns("B:B").Select
    Selection.NumberFormat = "0.000"
    Range("A2:C" & Der_Lg).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    
    On Error Resume Next
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    
    On Error GoTo 0
    
    Columns("A:H").EntireColumn.AutoFit
    Range("A1").Select

End Sub
Sub Mise_en_Forme_Dossier(Lg_Deb, Lg_Fin)
    
'''    Lg_Fin = Range("A2").End(xlDown).Row - 1
    Range(Cells(Lg_Deb, 1), Cells(Lg_Fin, 1)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Sub Mise_en_Forme_Nom_Rando_Distance_Denivell(Lg_Deb, Lg_Fin)
    
    Range(Cells(Lg_Deb, 1), Cells(Lg_Fin, 4)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
    End With
    
    Range("A1").Select
End Sub
Sub UpdateProgressBar_Principal(NewValue As Single, Optional NewCaption As String, Optional Programme As String)
    
    Barre_Progression.Caption = "Evolution du programme Rendement "
''''    Barre_Progression.Caption = "Evolution du programme Rendement " & Nom
    
    Barre_Progression.Label_Principal = "Programme principal "
''''    Barre_Progression.Label_Principal = "Programme principal " & valeur & "%"
    
    
    With Barre_Progression
        If Not IsMissing(NewCaption) Then
            .Caption = NewCaption
        End If
        .Lab_Principal = Programme
        .Principal.Value = NewValue
        If NewValue <> 0 Then
            .Repaint
        End If
    End With
End Sub
Sub UpdateProgressBar_Secondaire(NewValue As Single, Optional NewCaption As String, Optional Programme As String)
    
    With Barre_Progression
        If (Not IsMissing(NewCaption)) Then
            .Caption = NewCaption
        End If
        .Secondaire.Value = NewValue
        .Lab_Secondaire = Programme
''''        .Label_Secondaire = "Programme secondaire " & valeur & "%"
        .Label_Secondaire = "Nom de la randonne "
        If NewValue <> 0 Then
            .Repaint
        End If
    End With
End Sub
Sub Suppression_des_Feuilles()
    Dim i As Integer
    
    Application.DisplayAlerts = False

    For i = 1 To Sheets.Count
        If (Sheets(i).Name <> "Liste_des_Randos") And Sheets(i).Name <> "Menu_Gnral" Then
        
            Sheets(Sheets(i).Name).Select
            ActiveWindow.SelectedSheets.Delete
            i = i - 1
        End If
        
        If i >= Sheets.Count Then
            Exit Sub
        End If
    Next i
    Application.DisplayAlerts = True
End Sub
Function Recherche_Rpertoire_Base_Randonnes()
    Dim Nom As String
    Dim fs As Variant
    Dim i As Integer
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    Application.ScreenUpdating = True
    
    If fs.FileExists("C:\Program Files (x86)\Bayo\CartoExploreur 3\CartoExploreur 3.mdb") Then
        ChDir ("C:\Program Files (x86)\Bayo\CartoExploreur 3")
    Else
        If fs.FileExists("c:\Programme\Bayo\CartoExploreur 3\CartoExploreur 3.mdb") Then
            ChDir ("C:\Program Files\Bayo\CartoExploreur 3")
        Else
            ChDir ("C:\")
        End If
    End If

    Message.Show
    
    On Error Resume Next
    If Sheets.Count <> 1 Then
        If Err = 0 Then
            Sheets("Menu_Gnral").Select
            Message_1.Show
        End If
    End If
    
    On Error GoTo 0
    Recherche_Rpertoire_Base_Randonnes = Application.GetOpenFilename("Fichier Access (*.mdb), *.mdb", 1, "Recherche de la Base des randonnes")
    Message.Hide
    Application.ScreenUpdating = False
    
End Function
Sub Rajout_Feuille_Rando(Dossier, Lg_Deb, Lg_Fin, Nb_Feuille)
    Dim Nom As String
    Dim Couleur(10) As Long
    Dim Nb As Integer
    
    Couleur(1) = 192
    Couleur(2) = 6299648
    Couleur(3) = 255
    Couleur(4) = 65535
    Couleur(5) = 5296274
    Couleur(6) = 5287936
    Couleur(7) = 15773696
    Couleur(8) = 12611584
    Couleur(9) = 49407
    Couleur(10) = 10498160
    
    Nb = Nb_Feuille
    While Nb > 10
        Nb = Nb - 10
    Wend

    Sheets.Add After:=Sheets(Sheets.Count)
    Nom = Sheets(Sheets.Count).Name
    
    Sheets(Nom).Select
    Sheets(Nom).Name = Dossier
    Sheets(Dossier).Select
    
    On Error Resume Next
    With ActiveWorkbook.Sheets(Dossier).Tab
        .Color = Couleur(Nb)
        .TintAndShade = 0
    End With
    On Error GoTo 0
    

    Cells(1, 1).Value = " Nom de la Rando "
    Cells(1, 2).Value = " Distance en km "
    Cells(1, 3).Value = " Dnivell en m "
    Columns("B:B").Select
    Selection.NumberFormat = "0.000"
    Range("A1").Select

    Sheets("Liste_des_Randos").Select
    Range("B" & Lg_Deb & ":D" & Lg_Fin).Select
    Selection.Copy
    Sheets(Dossier).Select
    Range("A2").Select
    ActiveSheet.Paste
    Range("A1").Select
    Application.CutCopyMode = False

End Sub
Sub Liste_des_Randos_par_Feuille()
    Dim Lg_Deb As Integer
    Dim Lg_Fin As Integer
    Dim Dossier As String
    Dim Nb_Feuille As Integer
    Dim i As Integer
    
    
    Tri_des_Randos

    Suppression_des_Feuilles

    Application.ScreenUpdating = False

    Nb_Feuille = 0
    Sheets("Liste_des_Randos").Select
    Dossier = Range("A2").Value
    Lg_Deb = 2
    
    For i = 2 To Range("A1").End(xlDown).Row
        If (Range("A" & i).Value = Dossier) Then
            Lg_Fin = i
        Else
            Nb_Feuille = Nb_Feuille + 1
            Call Rajout_Feuille_Rando(Dossier, Lg_Deb, Lg_Fin, Nb_Feuille)
        
            Mise_en_Forme_Final_Feuille_Rando
            
            Sheets("Liste_des_Randos").Select
            Dossier = Range("A" & i).Value
            Lg_Deb = i
        End If
    Next i
    
    Nb_Feuille = Nb_Feuille + 1
    Call Rajout_Feuille_Rando(Dossier, Lg_Deb, Lg_Fin, Nb_Feuille)
    Mise_en_Forme_Final_Feuille_Rando

End Sub
Sub Enregistrement()
    Dim Nom_Complet As String
    Dim i As Integer
    Dim Rep_Courant As String
    Dim fName As Variant
    Dim Nom As String
    Dim Msg As String
    

    Sheets("Menu_Gnral").Select
    Sheets.Add

    Sheets.Add After:=Sheets(Sheets.Count)
    Nom = Sheets(1).Name

    Sheets(Nom).Select
    Sheets(Nom).Name = "Feuil1"
    Sheets("Feuil1").Select

    Sheets("Menu_Gnral").Select
    ActiveWindow.SelectedSheets.Delete
    
    Nom_Complet = ActiveWorkbook.FullName

    For i = Len(Nom_Complet) To 1 Step -1
        If Mid(Nom_Complet, i, 1) = "\" Then
            Exit For
        End If
    
    Next i
    
    Rep_Courant = Mid(Nom_Complet, 1, i - 1)
    fName = Rep_Courant & "\" & "Liste_de_Toutes_les_Randos.xls"
    
    Msg = " Le fichier Liste_de_Toutes_les_Randos.xls sera sauvegard dans le rpertoire " & Chr(10) & Chr(10)
    Msg = Msg & Rep_Courant
    i = MsgBox(Msg, vbInformation, "Message Utilisateur")
    
    On Error Resume Next
    ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False

    
End Sub
Function Existe_Fichier()
    Dim a As Object
    Dim Nom_Complet As String
    Dim i As Integer
    Dim Fichier As String
    Dim b As Boolean
    
    Nom_Complet = ActiveWorkbook.FullName

    For i = Len(Nom_Complet) To 1 Step -1
        If Mid(Nom_Complet, i, 1) = "\" Then
            Exit For
        End If
    
    Next i
    
    Fichier = Mid(Nom_Complet, 1, i - 1) & "\" & "Liste_de_Toutes_les_Randos.xls"
    
    Set a = CreateObject("Scripting.FileSystemObject")
    Existe_Fichier = a.FileExists(Fichier)

End Function
Sub Programme_Principal()
    Dim Nb_Pass As Integer
    Dim Nb_Total As Integer
    Dim Rep_Courant As String
  

    Application.ScreenUpdating = False
    
    Premier = False
        
    If Existe_Fichier Then
        Nb_Total = Nb_Total
        Message_1.Show
    End If
    
    
    Rep_Base = Recherche_Rpertoire_Base_Randonnes
    If (Rep_Base = "Faux") Or (InStr(1, Rep_Base, "CartoExploreur 3.mdb") = 0) Then
        GoTo Fin
    End If
    
    Nb_Total = 6
    Nb_Pass = 0
    
    Load Barre_Progression
    Barre_Progression.Lab_Secondaire.Visible = False
    Barre_Progression.Label_Secondaire.Visible = False
    Barre_Progression.Secondaire.Visible = False
    
    With Barre_Progression
        .Show
    End With
    
    UpdateProgressBar_Principal 0, "Progression du Programme 0%", "" ' set initial progress status
    UpdateProgressBar_Secondaire 0, "Progression du Programme 0%", "" ' set initial progress status
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Cration des feuilles"
    Cration_des_Feuilles
    
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Rcupration des dossiers"
    Rcupration_des_Dossiers
    
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Rcupration des noms des randonnes"
    Rcupration_des_Randonnes
    
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Rcupration du trac des Randonnes"
    Rcupration_Tracs_des_Randonnes
    
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Secondaire 0, "Progression du Programme 0%", "" ' set initial progress status
    Barre_Progression.Lab_Secondaire.Visible = True
    Barre_Progression.Label_Secondaire.Visible = True
    Barre_Progression.Secondaire.Visible = True
    Barre_Progression.Repaint
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Calcul dnivells, kilomtrage"
    Calcul_Caractristiques
    
    
    Nb_Pass = Nb_Pass + 1
    UpdateProgressBar_Principal (Nb_Pass / Nb_Total) * 100, "Progression du Programme " & Format(Nb_Pass / Nb_Total, "0%") & "   ", "Mise en forme du rsultat"
    Liste_des_Randos_par_Feuille
    
    Barre_Progression.Hide
    Unload Barre_Progression
    
    
    Liste_de_toutes_les_Randos
''''    Sheets("Liste_des_Randos").Select
''''    ActiveWindow.SelectedSheets.Delete

Fin:
    Sheets("Menu_Gnral").Select
    Range("E9").Select
    
    Enregistrement
    
End Sub
