' Procedure : SetParam
' Date : 14/12/2016
' Révision : 08/09/2019
' Auteur : JeanPaul
' Objectif : Enregistrer un paramètre dans une feuille de paramètres
' Entrée :
' Sortie :
' Note : Si la feuille paramètres n'existe pas elle est créée si le paramètre n'existe pas il sera créé,
' La plage nommée est étendue à chaque entrée. Si AttriRangeName est sur True la plage Value sera nommée
' Exemple : SetParam("Formats.Hide.Ribbon", True, "Cache ou affiche le ruban.",True Retour : pas de retour
Public Function SetParam(Key As String, _
Value As Variant, _
Optional RemReq As String = "", _
Optional AttribRangeName As Boolean = False)
Dim lRow As Integer, Sh As Sheets, c As Range
'Si pas de feuille paramètres on l'a crée
If Not (SheetExist(shParam)) Then
With ThisWorkbook
.Sheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = shParam
With .Range("A1:C1")
.Interior.Color = vbYellow
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.Range("A1:C1").Value = Array(rngParamKeyName, rngParamValueName, rngParamRemReqName)
'.visible = xlSheetVeryHidden
.Columns("A:C").AutoFit
End With
.Names.Add Name:=rngParamKeyName, RefersTo:="='Paramètres'!$A$1"
End With
End If
'On ne rafraichi pas la feuille
Application.ScreenUpdating = False
'On recherche la clé
With Worksheets(shParam).Range(rngParamKeyName)
Set c = .Find(UCase(Key), Lookin:=xlValues)
'Si elle existe on met à jour
If Not c Is Nothing Then
c.Offset(0, 1).Value = Value
If RemReq <> "" Then
c.Offset(0, 2).Value = RemReq
End If
'Sinon on crée une Clé
Else
lRow = .Rows.Count
Set c = .Range("A" & (lRow + 1))
c.Value = Format(Key, ">")
c.Offset(0, 1).Value = Value
c.Offset(0, 2).Value = RemReq
End If
'On crée la plage nommée de la valeur
If AttribRangeName = True Then
Dim e As Name, Exist As Boolean
Exist = False
For Each e In ThisWorkbook.Names
If UCase(e.Name) = UCase(c.Value) Then Exist = True
Next
Select Case Exist
Case False
ThisWorkbook.Names.Add Name:=FormatParamKeyText(c.Value, vbProperCase), RefersTo:="='" & shParam & "'!" & c.Offset(0, 1).Address
Case True
ThisWorkbook.Names(c.Value).RefersTo = "='" & shParam & "'!" & c.Offset(0, 1).Address
End Select
End If
'On redimensionne la plage nommée Param_Key
Dim Tableau() As String
With ThisWorkbook.Names(rngParamKeyName)
Tableau = Split(.RefersTo, "!")
ThisWorkbook.Names.Add _
Name:=.Name, _
RefersTo:=Tableau(0) & "!" & _
Range(Tableau(1)).Resize(Range(Tableau(1)).Rows.Count + 1).Address
End With
End With
Worksheets(shParam).Columns("A:C").AutoFit
If Not c Is Nothing Then Set c = Nothing
'Worksheets(shParam).Protect Contents:=True, Password:=sPassWord, UserInterfaceOnly:=True
Application.ScreenUpdating = True
End Function
' Procedure : GetParam
' Date : 14/12/2016
' Auteur : JeanPaul
' Objectif : Lire un paramètre
' Entrée :
' Sortie :
' Note :
' Exemple : GetParam("Formats.Hide.Ribbon", True Retour : Pas de retour
Public Function GetParam(Key As String, Optional DefaultValue As Variant = "") As Variant
Dim c As Range
If SheetExist(shParam) = False Then GetParam = "": Exit Function
'On recherche la clé
With Worksheets(shParam).Range(rngParamKeyName)
Set c = .Find(UCase(Key), Lookin:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
'Si elle existe on charge sa valeur
If Not c Is Nothing Then
GetParam = c.Offset(0, 1).Value
'Sinon on charge la valeur par défaut
Else
GetParam = DefaultValue
End If
End With
End Function
