如何解决如何设置区域设置以便 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
享受吧!
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。