Attribute VB_Name = "basIntlFormats" '------------------------------------------ ' basIntlFormats ' ' Some helper functions for handling date/time/currency ' formats for locales other than the current regional ' settings will handle. Since VB relies on the control ' panel, this is the only way to accomplish this. ' ' You may use this code in your projects, but a note on who ' you got it from would be appreciated. :-) ' ' Version of this module is 2.1. ' ' HISTORY: ' 1.0 5/5/98 Added date/time enum info ' 1.1 12/1/98 Used Get[Time|Date]Format instead of VB's Format function ' 1.2 5/5/99 Added currency formatting support ' 1.3 10/1/99 Added locale validation code ' 2.0 10/1/99 Added NT5 constants ' 2.1 10/1/99 Added comments on the validation code ' ' (c) 1998-99 Trigeminal Software, Inc. All Rights Reserved '------------------------------------------ Option Explicit Option Compare Text '------------------------------------------------------------ ' LOCALE specifiers -- from OLENLS.H '------------------------------------------------------------ Public Enum LCTypeEnum LOCALE_NOUSEROVERRIDE = &H80000000 ' OR in to avoid user override LOCALE_ILANGUAGE = &H1 ' language id LOCALE_SLANGUAGE = &H2 ' localized name of language LOCALE_SENGLANGUAGE = &H1001 ' English name of language LOCALE_SABBREVLANGNAME = &H3 ' abbreviated language name LOCALE_SNATIVELANGNAME = &H4 ' native name of language LOCALE_ICOUNTRY = &H5 ' country code LOCALE_SCOUNTRY = &H6 ' localized name of country LOCALE_SENGCOUNTRY = &H1002 ' English name of country LOCALE_SABBREVCTRYNAME = &H7 ' abbreviated country name LOCALE_SNATIVECTRYNAME = &H8 ' native name of country LOCALE_IDEFAULTLANGUAGE = &H9 ' default language id LOCALE_IDEFAULTCOUNTRY = &HA ' default country code LOCALE_IDEFAULTCODEPAGE = &HB ' default oem code page LOCALE_IDEFAULTANSICODEPAGE = &H1004 ' default ansi code page LOCALE_SLIST = &HC ' list item separator LOCALE_IMEASURE = &HD ' 0 = metric, 1 = US LOCALE_SDECIMAL = &HE ' decimal separator LOCALE_STHOUSAND = &HF ' thousand separator LOCALE_SGROUPING = &H10 ' digit grouping LOCALE_IDIGITS = &H11 ' number of fractional digits LOCALE_ILZERO = &H12 ' leading zeros for decimal LOCALE_INEGNUMBER = &H1010 ' negative number mode LOCALE_SNATIVEDIGITS = &H13 ' native ascii 0-9 LOCALE_SCURRENCY = &H14 ' local monetary symbol LOCALE_SINTLSYMBOL = &H15 ' intl monetary symbol LOCALE_SMONDECIMALSEP = &H16 ' monetary decimal separator LOCALE_SMONTHOUSANDSEP = &H17 ' monetary thousand separator LOCALE_SMONGROUPING = &H18 ' monetary grouping LOCALE_ICURRDIGITS = &H19 ' # local monetary digits LOCALE_IINTLCURRDIGITS = &H1A ' # intl monetary digits LOCALE_ICURRENCY = &H1B ' positive currency mode LOCALE_INEGCURR = &H1C ' negative currency mode LOCALE_SDATE = &H1D ' date separator LOCALE_STIME = &H1E ' time separator LOCALE_SSHORTDATE = &H1F ' short date-time separator LOCALE_SLONGDATE = &H20 ' long date-time separator LOCALE_STIMEFORMAT = &H1003 ' time format string LOCALE_IDATE = &H21 ' short date format ordering LOCALE_ILDATE = &H22 ' long date format ordering LOCALE_ITIME = &H23 ' time format specifier LOCALE_ITIMEMARKPOSN = &H1005 ' time marker position LOCALE_ICENTURY = &H24 ' century format specifier LOCALE_ITLZERO = &H25 ' leading zeros in time field LOCALE_IDAYLZERO = &H26 ' leading zeros in day field LOCALE_IMONLZERO = &H27 ' leading zeros in month field LOCALE_S1159 = &H28 ' AM designator LOCALE_S2359 = &H29 ' PM designator LOCALE_ICALENDARTYPE = &H1009 ' type of calendar specifier LOCALE_IOPTIONALCALENDAR = &H100B ' additional calendar types specifier LOCALE_IFIRSTDAYOFWEEK = &H100C ' first day of week specifier LOCALE_IFIRSTWEEKOFYEAR = &H100D ' first week of year specifier LOCALE_SDAYNAME1 = &H2A ' long name for Monday LOCALE_SDAYNAME2 = &H2B ' long name for Tuesday LOCALE_SDAYNAME3 = &H2C ' long name for Wednesday LOCALE_SDAYNAME4 = &H2D ' long name for Thursday LOCALE_SDAYNAME5 = &H2E ' long name for Friday LOCALE_SDAYNAME6 = &H2F ' long name for Saturday LOCALE_SDAYNAME7 = &H30 ' long name for Sunday LOCALE_SABBREVDAYNAME1 = &H31 ' abbreviated name for Monday LOCALE_SABBREVDAYNAME2 = &H32 ' abbreviated name for Tuesday LOCALE_SABBREVDAYNAME3 = &H33 ' abbreviated name for Wednesday LOCALE_SABBREVDAYNAME4 = &H34 ' abbreviated name for Thursday LOCALE_SABBREVDAYNAME5 = &H35 ' abbreviated name for Friday LOCALE_SABBREVDAYNAME6 = &H36 ' abbreviated name for Saturday LOCALE_SABBREVDAYNAME7 = &H37 ' abbreviated name for Sunday LOCALE_SMONTHNAME1 = &H38 ' long name for January LOCALE_SMONTHNAME2 = &H39 ' long name for February LOCALE_SMONTHNAME3 = &H3A ' long name for March LOCALE_SMONTHNAME4 = &H3B ' long name for April LOCALE_SMONTHNAME5 = &H3C ' long name for May LOCALE_SMONTHNAME6 = &H3D ' long name for June LOCALE_SMONTHNAME7 = &H3E ' long name for July LOCALE_SMONTHNAME8 = &H3F ' long name for August LOCALE_SMONTHNAME9 = &H40 ' long name for September LOCALE_SMONTHNAME10 = &H41 ' long name for October LOCALE_SMONTHNAME11 = &H42 ' long name for November LOCALE_SMONTHNAME12 = &H43 ' long name for December LOCALE_SMONTHNAME13 = &H100E ' long name for 13th month (if exists) LOCALE_SABBREVMONTHNAME1 = &H44 ' abbreviated name for January LOCALE_SABBREVMONTHNAME2 = &H45 ' abbreviated name for February LOCALE_SABBREVMONTHNAME3 = &H46 ' abbreviated name for March LOCALE_SABBREVMONTHNAME4 = &H47 ' abbreviated name for April LOCALE_SABBREVMONTHNAME5 = &H48 ' abbreviated name for May LOCALE_SABBREVMONTHNAME6 = &H49 ' abbreviated name for June LOCALE_SABBREVMONTHNAME7 = &H4A ' abbreviated name for July LOCALE_SABBREVMONTHNAME8 = &H4B ' abbreviated name for August LOCALE_SABBREVMONTHNAME9 = &H4C ' abbreviated name for September LOCALE_SABBREVMONTHNAME10 = &H4D ' abbreviated name for October LOCALE_SABBREVMONTHNAME11 = &H4E ' abbreviated name for November LOCALE_SABBREVMONTHNAME12 = &H4F ' abbreviated name for December LOCALE_SABBREVMONTHNAME13 = &H100F ' abbreviated name for 13th month (if exists) LOCALE_SPOSITIVESIGN = &H50 ' positive sign LOCALE_SNEGATIVESIGN = &H51 ' negative sign LOCALE_IPOSSIGNPOSN = &H52 ' positive sign position LOCALE_INEGSIGNPOSN = &H53 ' negative sign position LOCALE_IPOSSYMPRECEDES = &H54 ' mon sym precedes pos amt LOCALE_IPOSSEPBYSPACE = &H55 ' mon sym sep by space from pos LOCALE_INEGSYMPRECEDES = &H56 ' mon sym precedes neg amt LOCALE_INEGSEPBYSPACE = &H57 ' mon sym sep by space from neg */ End Enum ' Locale enumeration flags from winnls.h Private Const LCID_INSTALLED = &H1 '/* installed locale ids */ Private Const LCID_SUPPORTED = &H2 '/* supported locale ids */ ' dwFlags values for EnumDateFormats Private Const DATE_SHORTDATE = &H1 ' use short date picture Private Const DATE_LONGDATE = &H2 ' use long date picture Private Const DATE_USE_ALT_CALENDAR = &H4 ' use alternate calendar (if any) #If (WINVER >= &H500) Then Private Const DATE_YEARMONTH = &H8 ' use year month picture Private Const DATE_LTRREADING = &H10 ' add marks for left to right reading order layout Private Const DATE_RTLREADING = &H20 ' add marks for right to left reading order layout #End If ' WINVER >= &h0500 Private Type CURRENCYFMT NumDigits As Long ' number of decimal digits LeadingZero As Long ' if leading zero in decimal fields Grouping As Long ' group size left of decimal lpDecimalSep As String ' ptr to decimal separator string lpThousandSep As String ' ptr to thousand separator string NegativeOrder As Long ' negative currency ordering PositiveOrder As Long ' positive currency ordering lpCurrencySymbol As String ' ptr to currency symbol string End Type Private Type SYSTEMTIME wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (pDest As Any, pSrc As Any, ByVal ByteLen As Long) ' Supported by NT4, Windows 95, Windows 98 Private Declare Function ConvertDefaultLocale Lib "kernel32" (ByVal LCID As Long) As Long Private Declare Function EnumDateFormats Lib "kernel32" Alias "EnumDateFormatsA" (ByVal lpDateFmtEnumProc As Long, ByVal locale As Long, ByVal dwFlags As Long) As Boolean Private Declare Function EnumTimeFormats Lib "kernel32" Alias "EnumTimeFormatsA" (ByVal lpTimeFmtEnumProc As Long, ByVal locale As Long, ByVal dwFlags As Long) As Boolean Private Declare Function GetCurrencyFormat Lib "kernel32" Alias "GetCurrencyFormatA" (ByVal locale As Long, ByVal dwFlags As Long, ByVal lpValue As String, lpFormat As CURRENCYFMT, ByVal lpCurrencyStr As String, ByVal cchCurrency As Long) As Long Private Declare Function GetDateFormat Lib "kernel32" Alias "GetDateFormatA" (ByVal locale As Long, ByVal dwFlags As Long, lpDate As SYSTEMTIME, ByVal lpFormat As String, ByVal lpDateStr As String, ByVal cchDate As Long) As Long Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal LCID As Long, ByVal LCTYPE As Long, lpData As Any, ByVal cchData As Integer) As Integer Private Declare Function GetUserDefaultLangID Lib "kernel32" () As Integer Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long Private Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long Private Declare Function GetTimeFormat Lib "kernel32" Alias "GetTimeFormatA" (ByVal locale As Long, ByVal dwFlags As Long, lpTime As SYSTEMTIME, ByVal lpFormat As String, ByVal lpTimeStr As String, ByVal cchTime As Long) As Long Private Declare Function IsValidLocale Lib "kernel32" (ByVal locale As Long, ByVal dwFlags As Long) As Boolean Private Declare Function VariantTimeToSystemTime Lib "oleaut32.dll" (ByVal vtime As Double, lpSystemTime As SYSTEMTIME) As Boolean ' Not used at present -- Windows 2000-specific functions relating to the UI language. ' CONSIDER: Use them for enhanced NT5 support? Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetSystemDefaultUILanguage Lib "kernel32" () As Long Private m_stFormatEnum As String '---------------------------------------------------------------------- ' StGetLocaleInfo ' ' Gets Locale (international) info about current config ' See LOCALE constants at top of module for LCTYPE values '---------------------------------------------------------------------- Public Function StGetLocaleInfo(locale As Long, LCTYPE As LCTypeEnum) As String Dim LCID As Long Dim stBuff As String * 255 'ask for the locale info If (GetLocaleInfo(locale, LCTYPE, ByVal stBuff, Len(stBuff)) > 0) Then StGetLocaleInfo = StFromSz(stBuff) End If End Function '------------------------------------------------------------ ' StFromSz ' ' Returns a truncated string given a null terminated string '------------------------------------------------------------g Public Function StFromSz(szTmp As String) As String Dim ich As Integer ich = InStr(1, szTmp, vbNullChar, vbBinaryCompare) If ich Then StFromSz = Left$(szTmp, ich - 1) Else StFromSz = szTmp End If End Function Public Function StDateEnum(ByVal locale As Long, Optional ByVal fShortDate As Boolean = True) As String m_stFormatEnum = vbNullString Call EnumDateFormats(AddressOf EnumFormatsProc, locale, IIf(fShortDate, DATE_SHORTDATE, DATE_LONGDATE)) StDateEnum = m_stFormatEnum End Function Public Function StTimeEnum(ByVal locale As Long) As String m_stFormatEnum = vbNullString Call EnumTimeFormats(AddressOf EnumFormatsProc, locale, 0&) StTimeEnum = m_stFormatEnum End Function Public Function EnumFormatsProc(ByVal lpFormatString As Long) As Long Dim st As String st = String$(lstrlen(lpFormatString), vbNullChar) RtlMoveMemory ByVal StrPtr(st), ByVal lpFormatString, lstrlen(lpFormatString) st = StFromSz(StrConv(st, vbUnicode)) ' Grab the first format m_stFormatEnum = st ' Stop enumerating after the first one (there is usually only one anyway) EnumFormatsProc = 1& End Function '------------------------------ ' FormatDateTimeIntl ' ' Provides a slightly better version of FormatDateTime which will allow ' you to use format strings other than the ones for the current regional ' settings '------------------------------ Public Function FormatDateTimeIntl(Expression As Variant, _ Optional NamedFormat As VbDateTimeFormat = vbGeneralDate, _ Optional locale As Long = -1) Dim stDateFormat As String Dim stTimeFormat As String Dim stDateBuffer As String Dim stTimeBuffer As String Dim st As SYSTEMTIME Dim cch As Long If (IsValidLocale(locale, LCID_SUPPORTED) = 0) Then ' Either they are wanting the default locale, or the locale they specified ' is invalid, so use the normal FormatDateTime function. This works since ' the default value (-1) is not a supported locale ' CONSIDER: NOT a perfect solution, perhaps an error should be raised ' when an invalid LCID is passed? FormatDateTimeIntl = FormatDateTime(Expression, NamedFormat) Exit Function End If Select Case NamedFormat Case vbGeneralDate stDateFormat = StDateEnum(locale, False) stTimeFormat = StTimeEnum(locale) Case vbLongDate stDateFormat = StDateEnum(locale, False) Case vbShortDate stDateFormat = StDateEnum(locale, True) Case vbLongTime stTimeFormat = StTimeEnum(locale) Case vbShortTime ' Since VB does not use regional settings for this format, neither ' do we. Display a time using the 24-hour format (hh:mm) stTimeFormat = "hh" & StGetLocaleInfo(locale, LOCALE_STIME) & "mm" End Select If (NamedFormat = vbGeneralDate) Or (NamedFormat = vbLongDate) Or (NamedFormat = vbShortDate) Then If VariantTimeToSystemTime(Expression, st) Then cch = GetDateFormat(locale, 0&, st, stDateFormat, vbNullString, 0&) If cch > 0 Then stDateBuffer = String$(cch, vbNullChar) If GetDateFormat(locale, 0&, st, stDateFormat, stDateBuffer, Len(stDateBuffer)) > 0 Then stDateBuffer = StFromSz(stDateBuffer) Else Err.Raise vbObjectError + 3000, "basIntlformats.FormatDateTimeIntl", "Failed GetDateFormat call, GetLastError returns: " & Err.LastDllError End If End If Else Err.Raise vbObjectError + 3000, "basIntlformats.FormatDateTimeIntl", "Failed VariantTimeToSystemTime call, GetLastError returns: " & Err.LastDllError End If End If If (NamedFormat = vbGeneralDate) Or (NamedFormat = vbLongTime) Or (NamedFormat = vbShortTime) Then If VariantTimeToSystemTime(Expression, st) Then cch = GetTimeFormat(locale, 0&, st, stTimeFormat, vbNullString, 0&) If cch > 0 Then stTimeBuffer = String$(cch, vbNullChar) If GetTimeFormat(locale, 0&, st, stTimeFormat, stTimeBuffer, Len(stTimeBuffer)) > 0 Then stTimeBuffer = StFromSz(stTimeBuffer) Else Err.Raise vbObjectError + 3000, "basIntlformats.FormatDateTimeIntl", "Failed GetDateFormat call, GetLastError returns: " & Err.LastDllError End If End If Else Err.Raise vbObjectError + 3000, "basIntlformats.FormatDateTimeIntl", "Failed VariantTimeToSystemTime call, GetLastError returns: " & Err.LastDllError End If End If If NamedFormat = vbGeneralDate Then FormatDateTimeIntl = stDateBuffer & " " & stTimeBuffer Else FormatDateTimeIntl = stDateBuffer & stTimeBuffer End If End Function '------------------------------ ' FormatCurrencyIntl ' ' Provides a slightly better version of FormatCurrency which will allow ' you to use format strings other than the ones for the current regional ' settings... '------------------------------ Function FormatCurrencyIntl(Expression As Variant, _ Optional NumDigitsAfterDecimal As Long = -1, _ Optional IncludeLeadingDigit As VbTriState = vbUseDefault, _ Optional UseParensForNegativeNumbers As VbTriState = vbUseDefault, _ Optional GroupDigits As VbTriState = vbUseDefault, _ Optional locale As Long = -1) As String Dim cf As CURRENCYFMT Dim nc As Integer Dim stGrouping As String Dim stBuffer As String Dim ich As Long Dim cch As Long If (IsValidLocale(locale, LCID_SUPPORTED) = 0) Then ' Either they are wanting the default locale, or the locale they specified ' is invalid, so use the normal FormatCurrency function. This works since ' the default value (-1) is not a supported locale. ' CONSIDER: NOT a perfect solution, perhaps an error should be raised ' when an invalid LCID is passed? FormatCurrencyIntl = FormatCurrency(Expression, NumDigitsAfterDecimal, IncludeLeadingDigit, UseParensForNegativeNumbers, GroupDigits) Exit Function End If If NumDigitsAfterDecimal = -1 Then cf.NumDigits = StGetLocaleInfo(locale, LOCALE_IDIGITS) Else cf.NumDigits = NumDigitsAfterDecimal End If If IncludeLeadingDigit = vbUseDefault Then cf.LeadingZero = StGetLocaleInfo(locale, LOCALE_ILZERO) Else cf.LeadingZero = Abs(IncludeLeadingDigit) End If Select Case UseParensForNegativeNumbers Case vbUseDefault cf.NegativeOrder = StGetLocaleInfo(locale, LOCALE_INEGCURR) Case vbTrue If StGetLocaleInfo(locale, LOCALE_INEGSYMPRECEDES) = 1 Then cf.NegativeOrder = 0 ' Left parenthesis,monetary symbol,number,right parenthesis. Example: ($1.1) Else cf.NegativeOrder = 4 ' Left parenthesis, number, monetary symbol, right parenthesis. Example: (1.1$) End If Case vbFalse Select Case StGetLocaleInfo(locale, LOCALE_INEGSIGNPOSN) Case 0 ' Parentheses surround the amount and the monetary symbol. ' Moral dilemma... the user has said to NOT use parens for ' negative currency, but the control panel says we should ' and does not give us the order. Try to derive it nc = StGetLocaleInfo(locale, LOCALE_INEGCURR) Select Case nc Case 0, 14 ' Left parenthesis,monetary symbol,number,right parenthesis. Example: ($1.1) -- 14 has extra space cf.NegativeOrder = 1 ' Negative sign, monetary symbol, number. Example: -$1.1 Case 4, 15 ' Left parenthesis, number, monetary symbol, right parenthesis. Example: (1.1$) -- 15 has extra space cf.NegativeOrder = 7 ' Number, monetary symbol, negative sign. Example: 1.1$- Case Else cf.NegativeOrder = nc End Select Case 1 ' The sign precedes the number. cf.NegativeOrder = 2 ' Monetary symbol, negative sign, number. Example: $-1.1 Case 2 ' The sign follows the number. cf.NegativeOrder = 3 ' Monetary symbol, number, negative sign. Example: $1.1- Case 3 ' The sign precedes the monetary symbol. cf.NegativeOrder = 1 ' Negative sign, monetary symbol, number. Example: -$1.1 Case 4 ' The sign follows the monetary symbol. cf.NegativeOrder = 7 ' Number, monetary symbol, negative sign. Example: 1.1$- End Select End Select Select Case GroupDigits Case vbUseDefault, vbTrue stGrouping = StGetLocaleInfo(locale, LOCALE_SMONGROUPING) ich = InStr(1, stGrouping, ";", vbBinaryCompare) If ich > 0 Then stGrouping = Left$(stGrouping, ich - 1) If IsNumeric(stGrouping) Then cf.Grouping = Val(stGrouping) Else cf.Grouping = 3 End If Case vbFalse cf.Grouping = 0 End Select ' Get the values that the function does not have params for from the info ' for the given locale cf.lpCurrencySymbol = StGetLocaleInfo(locale, LOCALE_SCURRENCY) cf.lpDecimalSep = StGetLocaleInfo(locale, LOCALE_SMONDECIMALSEP) cf.lpThousandSep = StGetLocaleInfo(locale, LOCALE_STHOUSAND) cf.PositiveOrder = StGetLocaleInfo(locale, LOCALE_ICURRENCY) cch = GetCurrencyFormat(locale, 0&, CStr(Expression), cf, vbNullString, 0&) If cch > 0 Then stBuffer = String$(cch, vbNullChar) If GetCurrencyFormat(locale, 0&, CStr(Expression), cf, stBuffer, Len(stBuffer)) > 0 Then FormatCurrencyIntl = StFromSz(stBuffer) Else Err.Raise vbObjectError + 3000, "basIntlformats.FormatCurrencyIntl", "Failed GetCurrencyFormat call, GetLastError returns: " & Err.LastDllError End If End If End Function