Code:
Option Explicit
'Public Sub Get2ShortDate()
Public Function GetMySystemsShortDate() As String
Rem 1 Attempt to get the sShortDate from registry via DateSerial( ) implification way
On Error GoTo Bed
Dim TestDateSerial As String
Let TestDateSerial = DateSerial(9, 3, 4) ' DateSerial(year, month, day) https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dateserial-function
' By experimenting, it appears that for the day and month, if the sShortDate in the registry needs more than one character then a zero is added to that retuned by DateSerial(9, 3, 4) For the year any missing characters seem to be relplaced by a 0 2 or 1 - For this reason I don't use 1 or 2 for the day or month becuse if i do , there may be some wrong determination below: We use the number to determine if we have a day or month or year
If InStr(1, TestDateSerial, "9", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Year in your short date format": Exit Function
If InStr(1, TestDateSerial, "3", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Month number in your short date format": Exit Function
If InStr(1, TestDateSerial, "4", vbBinaryCompare) = 0 Then MsgBox Prompt:="You have no Day number in your short date format": Exit Function
Dim C As Variant ' This is each character. It can be a number or letter, so I used Variant but string would work also
Dim Cnt As Long: Let Cnt = 1
Let C = Mid(TestDateSerial, Cnt, 1) ' ========= start of returned string
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting through the characters, (numbers), from the start, while we have a number. So we are counting the first number section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = True
Dim Cnt1 As Long: Let Cnt1 = Cnt - 1 ' this will be the count of the characters ( numbers ) in the first number section
' =============================================
Dim Sep1 As String
Do While IsNumeric(C) = False
Let Sep1 = Sep1 & C ' In the first seperator
Let Cnt = Cnt + 1 ' we are counting through the character in the thing used as the first seperator. (These should not be numbers)
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
Dim DMY As String ' At this point we have reached the end of the first seperator,
' the next lines search the numbers in the first number section to determine if they are a day or month or year
If InStr(1, Left(TestDateSerial, Cnt - 1), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are actually looking at the first number and first seperator, but never ming
If InStr(1, Left(TestDateSerial, Cnt - 1), "3", vbBinaryCompare) <> 0 Then Let DMY = "M"
If InStr(1, Left(TestDateSerial, Cnt - 1), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Dim sShortDate As String ' the next line gives us a character string where the fist numbers are replaced by characters representing if they are a day or month or year
Let sShortDate = Evaluate("=REPT(""" & DMY & """," & Cnt1 & ")") & Sep1 ' ======= make first bit of output ==
' ===== xx & sep1 ******************************************
Dim Pos2 As Long ' ============================================================================================
Let Pos2 = Len(sShortDate) + 1 ' This should be the position where the second number section starts
Do While IsNumeric(C) = True
Let Cnt = Cnt + 1 ' we are counting the characters ( numbers ) in the second ( middle ) character ( number ) section
Let C = Mid(TestDateSerial, Cnt, 1)
Loop
Dim Cnt2 As Long: Let Cnt2 = Cnt - Pos2 ' this will be the count of the characters ( numbers ) in the second ( middle ) number section
' ========================== at first character in second seperator ========================================
Dim Sep2 As String
Do While IsNumeric(C) = False
Let Sep2 = Sep2 & C '
Let Cnt = Cnt + 1 ' we are counting through the characters making up the second seperator
Let C = Mid(TestDateSerial, Cnt, 1)
Loop ' While IsNumeric(C) = False
' the Cnt C counting stops at the start of the last number section
' the next lines search the numbers in the second ( middle) number section to determine if they are a day or month or year
' at this point we have got the second seperator string, Sep2 and are at the start of the last number ===
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we are looking in the middle number section
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "3", vbBinaryCompare) <> 0 Then Let DMY = "M"
If InStr(1, Mid(TestDateSerial, Pos2, Cnt2), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt2 & ")") & Sep2 ' this adds to the sShortDate string the characters to indicate the type ( day month or year ) of the middle section numbers and the second seperator
' ==== xx & Sep1 & yy & Sep2 *******************************************
Dim Pos3 As Long: Let Pos3 = Len(sShortDate) + 1 ' this should be the start position of the last number section
Dim Cnt3 As Long '
Let Cnt3 = Len(TestDateSerial) - Pos3 + 1 ' this should be the number of characters ( numbers ) in the last number section
' we don't bother to loop through the last number section
' the next lines search the numbers in the third ( last ) number section to determine if they are a day or month or year
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "4", vbBinaryCompare) <> 0 Then: Let DMY = "d" ' we look from the start of the last number section, Pos3 , for a length of its count of its characters , Cnt3
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "3", vbBinaryCompare) <> 0 Then Let DMY = "M"
If InStr(1, Mid(TestDateSerial, Pos3, Cnt3), "9", vbBinaryCompare) <> 0 Then Let DMY = "y"
Let sShortDate = sShortDate & Evaluate("=REPT(""" & DMY & """," & Cnt3 & ")") ' finally we add the characters representing the characters to indicate the type ( day month or year ) of the last section
' ===== xx & Sep1 & yy & Sep2 & zzz *************************************************************************
' =============================================================================================================
GoTo Rem2
Bed: ' Error handling code section for if the above coding errored
Let sShortDate = "Error getting sShortDate"
On Error GoTo -1
Rem2: ' Rem 2 Some other computer and user info
On Error Resume Next ' In case info below is somehow protected
Dim UsrNme As String: Let UsrNme = Application.UserName: Let UsrNme = Environ("username")
Dim CmprNme As String: Let CmprNme = Environ("computername")
Dim WOS As String: Let WOS = Environ("OS")
'Dim VersXl As String: Let VersXl = " ( " & ExcelVersion & " ) "
On Error GoTo 0
'Debug.Print sShortDate
Let GetMySystemsShortDate = sShortDate
End Function
Reply With Quote
Bookmarks