Date et heure Omega String

[Bernard_XLD]

Bonjour a tous

Bernard_XLD et patricktoulon vous présentent Omega String, la fonction Os "à la fin, je suis un String".
Partant d'une idée, Patrick et moi avons développé cette fonction de conversion horaire en mode texte plus particulièrement dédiée à l'affichage et au calcul des horaires négatifs en calendrier 1900, mais qui peut servir à d'autres fins.
Elle transcrit toute valeur horaire en chaîne texte formatée selon le format de la cellule appelante si elle existe ou selon un format personnalisé passé en argument optionnel.
Les formats personnalisés des cellules ( ou passés en argument ) sont traités et les 56 couleurs de police possibles pour le texte sont gérées.
Compatible et prévue de base pour pouvoir fonctionner avec Omega Hour, elle permet de travailler et d'afficher normalement les heures négatives en calendrier 1900. elle possède un argument facultatif permettant de préciser un format texte de sortie
Utilisable en formule ou Vba.

Bien cordialement, @+

'********************************************
'             Fontion Omega String (Os), "à la fin, je suis un texte"
'             V1.0
'cette fonction, dédiée au travail des heures en calendrier 1900, convertit en texte toute valeur horaire et affiche le résultat selon le format de la cellule parente
'les formats personnalisés sont traités et les 56 couleurs de police possibles sont gérées
'cette fonction est conçue pour pouvoir travailler avec la fonction Omega Hour (Oh)
'utilisable Vba et formule
'auteurs : Bernard_XLD & patricktoulon sur ExcelDownloads
'date 16/05/2021
'**********************************************

Function Os(Val_Ref, Optional FormatTxt$)
Dim CellNumberFormat$, ColorNeg$, ColorPos$, i&, CellHor As Boolean, TestVal As Boolean, TestVal2 As Boolean
With Application
    If TypeName(Val_Ref) = "Range" Then If Val_Ref.Count > 1 Then Exit Function
    If Not TypeName(.Caller) = "Range" And FormatTxt = "" Then FormatTxt = "[hh]:mm:ss"
    CellNumberFormat = FormatTxt
    If TypeName(.Caller) = "Range" Then
        If CellNumberFormat = "" Then CellNumberFormat = .ThisCell.NumberFormat
        CellHor = UCase(CellNumberFormat) Like "*[H,M,S]*"
        If CellHor Then
            If InStr(1, .ThisCell.NumberFormat, "]-") Or InStr(1, .ThisCell.NumberFormat, "][") Then .Caller.Font.ColorIndex = xlAutomatic
            If InStr(1, CellNumberFormat, "]-") Then
                For i = Len(CellNumberFormat) - 2 To 1 Step -1
                    If Mid(CellNumberFormat, i + 1, 2) = "]-" Or TestVal = True Then
                        If Mid(CellNumberFormat, i, 1) = "[" Then TestVal = False: Exit For
                        ColorNeg = Mid(CellNumberFormat, i, 1) & ColorNeg
                        TestVal = True
                    End If
                Next i
                Select Case ColorNeg
                Case Is = "Black"
                    ColorNeg = 1
                Case Is = "White"
                    ColorNeg = 2
                Case Is = "Red"
                    ColorNeg = 3
                Case Is = "Green"
                    ColorNeg = 4
                Case Is = "Blue"
                    ColorNeg = 5
                Case Is = "Yellow"
                    ColorNeg = 6
                Case Is = "Magenta"
                    ColorNeg = 7
                Case Is = "Cyan"
                    ColorNeg = 8
                Case Else
                    ColorNeg = Mid(ColorNeg, 6)
                End Select
            End If
            If InStr(1, CellNumberFormat, "][") Then
                For i = 1 To Len(CellNumberFormat)
                    If Mid(CellNumberFormat, i, 1) = "[" Or TestVal = True Then
                        If Mid(CellNumberFormat, i + 1, 1) = "]" Then Exit For
                        ColorPos = ColorPos & Mid(CellNumberFormat, i + 1, 1)
                        TestVal = True
                    End If
                Next i
                Select Case ColorPos
                Case Is = "Black"
                   ColorPos = 1
                Case Is = "White"
                   ColorPos = 2
                Case Is = "Red"
                   ColorPos = 3
                Case Is = "Green"
                   ColorPos = 4
                Case Is = "Blue"
                   ColorPos = 5
                Case Is = "Yellow"
                   ColorPos = 6
                Case Is = "Magenta"
                   ColorPos = 7
                Case Is = "Cyan"
                   ColorPos = 8
                Case Else
                   ColorPos = Mid(ColorPos, 6)
                End Select
            End If
        End If
    End If
    If Val_Ref < 0 Then
        Os = "-" & .Text(-Val_Ref, CellNumberFormat)
        If Not ColorNeg = "" Then .Caller.Font.ColorIndex = ColorNeg
    Else
        Os = .Text(Val_Ref, CellNumberFormat)
        If Not ColorPos = "" Then .Caller.Font.ColorIndex = ColorPos
    End If
End With
End Function

Sub Test_Os()
Dim ChnTest, FormatTxt$
FormatTxt = "[hh]" & Chr(34) & " heures " & Chr(34) & "mm" & Chr(34) & " minutes " & Chr(34) & "ss" & Chr(34) & " secondes" & Chr(34)
ChnTest = "7:45"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
ChnTest = "-7:45"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
ChnTest = "10,10"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
ChnTest = "-10,10"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
ChnTest = "10.10"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
ChnTest = "-10.10"
MsgBox "Valeur texte de " & ChnTest & "  au format " & FormatTxt & " : " & vbLf & vbLf & Os(Oh(ChnTest), FormatTxt), vbOKOnly + vbInformation
End Sub