如何设置语言环境以便 CDATE 进行正确的转换？答案

【问题标题】：How can I set the Locale so that CDATE does the correct conversion?如何设置语言环境以便 CDATE 进行正确的转换？
【发布时间】：2021-08-23 19:52:12
【问题描述】：

在 VBA 中，我有一个允许以 dmy 顺序输入多语言日期的源。但这可能是 2021 年 11 月 3 日，也可能是 2021 年 3 月 3 日，甚至是 2021 年 5 月 5 日（德语）。所以用户地域不同，有时会忘记输入英文。这不是我要解决的 dmy 或 mdy 问题。我尝试使用 CDate 来转换这些日期，但无济于事。我无法在 VBA 中设置语言环境，以便 CDate 正确使用它。

【问题讨论】：

这能回答你的问题吗？ VBS incorrect datetime format

标签： vba date setlocale

【解决方案1】：

CDateLocale

我寻找一种解决方案，在 VBA 中为 CDate 提供替代方案，以处理来自不同语言环境的输入。首先，我尝试自己处理每种语言（英语、德语、荷兰语）的例外情况。所涉及的月份是 3 月、5 月、10 月和 12 月，每种语言都不同。但这太过分了。假设您想添加斯瓦希里语 (sw)。我想要的是一个直接的解决方案，无需处理每一个异常。

我在任何地方都读到无法在 Excel 中设置当前的语言环境。然后我找到了关于使用 Microsoft 的脚本库来设置语言环境并在 VBScript 中执行一些操作的线程。这是史蒂夫写的。 1+1 =2，那么为什么不在 VBScript 中执行 CDate 并使其适应我的需要呢？我想创建一个可以处理多个语言环境的 CDate 函数，直到找到一个具有有效日期的语言。

示例：CDateLocale("15 Mai 2021", "en-GB,nl,de") => 15-5-2021（通过 de Locale 找到）

如果没有找到它返回 0，我更喜欢它而不是像 CDate 那样引发错误。语言环境可以是数字，语言国家/地区的语言。不允许使用十六进制代码。提示：在开头设置您最常用的语言环境。

所以结果是：

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

您需要适应 VBA7 或 Win64 环境，以使 Library Scriptcontrol 按照 StackOverfloow 用户的建议工作：omegastripes getting-scriptcontrol-to-work-with-excel-2010-x64

在代码中，我将 #If Win64 更改为 #If Win64 Or (Win32 And VBA7) 以使其在我的 32 位环境中工作。我无法测试是否适用于 Win64。

您可以将以下内容放在单独的模块中，以便您也可以在其他情况下使用它。命名它，例如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

然后我想将转换后的字符串日期恢复为一个字符串，因为我想允许不规则的日期，例如 2021 Q2 或只有一年：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

布丁的证据在吃，所以我做了一些测试

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

结果：

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

享受吧！

【讨论】：