How can I set the Locale so that CDATE does the correct conversion?

Question

In VBA I have a source that allows for multilingual date input in dmy order. But that can be 3 Nov 2021, but also 3-3-2021 of even 5 Mai 2021 in German. So the users are indifferent regions and sometimes forget to enter in English. It is not the dmy or mdy problem that I want to solve. I tried to use CDate to convert these dates, but to no avail. I could not set the Locale from within VBA, so that CDate would use it correctly.

Answer 1

CDateLocale

I looked for a solution to have an alternative for CDate in VBA that could handle input from different locales. First I tried to deal with the exception for each language (English, German, Dutch) myself. The months involved were March, May, October and December, which are different in each of the languages. But this was too much of a hazzle. Imagine you want to add Swahili (sw). What I wanted was a straight forward solution without dealing with each and every exception.

Everywhere I read that the current Locale could not be set in Excel. And then I found thread about using the Microsoft's scripting library to set the Locale and perform some actions in VBScript. It was written by Steve. 1+1 =2, so why not perform CDate in VBScript and adapt it to my needs? I wanted create a CDate function that could handle multiple locales, until it finds one that has a valid date.

Example: CDateLocale( "15 Mai 2021", "en-GB,nl,de") => 15-5-2021 (found via the de Locale)

If not found it returns 0, which I like better than raising an error as CDate does. The locale can either be a number, language of language-Country. No hexcodes are allowed. Tip: Set your most frequent used Locale at the beginning.

So that results in:

Function CDateLocale(mycDate As String, Optional inputlocale As String) As String

Option Explicit

'VBScript function as a string:

Const codestring = "Function XXX(mycdate, locale)" & vbCrLf & _
            "On Error resume next" & vbCrLf & _
            "CurLocale = SetLocale(locale)" & vbCrLf & _
            "XXX = cdate(mycDate)" & vbCrLf & _
            "SetLocale(CurLocale)" & vbCrLf & _
            "End Function"
        
'GENERAL REMARK
'CDate recognizes date formats according to the locale setting
'You must provide the day, month, and year in the correct order for your locale,
'or the date may not be interpreted correctly.
'A long date format is not recognized if it contains
'a day-of-the-week string, such as "Wednesday".


Public Function CDateLocale(myCDate As String, Optional Inputlocale As String) As Date

    'This function does not solve the problem with the order of day and month
    'It solves the language problem when a literal date is not recognized.
    'E.g. Avril will not be recognized if checked with en-GB as locale. Avril = April in French
    'With fr as locale it will be recognized
    'Example: CDateLocale("5 Avr 2021", "fr")
 
    'Inputlocale is optional. Without inputlocale this function defaults to the user region and
    'language setting and hence works the way CDate does.
 
    Dim locales() As String
    Dim i As Long
    
    Inputlocale = Replace(Inputlocale, " ", "") 'solve input errors
    If Inputlocale = "" Then
        Inputlocale = "0"  'force userlocale
    End If
    
    If Len(myCDate) = 4 Then  'Probably a single year is entered, like: 2021
        'Force that it is not a date,
        'otherwise 13-7-1905 will be returned = the 2021th day since 1 jan 1900
        CDateLocale = 0
    Else
        locales = Split(Inputlocale, ",")
        
       'Thanks to Steve' StackOverflow user for the ScriptControl solution
       'https://stackoverflow.com/questions/42122216/vbscript-getlocale-setlocale-other-uses

        With CreateObjectx86("ScriptControl")
            .Language = "VBScript"
            .addCode codestring     'See Const codestring at top of module
            
            For i = LBound(locales) To UBound(locales)
                On Error Resume Next  'XXX can cause an error
                    CDateLocale = .Run("XXX", myCDate, locales(i))
                On Error GoTo 0
                If CDateLocale <> 0 Then
                   Exit For
                End If
            Next
            
        End With
    
    End If

End Function

And you need an adaptation for the VBA7 or Win64 environment to make the Library Scriptcontrol work as suggested by StackOverfloow user: omegastripes getting-scriptcontrol-to-work-with-excel-2010-x64

In the code I changed #If Win64 to #If Win64 Or (Win32 And VBA7) to make it work in my 32 bits environment. I can't test if for Win64.

You can place the following in a separate module, so that you can use it in other situations as well. Name it e.g. LIB_ScriptControl

Option Explicit

Sub Test()
    
    Dim oSC As Object
    
    Set oSC = CreateObjectx86("ScriptControl") ' create ActiveX via x86 mshta host
    Debug.Print TypeName(oSC) ' ScriptControl
    ' do some stuff
    
    ' mshta window is running until Static oWnd reference to window lost
    ' if necessary you can manually close mshta host window by CreateObjectx86 Empty
    
End Sub

Function CreateObjectx86(Optional sProgID)
   
    Static oWnd As Object
    Dim bRunning As Boolean
    
    #If Win64 Or (Win32 And VBA7) Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        Select Case True
            Case IsMissing(sProgID)
                If bRunning Then oWnd.Lost = False
                Exit Function
            Case IsEmpty(sProgID)
                If bRunning Then oWnd.Close
                Exit Function
            Case Not bRunning
                Set oWnd = CreateWindow()
                oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID) End Function", "VBScript"
                oWnd.execScript "var Lost, App;": Set oWnd.App = Application
                oWnd.execScript "Sub Check(): On Error Resume Next: Lost = True: App.Run(""CreateObjectx86""): If Lost And (Err.Number = 1004 Or Err.Number = 0) Then close: End If End Sub", "VBScript"
                oWnd.execScript "setInterval('Check();', 500);"
        End Select
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject(sProgID)
    #End If
    
End Function

Function CreateWindow()

    ' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
    Dim sSignature, oShellWnd, oProc
    
    On Error Resume Next
    Do Until Len(sSignature) = 32
        sSignature = sSignature & Hex(Int(Rnd * 16))
    Loop
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop
    
End Function

And then I wanted to my converted string date back to a string as I wanted to allowed for irregular dates, such as 2021 Q2 or only a year: 2024.

Function CDateString(myCDate As String, _
                     Optional Inputlocale As String, _
                     Optional OutputFormat As String) As String

Dim dDate As Date
dDate = CDateLocale(myCDate, Inputlocale)

If OutputFormat = "" Then
    OutputFormat = "[$-0809]dd-mmm-yyyy"  'my preference : en-GB
    'language added in case you want mmm or mmmm
End If

If dDate = 0 Then
    CDateString = myCDate
Else
    'CDateString = Format(dDate, OutputFormat)
    'Format does not react on locale in outputformat, so use WorksheetFunction.Text instead
    'You could write your own code via VBScript...
    CDateString = WorksheetFunction.Text(dDate, OutputFormat)
End If

End Function

The proof of the pudding is in the eating, so I did some testing

Sub Test_CDateLocal()
    Debug.Print CDateString("Avril 02, 2021", "en-GB,de,nl, fr ")
    Debug.Print CDateString("2021 Q3", "en-GB,de,nl,fr")
    Debug.Print CDateString("2-3-2021")
    Debug.Print CDateString("After 3 Nov 2021")
    Debug.Print CDateString("2021")
    Debug.Print CDateString("No date yet")
    Debug.Print CDateString("5 Mai 2021", "de")
    Debug.Print CDateString("Nov 3, 2021")
    Debug.Print CDateString("Nov 3, 2021", "")
    Debug.Print CDateString("Nov 3, 2021", "0")
    Debug.Print CDateString("Nov 3, 2021", "0809")
End Sub

And the result:

02-Apr-2021
2021 Q3
02-Mar-2021
After 3 Nov 2021
2021
No date yet
05-May-2021
03-Nov-2021
03-Nov-2021
03-Nov-2021
03-Nov-2021

Enjoy!