如何设置区域设置以便 CDATE 进行正确的转换？

问题描述

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

解决方法

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 环境进行调整，以使库脚本控件按照 StackOverflow 用户的建议工作：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>""",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",de,fr ")
    Debug.Print CDateString("2021 Q3",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,"")
    Debug.Print CDateString("Nov 3,"0")
    Debug.Print CDateString("Nov 3,"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

享受吧！