Option Explicit
Public Const LgRésv = 32, LgValI = 32
Public Const SkDatÉcr = 1&, SkSkFin = SkDatÉcr + 8, SkDébRés = SkSkFin + 4, _
dSkHDép = 0, dSkLDép = dSkHDép + 8, dSkHArr = dSkLDép + 8, dSkLArr = dSkHArr + 8, _
dSkRésv = dSkLArr + 8, LgrEnrg = dSkRésv + 6 * LgRésv, SkTabImp = SkDébRés + 500& * LgrEnrg, _
dSkCodI = 0, dSkValI = dSkCodI + 8, dSkHeuI = dSkValI + LgValI, LgrEnrI = dSkHeuI + 8
Dim DateÉcrRéf As Date, SkFin As Long, HDép As Date, LDép As String, Rés As String
Dim RMin As Long, R As Long, RCnt As Long, RMax As Long, P As Integer
'
Function OuvrirBaseOk(Tâche As String) As Boolean
Dim RéfFic As String: RéfFic = ParmTélé.Range("RéfBasDon").Value
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Réessayer: Err.Clear
If FSO.FileExists(RéfFic) Then
Open RéfFic For Binary Access Read Write Shared As #1
Else
Err.Raise vbObjectError + 513, , "La base de donnée """ & RéfFic & """" _
& vbLf & "n'existe plus ou est indisponible."
End If
OuvrirBaseOk = Err = 0
If Err Then
If TélérésOpé Then
If Tâche <> "" Then If MsgBox(Err.Description & vbLf & _
"Si vous vous résignez à annuler, la téléréservation tombera en panne.", _
vbExclamation + vbRetryCancel, Tâche) = vbRetry Then GoTo Réessayer
TélérésvHS = True
End If
Close #1
End If
End Function
'
Function FRéserv(ByVal LDép As String, ByVal HDép As Date, Place As Integer) As String
If OuvrirBaseOk("Consultation d'une place") Then
Dim Sk As Long: Sk = SkRés(LDép, HDép, Place, Créer:=False)
If Sk = 0 Then
FRéserv = ""
Else
FRéserv = FStrRés(Sk)
End If
Close #1
End If
End Function
'
Function FStrRés(ByVal Sk As Long) As String
Dim L As Byte, Z As String, NumI As Long, CodI As String
Get #1, Sk, L: Z = String(L, " "): Get #1, , Z
If L > 1 Then
If Mid$(Z, L - 1, 1) = vbTab Then
NumI = Asc(Right$(Z, 1))
CodI = FStr(SkTabImp + (NumI - 1) * LgrEnrI + dSkCodI)
' If CodI = "" Then CodI = Format(NumI, "00")
Z = Left$(Z, L - 2) & vbLf & CodI
End If
End If
FStrRés = Z
End Function
'
Function SkRés(ByVal LDépart As String, ByVal HDépart As Date, Place As Integer, Créer As Boolean) As Long
Dim SkCou As Long, NouvEnregCréés As Boolean, HDépRPréc As Date, LDépRPréc As String
SkFin = FLng(SkSkFin): SkCou = SkFin
HDép = FDat(SkCou + dSkHDép)
LDép = FStr(SkCou + dSkLDép)
While HDép > HDépart Or HDép = HDépart And LDép <> LDépart
If SkCou <= SkDébRés Then SkCou = SkTabImp
SkCou = SkCou - LgrEnrg
HDép = FDat(SkCou + dSkHDép)
LDép = FStr(SkCou + dSkLDép)
Wend
If Créer Then
While HDép < HDépart Or HDép = HDépart And LDép <> LDépart
If SkCou = SkFin Then
SkCou = SkCou + LgrEnrg
If SkCou = SkTabImp Then SkCou = SkDébRés
SkFin = SkCou
If Not NouvEnregCréés Then
With RésEnC.Range("LigRés"): RMin = .Row: RMax = RMin + .Rows.Count - 1: End With
R = RMin
Do
HDépRPréc = CDate(RésEnC.Range("HDép").Rows(R).Value)
LDépRPréc = RésEnC.Range("LDép").Rows(R).Value
If HDépRPréc > HDép Then R = R - 1: Exit Do
If HDépRPréc = HDép And LDépRPréc = LDép Then Exit Do
R = R + 1: Loop
NouvEnregCréés = True
End If
R = R + 1
HDép = CDate(RésEnC.Range("HDép").Rows(R).Value)
LDép = RésEnC.Range("LDép").Rows(R).Value
FDat(SkCou + dSkHDép) = HDép
FStr(SkCou + dSkLDép) = LDép
FDat(SkCou + dSkHArr) = CDate(RésEnC.Range("HArr").Rows(R).Value)
FStr(SkCou + dSkLArr) = RésEnC.Range("LArr").Rows(R).Value
For P = 1 To 6: FStr(SkCou + dSkRésv + LgRésv * (P - 1)) = "": Next P
Else
SkCou = SkCou + LgrEnrg
If SkCou = SkTabImp Then SkCou = SkDébRés
HDép = FDat(SkCou + dSkHDép)
LDép = FStr(SkCou + dSkLDép)
End If
Wend
End If
If HDép <> HDépart Or LDép <> LDépart Then
If Not Créer And Place = 0 Then Place = 1
SkRés = 0
ElseIf Place = 0 Then
SkRés = SkCou + dSkRésv
For Place = 1 To 6
If FStr(SkRés) = "" Then GoTo Fin
SkRés = SkRés + LgRésv: Next Place
MsgBox "Navette pleine pour ce trajet", vbCritical, "Recherche place libre"
SkRés = 0: Place = 0
Else
SkRés = SkCou + dSkRésv + LgRésv * (Place - 1)
End If
Fin:
If NouvEnregCréés Then FLng(SkSkFin) = SkFin
End Function
'
Sub ImporterFicSiNéc()
If Not OuvrirBaseOk("Consultation de la base de données") Then Exit Sub
If TélérésvHS Then
MsgBox "La base de données a pu être ouverte," & vbLf _
& "une remise à niveau va avoir lieu.", _
vbInformation, "Tentative de consultation de la base"
Close #1
TélérésOpé = True
RemiseÀNiveau
If Not OuvrirBaseOk("Consultation de la base de données") Then Exit Sub
End If
Dim DernDateÉcr As Date, SkCou As Long, HDép1 As Date, RgPlace As Range
Dim Tv(1 To 500, 1 To 10) As Variant
DernDateÉcr = FDat(SkDatÉcr)
If DernDateÉcr <> DateÉcrRéf Then
SkFin = FLng(SkSkFin)
RMin = RésEnC.Range("LigRés").Row
RCnt = RésEnC.Range("LigRés").Rows.Count
HDép1 = CDate(RésEnC.Range("HDép").Rows(RMin).Value)
SkCou = SkFin: HDép = FDat(SkCou + dSkHDép)
R = 0
If HDép > HDép1 Then
Do:
SkCou = SkCou + LgrEnrg: If SkCou >= SkTabImp Then SkCou = SkDébRés
Loop Until FDat(SkCou + dSkHDép) >= HDép1
Do:
R = R + 1
If R > RCnt Then Exit Do
Tv(R, 1) = FStr(SkCou + dSkLDép)
Tv(R, 2) = FDat(SkCou + dSkHDép)
Tv(R, 3) = FStr(SkCou + dSkLArr)
Tv(R, 4) = FDat(SkCou + dSkHArr)
For P = 0 To 5
Tv(R, 5 + P) = FStrRés(SkCou + dSkRésv + LgRésv * P)
Next P
If SkCou = SkFin Then Exit Do
SkCou = SkCou + LgrEnrg: If SkCou >= SkTabImp Then SkCou = SkDébRés
Loop
With Application: .Calculation = xlCalculationManual: .EnableEvents = False: End With
If R > 0 Then RésEnC.Range("LDép:Places").Rows(RMin).Resize(R).Value = Tv
RésEnC.Range("DDép").Rows(RMin).Resize(R).Formula = "=INT(HDép)"
RésEnC.Range("Jour").Rows(RMin).Resize(R).Formula = "=MATCH(DDép,DatePlanif,1)"
RésEnC.Range("Traj").Rows(RMin).Resize(R).FormulaR1C1 = "=TrajLH(RC" _
& RésEnC.Range("LDép").Column & ",RC" & RésEnC.Range("HDép").Column & ")"
Else
RésEnC.Range("Places").Rows(RMin).Value = ""
R = 1
End If
If R < RCnt Then
RCnt = RCnt - R: R = RMin + R
RésEnC.Range("Jour").Rows(R).Resize(RCnt).FormulaR1C1 = "=OFFSET(RC,-1,0)+(Traj=1)"
RésEnC.Range("Traj").Rows(R).Resize(RCnt).FormulaR1C1 = "=MOD(OFFSET(RC,-1,0),ROWS(THDép))+1"
RésEnC.Range("DDép").Rows(R).Resize(RCnt).FormulaR1C1 = "=INDEX(DatePlanif,Jour)"
RésEnC.Range("LDép").Rows(R).Resize(RCnt).FormulaR1C1 = "=INDEX(TLDép,Traj)"
RésEnC.Range("HDép").Rows(R).Resize(RCnt).FormulaR1C1 = "=DDép+INDEX(THDép,Traj)"
RésEnC.Range("LArr").Rows(R).Resize(RCnt).FormulaR1C1 = "=INDEX(TLArr,Traj)"
RésEnC.Range("HArr").Rows(R).Resize(RCnt).FormulaR1C1 = "=INDEX(THArr,Traj)"
RésEnC.Range("Places").Rows(R).Resize(RCnt).ClearContents
End If
JusteImporterTabImp
With Application: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With
DateÉcrRéf = DernDateÉcr: End If
Close #1
End Sub
'
Sub JusteImporterTabImp()
Dim SkCou As Long, Ti(1 To 99, 1 To 4) As Variant, Z As String
SkCou = SkTabImp: R = 0
Do: R = R + 1
Ti(R, 1) = R
Ti(R, 2) = FStr(SkCou + dSkCodI)
Z = FStr(SkCou + dSkValI): If Z = "" Then _
Ti(R, 3) = Empty Else _
Ti(R, 3) = Z
Ti(R, 4) = FDat(SkCou + dSkHeuI)
If R = UBound(Ti, 1) Then Exit Do
SkCou = SkCou + LgrEnrI: Loop
TabImp.[Tablo Numéro:Theure].Value = Ti
End Sub
'
Sub ImporterTabImp()
Application.EnableEvents = False
If OuvrirBaseOk("Lecture de la table des imputations") Then
TabImp.BtTriNum_Click
JusteImporterTabImp
DateÉcrRéf = FDat(SkDatÉcr)
End If
Close #1
Application.EnableEvents = True
End Sub
'
Sub CréerLeFichier()
Dim Nom As String, Spéc As String, CodI As String, NumI As Long, X As Double
On Error Resume Next
Open ParmTélé.Range("RéfBasDon").Value For Binary Access Read Write Shared As #1
If Err Then
MsgBox Err.Description, vbCritical, "Création de la base de données"
Close #1: TélérésvHS = True: Exit Sub
End If
On Error GoTo 0
SkFin = SkTabImp
With RésEnC.Range("LigRés"): RMin = .Row: RMax = RMin + RésEnC.Range("NbVoy").Value - 1: End With
TabImp.BtTriNum_Click
For R = RMin To RMax
SkFin = SkFin + LgrEnrg: If SkFin >= SkTabImp Then SkFin = SkDébRés
FDat(SkFin + dSkHDép) = CDate(RésEnC.Range("HDép").Rows(R).Value)
FStr(SkFin + dSkLDép) = RésEnC.Range("LDép").Rows(R).Value
FDat(SkFin + dSkHArr) = CDate(RésEnC.Range("HArr").Rows(R).Value)
FStr(SkFin + dSkLArr) = RésEnC.Range("LArr").Rows(R).Value
For P = 1 To 6
ValRés(Nom, Spéc, CodI) = RésEnC.[Places].Item(R, P).Value
NumI = 0
If IsNumeric(CodI) Then X = CodI: NumI = Int(Min(Max(X, 0), 99)): If NumI <> X Then NumI = 0
If NumI = 0 Then NumI = ÉquivRg0(CodI, TabImp.[Tablo TCode])
If NumI > 0 Then CodI = vbTab & Chr$(NumI)
FStr(SkFin + dSkRésv + LgRésv * (P - 1)) = ValRés(Nom, Spéc, CodI)
Next P
Next R
FLng(SkSkFin) = SkFin
Do
SkFin = SkFin + LgrEnrg: If SkFin >= SkTabImp Then Exit Do
FDat(SkFin + dSkHDép) = 0
FStr(SkFin + dSkLDép) = ""
Loop
JusteÉcrireTabImp
FDat(SkDatÉcr) = Now
Close #1
End Sub
'
Sub JusteÉcrireTabImp()
Dim Ti As Variant, SkCou As Long
Ti = TabImp.[Tablo Numéro:Theure].Value
SkCou = SkTabImp
For R = 1 To UBound(Ti, 1)
FStr(SkCou + dSkCodI) = Ti(R, 2)
FStr(SkCou + dSkValI) = Ti(R, 3)
FDat(SkCou + dSkHeuI) = Ti(R, 4)
SkCou = SkCou + LgrEnrI: Next R
End Sub
'
Sub ÉcrireTabImp()
If OuvrirBaseOk("Écriture de la table des imputations") Then
TabImp.BtTriNum_Click
JusteÉcrireTabImp
FDat(SkDatÉcr) = Now
End If
Close #1
End Sub
'
Sub VérifierLeFichier(HeurÉcri As Variant, DernLDép As String, DernHDép As Variant)
If OuvrirBaseOk("") Then
HeurÉcri = FDat(SkDatÉcr)
SkFin = FLng(SkSkFin)
If SkFin >= SkDébRés And SkFin < SkTabImp And SkDébRés + LgrEnrg * ((SkFin - SkDébRés) \ LgrEnrg) = SkFin Then
DernLDép = FStr(SkFin + dSkLDép): DernHDép = FDat(SkFin + dSkHDép)
Else
DernLDép = "": DernHDép = Null
End If
Else
HeurÉcri = Null: DernLDép = "": DernHDép = Null
End If
Close #1
End Sub
'
Property Get FStr(ByVal Sk As Long) As String
Dim L As Byte, Z As String: Get #1, Sk, L: Z = String(L, " "): Get #1, , Z: FStr = Z
End Property
Property Let FStr(ByVal Sk As Long, ByVal Z As String)
Dim L As Byte: L = Len(Z): Put #1, Sk, L: Put #1, , Z
End Property
Property Get FLng(ByVal Sk As Long) As Long: Get 1, Sk, FLng: End Property
Property Let FLng(ByVal Sk As Long, ByVal VLng As Long): Put 1, Sk, VLng: End Property
Property Get FDat(ByVal Sk As Long) As Date: Get 1, Sk, FDat: End Property
Property Let FDat(ByVal Sk As Long, ByVal VDat As Date): Put 1, Sk, VDat: End Property
