在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中设置。然后我找到了关于使用微软的脚本库来设置区域设置并在VBScript中执行一些操作的线程。这是史蒂夫写的。1+1=2，那么为什么不在VBScript中执行CDate并根据我的需要进行调整呢？我想创建一个CDate函数，它可以处理多个区域设置，直到它找到一个具有有效日期的区域设置。
示例：CDateLocale("2021年5月15日"，"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环境进行调整，以使库脚本控件按照StackOverfloow用户的建议工作：omegastripes获取scriptcontrol-to-work-with-excel-2010-x64
在代码中，我将#If Win64更改为#If Win64Or(Win32和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%syswow64mshta.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年第二季度或仅一年：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
享受吧！