Login | Register   
LinkedIn
Google+
Twitter
RSS Feed
Download our iPhone app
TODAY'S HEADLINES  |   ARTICLE ARCHIVE  |   FORUMS  |   TIP BANK
Browse DevX
Sign up for e-mail newsletters from DevX


Tip of the Day
Language: VB6
Expertise: Advanced
Sep 15, 2003

FormatInternationalDate - Retrieving a date in an international format

' *** International date handler
Public Enum eDateLocale
   edlArabic = &H401
   edlDanish = &H406
   edlGerman = &H407
   edlSwissGerman = &H807
   edlAmerican = &H409
   edlBritish = &H809
   edlAustralian = &HC09
   edlSpanish = &H40A
   edlFinnish = &H40B
   edlFrench = &H40C
   edlFrenchCanadian = &HC0C
   edlHebrew = &H40D
   edlItalian = &H410
   edlDutch = &H413
   edlDutchPreferred = &H13
   edlDutchBelgian = &H813
   edlNorskBokmal = &H414
   edlNorskNynorsk = &H814
   edlPortBrazil = &H416
   edlPortIberian = &H816
   edlSwedish = &H41D
   edlCatalan = &H403
   edlRussian = &H419
   edlCzech = &H405
   edlHungarian = &H40E
   edlPolish = &H415
   edlJapanese = &H411
   edlKorean = &H412
   edlTaiwan = &H404
   edlChina = &H804
   edlTurkish = &H41F
   edlGreek = &H408
   edlBasque = &H42D
   edlSlovenian = &H424
   edlMalaysian = &H43E
   edlAfrikaans = &H436
   edlBulgarian = &H402
   edlCroatian = &H41A
   edlEstonian = &H425
   edlLatvian = &H426
   edlLithuanian = &H427
   edlMacedonian = &H42F
   edlRomanian = &H418
   edlSerbianCyrillic = &HC1A
   edlSerbianLatin = &H81A
   edlByelorussian = &H423
   edlSlovak = &H41B
   edlUkrainian = &H422
   edlIcelandic = &H40F
   edlVietnamese = &H42A
   edlThai = &H41E
End Enum

Private Const LOCALE_SDAYNAME1 = &H2A
Private Const LOCALE_SDAYNAME2 = &H2B
Private Const LOCALE_SDAYNAME3 = &H2C
Private Const LOCALE_SDAYNAME4 = &H2D
Private Const LOCALE_SDAYNAME5 = &H2E
Private Const LOCALE_SDAYNAME6 = &H2F
Private Const LOCALE_SDAYNAME7 = &H30
Private Const LOCALE_SMONTHNAME1 = &H38
Private Const LOCALE_SMONTHNAME2 = &H39
Private Const LOCALE_SMONTHNAME3 = &H3A
Private Const LOCALE_SMONTHNAME4 = &H3B
Private Const LOCALE_SMONTHNAME5 = &H3C
Private Const LOCALE_SMONTHNAME6 = &H3D
Private Const LOCALE_SMONTHNAME7 = &H3E
Private Const LOCALE_SMONTHNAME8 = &H3F
Private Const LOCALE_SMONTHNAME9 = &H40
Private Const LOCALE_SMONTHNAME10 = &H41
Private Const LOCALE_SMONTHNAME11 = &H42
Private Const LOCALE_SMONTHNAME12 = &H43

Private Declare Function IsValidLocale Lib "kernel32" (ByVal Locale As Long, _
    ByVal dwFlags As Long) As Boolean
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" _
    (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, _
    ByVal cchData As Long) As Long
Private Declare Function GetUserDefLCID Lib "kernel32" Alias _
    "GetUserDefaultLCID" () As Long


' **********************************************************************
' * Programmer Name  : WAty Thierry
' * E-Mail           : waty.thierry@vbdiamond.com
' * Web Site         : http://www.d2dsources.com
' * Date             : 07/15/2003
' **********************************************************************
' * Comments         : Retrieve the date from an international long Format
' *
' * Retrieve the date from an international long format
' * Debug.Print FormatInternationalDate("11 juillet 2003") ' => 2003/07/11,
' * Debug.Print FormatInternationalDate("11-july-2003", , "-") ' => 2003/07/11,
' * Debug.Print FormatInternationalDate("11 diciembre 2003") ' => 2003/12/11
' *
' **********************************************************************

Function FormatInternationalDate(sDate As String, Optional sRequiredFormat As _
    String = "YYYY/MM/DD", Optional sDelimiter As Variant = " ") As String
   On Error GoTo ERROR_FormatInternationalDate
   
   Dim sTmp       As String
   Dim oSplit()   As String
   
   Dim sDay       As String
   Dim sMonth     As String
   Dim sYear      As String
   
   Dim colLanguage  As New Collection
   
   Dim oLanguage  As Variant
   Dim nLanguage  As eDateLocale
   
   ' *** Some init
   sDay = vbNullString
   sMonth = vbNullString
   sYear = vbNullString
   
   ' *** Get the date
   sTmp = Trim$(sDate)
   
   ' *** Clean  a bit the date with double delimiters
   Do While InStr(sTmp, sDelimiter & sDelimiter) > 0
      sTmp = Replace(sTmp, sDelimiter & sDelimiter, sDelimiter, , , _
          vbTextCompare)
   Loop
   
   ' *** Split the date
   oSplit = Split(sTmp, sDelimiter)
   
   ' *** Check if we have 3 parts
   If UBound(oSplit) = 2 Then
      ' *** Assuming the day is the first of the array
      sDay = oSplit(0)
      ' *** Assuming the month is the second of the array
      sMonth = oSplit(1)
      ' *** Assuming the year is the third of the array
      sYear = oSplit(2)
   Else
      sMonth = sDate
   End If
   
   ' *** Create the collection of languages
   colLanguage.Add "L" & edlFrench ' *** &H40C
   colLanguage.Add "L" & edlFrenchCanadian ' *** &HC0C
   colLanguage.Add "L" & edlGerman ' *** &H407
   colLanguage.Add "L" & edlSpanish ' *** &H40A
   colLanguage.Add "L" & edlItalian ' *** &H410
   colLanguage.Add "L" & edlDutch ' *** &H413
   colLanguage.Add "L" & edlSwedish ' *** &H41D
   colLanguage.Add "L" & edlDanish ' *** &H406
   colLanguage.Add "L" & edlArabic ' *** &H401
   colLanguage.Add "L" & edlSwissGerman ' *** &H807
   colLanguage.Add "L" & edlAmerican ' *** &H409
   colLanguage.Add "L" & edlBritish ' *** &H809
   colLanguage.Add "L" & edlAustralian ' *** &HC09
   colLanguage.Add "L" & edlFinnish ' *** &H40B
   colLanguage.Add "L" & edlHebrew ' *** &H40D
   colLanguage.Add "L" & edlDutchPreferred ' *** &H13
   colLanguage.Add "L" & edlDutchBelgian ' *** &H813
   colLanguage.Add "L" & edlNorskBokmal ' *** &H414
   colLanguage.Add "L" & edlNorskNynorsk ' *** &H814
   colLanguage.Add "L" & edlPortBrazil ' *** &H416
   colLanguage.Add "L" & edlPortIberian ' *** &H816
   colLanguage.Add "L" & edlCatalan ' *** &H403
   colLanguage.Add "L" & edlRussian ' *** &H419
   colLanguage.Add "L" & edlCzech ' *** &H405
   colLanguage.Add "L" & edlHungarian ' *** &H40E
   colLanguage.Add "L" & edlPolish ' *** &H415
   colLanguage.Add "L" & edlJapanese ' *** &H411
   colLanguage.Add "L" & edlKorean ' *** &H412
   colLanguage.Add "L" & edlTaiwan ' *** &H404
   colLanguage.Add "L" & edlChina ' *** &H804
   colLanguage.Add "L" & edlTurkish ' *** &H41F
   colLanguage.Add "L" & edlGreek ' *** &H408
   colLanguage.Add "L" & edlBasque ' *** &H42D
   colLanguage.Add "L" & edlSlovenian ' *** &H424
   colLanguage.Add "L" & edlMalaysian ' *** &H43E
   colLanguage.Add "L" & edlAfrikaans ' *** &H436
   colLanguage.Add "L" & edlBulgarian ' *** &H402
   colLanguage.Add "L" & edlCroatian ' *** &H41A
   colLanguage.Add "L" & edlEstonian ' *** &H425
   colLanguage.Add "L" & edlLatvian ' *** &H426
   colLanguage.Add "L" & edlLithuanian ' *** &H427
   colLanguage.Add "L" & edlMacedonian ' *** &H42F
   colLanguage.Add "L" & edlRomanian ' *** &H418
   colLanguage.Add "L" & edlSerbianCyrillic ' *** &HC1A
   colLanguage.Add "L" & edlSerbianLatin ' *** &H81A
   colLanguage.Add "L" & edlByelorussian ' *** &H423
   colLanguage.Add "L" & edlSlovak ' *** &H41B
   colLanguage.Add "L" & edlUkrainian ' *** &H422
   colLanguage.Add "L" & edlIcelandic ' *** &H40F
   colLanguage.Add "L" & edlVietnamese ' *** &H42A
   colLanguage.Add "L" & edlThai ' *** &H41E

   ' *** Replace the months for the current date
   nLanguage = GetUserDefLCID()
   sMonth = ReplaceAllMonths(sMonth, nLanguage)

   If IsNumeric(sMonth) = False Then
      ' *** Replace the months for all locale
      For Each oLanguage In colLanguage
         nLanguage = Replace(oLanguage, "L", vbNullString)
         sMonth = ReplaceAllMonths(sMonth, nLanguage)
      
         If IsNumeric(sMonth) Then Exit For
      Next
   End If
   
   ' *** Create the date at the right format
   If IsNumeric(sDay) And IsNumeric(sMonth) And IsNumeric(sYear) Then
      FormatInternationalDate = Format(DateSerial(sYear, sMonth, sDay), _
          sRequiredFormat)
   Else
      FormatInternationalDate = vbNullString
   End If

EXIT_FormatInternationalDate:
   Exit Function

ERROR_FormatInternationalDate:
   FormatInternationalDate = vbNullString
   Resume EXIT_FormatInternationalDate
   
End Function


' *********************************************************************
' * Author           : Waty Thierry
' * E-Mail           : waty.thierry@vbdiamond.com
' * Web Site         : http://www.d2dsources.com
' * Date             : 07/11/2003
' * Procedure Name   : ReplaceAllMonths
' * Purpose          : Replace the all the months name for a locale
' * Parameters       :
' *                    sDate As String        Date to work
' *                    eLocale As eDateLocale Locale to change
' **********************************************************************
' * Comments         :
' * Replace the all the months name for a locale
' **********************************************************************

Private Function ReplaceAllMonths(sDate As String, eLocale As eDateLocale) As _
    String
   Dim nI         As Integer
   Dim sTmp       As String
   
   sTmp = sDate
   
   For nI = 1 To 12
      sTmp = ReplaceMonth(sTmp, eLocale, nI)
   Next
   
   ReplaceAllMonths = sTmp
End Function


' ********************************************************************
' * Author           : Waty Thierry
' * E-Mail           : waty.thierry@vbdiamond.com
' * Web Site         : http://www.d2dsources.com
' * Date             : 07/11/2003
' * Procedure Name   : ReplaceMonth
' * Purpose          : Replace the month name for a given month and Locale
' * Parameters       :
' *                    sDate As String          Date to work
' *                    eLocale As eDateLocale   Locale to use
' *                    nMonth As Integer        Month to replace
' *********************************************************************
' * Comments         :
' * Replace the month name for a given month and locale
' **********************************************************************
   
Private Function ReplaceMonth(sDate As String, eLocale As eDateLocale, _
    nMonth As Integer) As String
   If (nMonth < 1) And (nMonth > 12) Then
      ReplaceMonth = sDate
   Else
      Dim nRet             As Long
      Dim lpLCDateVar      As String
      Dim sTmp             As String
      Dim nPos             As Integer
      
      nRet = GetLocaleInfo(eLocale, LOCALE_SMONTHNAME1 + nMonth - 1, _
          lpLCDateVar, 0)
      sTmp = String$(nRet, 0)
   
      nRet = GetLocaleInfo(eLocale, LOCALE_SMONTHNAME1 + nMonth - 1, sTmp, nRet)
      nPos = InStr(sTmp, Chr$(0))
      sTmp = Left$(sTmp, nPos - 1)
      
      ReplaceMonth = Replace(sDate, sTmp, nMonth, , , vbTextCompare)
   End If
End Function



' Visit the author's VB Diamond (www.vbdiamond.com) site for many more VB6 
' routines
Waty Thierry
 
Comment and Contribute

 

 

 

 

 


(Maximum characters: 1200). You have 1200 characters left.

 

 

Sitemap
Thanks for your registration, follow us on our social networks to keep up-to-date