1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168
|
'---------------------------------------------------------------------------------------
' Déclarations Publiques / Privées
'---------------------------------------------------------------------------------------
'
Dim rBigramme As Range ' Plage contenant le bigramme
Dim rLcn As Range ' Plage contenant le LCN
Dim rAplomb As Range ' Plage contenant le niveau d'aplomb
Dim lLigneCourante As Long ' Numéro de la ligne courante
Dim iAplomb As Integer ' Valeur de l'aplomb courant
Dim iAplombPrec As Integer ' Valeur de l'aplomb précédant
Dim iAplombSuiv As Integer ' Valeur de l'aplomb suivant
Dim sLcn As String ' Chaine constituant le LCN
Dim sLcnPrec As String ' Valeur du LCN à la ligne précédente
Dim lTailleFormat As Long ' Taille du format
Dim stFormatLCN(0 To 8) As String ' On définit la taille du tableau contenant les formats
' de chaque niveau d'aplomb
'---------------------------------------------------------------------------------------
' Initialisations
'---------------------------------------------------------------------------------------
'
' On récupère les plages nommées dans la feuille de calcul
Set rBigramme = Worksheets("Feuil1").Range("Bigramme")
Set rLcn = Worksheets("Feuil1").Range("Lcn")
Set rAplomb = Worksheets("Feuil1").Range("Aplomb")
iAplomb = 1 ' Vdp
iAplombPrec = 0 ' Vdp
iAplombSuiv = 0 ' Vdp
sLcn = "" ' VpD
sLcnPrec = "" ' VpD
lLigneCourante = 0 ' VpD
lTailleFormat = 0 ' VpD
' On initialise le tableau contenant les formats de chaque niveau d'aplomb
' Le numéro d'indice du tableau correspond au numéro d'indice de l'aplomb
' L'indice "0" n'est présent que pour gérer le code du ... ("B" pour ...)
' Séquences au format : 1er car = taille en Nb car, 2ème car = type de séquence
stFormatLCN(0) = "1B" ' "B" pour ...
stFormatLCN(1) = "2$" ' Bigramme de l'installation
stFormatLCN(2) = "2X" ' Commence à "01" et fini à "ZZ"
stFormatLCN(3) = "2Y" ' Commence à "AA" et fini à "99"
stFormatLCN(4) = "2X" ' Commence à "01" et fini à "ZZ"
stFormatLCN(5) = "2Y" ' Commence à "AA" et fini à "99"
stFormatLCN(6) = "2X" ' Commence à "01" et fini à "ZZ"
stFormatLCN(7) = "2Y" ' Commence à "AA" et fini à "99"
stFormatLCN(8) = "1X" ' Commence à "1" et fini à "Z"
'---------------------------------------------------------------------------------------
' Implémentation
'---------------------------------------------------------------------------------------
'
If IsEmpty(prAplomb.Value) Then Exit Function ' Terminé : pas de calcul à réaliser
iAplomb = prAplomb.Value ' Récupère la valeur de l'aplomb courant
If Not IsNumeric(iAplomb) Then
MsgBox ("ERREUR : L'aplomb doit être numérique !")
Else
lLigneCourante = prAplomb.Row ' Récupère le numéro de ligne courante
If iAplomb <= UBound(stFormatLCN, 1) Then
' Le niveau d'aplomb est conforme pour le LCN
If iAplomb = 1 Then
If rBigramme.Cells(lLigneCourante, 1).Value <> "" Then
' Le bigramme est renseigné
sLcn = Right(stFormatLCN(0), 1) & rBigramme.Cells(lLigneCourante, 1).Value ' On initialise la chaine du LCN
F_Calcul_LCN = sLcn ' On affecte la valeur au LCN
Else
' Le bigramme n'est pas renseigné --> on quitte la procédure
MsgBox "F_Calcul_LCN : Bigramme d'intallation non renseigné " & _
vbCrLf & " --> Calcul impossible !"
End If
Else
' On récupère la valeur de l'aplomb précédent
iAplombPrec = rAplomb.Cells(lLigneCourante - 1, 1).Value
If (iAplomb - iAplombPrec) <= 1 Then
' On récupère la valeur du LCN précédent
' ET C'EST LA QUE L'ERREUR DE REFERENCE CIRCULAIRE INTERVIENT !
sLcnPrec = rLcn.Cells(lLigneCourante - 1, 1).Value
'---------------------------------------------------------------
' On récupère la taille du format courant
lTailleFormat = CLng(Val(Left(stFormatLCN(iAplomb), 1)))
Select Case iAplombPrec
Case Is < iAplomb
' On initialise la chaine du LCN pour le niveau à partir du LCN Précédent
sLcn = sLcnPrec & InitialiseNiveau(stFormatLCN(iAplomb))
' On initialise la mémorisation de la partie de sequence d'incrémentation du
' niveau d'aplomb courant
itPartieSeq(iAplomb) = 1
Case Is = iAplomb
' On incrémente la valeur du LCN pour le niveau
sIndex = IncrementeNiveau(stFormatLCN(iAplomb), _
Right(sLcnPrec, lTailleFormat), _
itPartieSeq(iAplomb))
sLcn = Left(sLcnPrec, Len(sLcnPrec) - lTailleFormat) & sIndex
Case Is > iAplomb
' On détermine la valeur du LCN pour le niveau courant à partir du LCN précédent
' On calcule la taille du LCN pour le niveau courant
lTailleLcn = 0
For iInd = 0 To iAplomb
lTailleLcn = lTailleLcn + CLng(Val(Left(stFormatLCN(iInd), 1)))
Next iInd
' On récupère la partie du LCN du niveau précédent pour constituer le LCN du niveau courant
sLcnCourant = Left(sLcnPrec, lTailleLcn)
' On incrémente la valeur du LCN pour le niveau
sIndex = IncrementeNiveau(stFormatLCN(iAplomb), _
Right(sLcnCourant, lTailleFormat), _
itPartieSeq(iAplomb))
sLcn = Left(sLcnCourant, Len(sLcnCourant) - lTailleFormat) & sIndex
End Select
' On initialise la chaine du LCN
sLcn = Right(stFormatLCN(0), 1) & rBigramme.Cells(lLigneCourante, 1).Value
' On affecte la valeur au LCN
F_Calcul_LCN = sLcn
If InStr(1, rLcn.Cells(lLigneCourante, 1).Value, "?") > 0 Then
' Le LCN comporte une erreur : on l'affiche en gras blanc sur fond rouge
rLcn.Cells(lLigneCourante, 1).Interior.Color = vbRed
rLcn.Cells(lLigneCourante, 1).Font.Color = vbWhite
rLcn.Cells(lLigneCourante, 1).Characters.Font.Bold = True
End If
Else
MsgBox "F_Calcul_LCN : ligne n°" & lLigneCourante & _
" Ecart entre aplomb courant et aplomb précédent > 1 !!!"
L 'aplomb courant comporte une erreur : on l'affiche en gras blanc sur fond rouge
rAplomb.Cells(lLigneCourante, 1).Interior.Color = vbRed
rAplomb.Cells(lLigneCourante, 1).Font.Color = vbWhite
rAplomb.Cells(lLigneCourante, 1).Characters.Font.Bold = True
End If
End If ' iAplomb = 1
Else
MsgBox "F_Calcul_LCN : Niveau d'aplomb supérieur au niveau d'aplomb maximum imposé par le LCN !!!"
Exit Function
End If
End If
' On Error GoTo F_Calcul_Lcn_Erreur
'
' On Error GoTo 0
' Exit Function
'
'F_Calcul_Lcn_Erreur:
'
' MsgBox "Erreur " & Err.Number & " (" & Err.Description & ") dans la fonction F_Calcul_LCN du module F_Calcul_LCN"
'
'Fin:
End Function |
Partager