dsformatdatetime.bas

使用modem实现的来电显示程序,可以用参考串口编程

Attribute VB_Name = "本地化支持"
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 Long
End Type

Public Const LOCALE_SDATE = &H1D        '  date separator
Public Const LOCALE_STIME = &H1E        '  time separator

Public Const LOCALE_SYSTEM_DEFAULT = &H400
Public Const LOCALE_USER_DEFAULT = &H800
Public Const LOCALE_NOUSEROVERRIDE = &H80000000
Public Const LOCALE_USE_CP_ACP = &H40000000

' Time Flags for GetTimeFormatW.
Public Const TIME_NOMINUTESORSECONDS = &H1
Public Const TIME_NOSECONDS = &H2
Public Const TIME_NOTIMEMARKER = &H4
Public Const TIME_FORCE24HOURFORMAT = &H8

' Date Flags for GetDateFormatW.
Public Const DATE_SHORTDATE = &H1
Public Const DATE_LONGDATE = &H2
Public Const DATE_USE_ALT_CALENDAR = &H4
Public Const DATE_YEARMONTH = &H8
Public Const DATE_LTRREADING = &H10
Public Const DATE_RTLREADING = &H20

'Flags for Locale
Public Const LOCALE_SSHORTDATE As Long = &H1F
Public Const LOCALE_STIMEFORMAT As Long = &H1003

Declare Sub GetLocalTime Lib "kernel32" (lpSystemTime As SYSTEMTIME)
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

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
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 Lang As Integer

Function FormatDateAPI(MyDate As Date, Optional Y2K As Boolean = False) As String
Dim MyDateSys As SYSTEMTIME
Dim datestr As String * 255, sDateFormat As String
Dim strlen As Long

  'Convert Date to SystemTime format
   MyDateSys.wYear = Year(MyDate)
   MyDateSys.wMonth = Month(MyDate)
   MyDateSys.wDay = Day(MyDate)

   'Get the Windows Short Date string
   sDateFormat = GetLocaleString(LOCALE_SSHORTDATE)
    
   If Y2K Then 'Force 4 digits for year (Y2K compliance)
      If InStr(1, sDateFormat, "yyyy") Then
         'year is OK, do nothing
      ElseIf InStr(1, sDateFormat, "yyy") Then
         'Windows accepts this AND treats as 'yyyy'
         Replace sDateFormat, "yyy", "yyyy"
      ElseIf InStr(1, sDateFormat, "yy") Then
         Replace sDateFormat, "yy", "yyyy"
      ElseIf InStr(1, sDateFormat, "y") Then
         'Windows accepts this AND treats as 'yy'
         Replace sDateFormat, "y", "yyyy"
      End If
   End If
   'Format date using Windows Short Date AND Y2K fix (if used)
   strlen = GetDateFormat(LOCALE_SYSTEM_DEFAULT, 0, MyDateSys, sDateFormat, datestr, Len(datestr))
   FormatDateAPI = Left(datestr, IIf(strlen = 0, 0, strlen - 1))
   
End Function
Function FormatDateSys(mYear As Byte, mMonth As Byte, mDay As Byte, Optional Y2K As Boolean = False) As String
Dim MyDateSys   As SYSTEMTIME
Dim datestr     As String * 255, sDateFormat As String
Dim strlen      As Long


  'Convert Date to SystemTime format
   MyDateSys.wYear = IIf(mYear >= 0 And mYear < 80, 2000 + mYear, 1900 + mYear)
   MyDateSys.wMonth = mMonth
   MyDateSys.wDay = mDay

   'Get the Windows Short Date string
   sDateFormat = GetLocaleString(LOCALE_SSHORTDATE)
   If Y2K Then
    If InStr(1, sDateFormat, "yyyy") Then
       'year is OK, do nothing
    ElseIf InStr(1, sDateFormat, "yyy") Then
       'Windows accepts this AND treats as 'yyyy'
       Replace sDateFormat, "yyy", "yyyy"
    ElseIf InStr(1, sDateFormat, "yy") Then
       Replace sDateFormat, "yy", "yyyy"
    ElseIf InStr(1, sDateFormat, "y") Then
       'Windows accepts this AND treats as 'yy'
       Replace sDateFormat, "y", "yyyy"
    End If
   End If
   'Format date using Windows Short Date AND Y2K fix (if used)
   strlen = GetDateFormat(LOCALE_SYSTEM_DEFAULT, 0, MyDateSys, sDateFormat, datestr, Len(datestr))
   FormatDateSys = Left(datestr, IIf(strlen = 0, 0, strlen - 1))
   If FormatDateSys = "" Then
   If Y2K Then
    FormatDateSys = "----------"
   Else
    FormatDateSys = "--------"
   End If
   End If
End Function
Function FormatTimeAPI(MyDate As Date) As String
Dim MyDateSys As SYSTEMTIME
Dim timestr As String * 255
Dim strlen As Long

  'Convert Date to SystemTime format
   MyDateSys.wHour = Hour(MyDate)
   MyDateSys.wMinute = Minute(MyDate)
   MyDateSys.wSecond = Second(MyDate)

  'Format time using Windows Time Format
   strlen = GetTimeFormat(LOCALE_SYSTEM_DEFAULT, 0, MyDateSys, GetLocaleString(LOCALE_STIMEFORMAT), timestr, Len(timestr))
   FormatTimeAPI = Left(timestr, IIf(strlen = 0, 0, strlen - 1))

End Function
Function FormatTimeSys(mHour As Byte, mMinute As Byte, mSecond As Byte) As String
Dim MyDateSys As SYSTEMTIME
Dim timestr As String * 255
Dim strlen As Long

  'Convert Date to SystemTime format
   MyDateSys.wHour = mHour
   MyDateSys.wMinute = mMinute
   MyDateSys.wSecond = mSecond

  'Format time using Windows Time Format
   strlen = GetTimeFormat(LOCALE_SYSTEM_DEFAULT, 0, MyDateSys, GetLocaleString(LOCALE_STIMEFORMAT), timestr, Len(timestr))
   
   FormatTimeSys = Left(timestr, IIf(strlen = 0, 0, strlen - 1))
   
   If FormatTimeSys = "" Then FormatTimeSys = "--------"
End Function
Function mDateHeader() As String
 
   mDateHeader = mDateFormat
   Select Case Lang 'first the year substitutions
      Case 0: Replace mDateHeader, "y", "J"
      Case 2000 To 5000: Replace mDateHeader, "y", "a"
   End Select
   Select Case Lang 'AND the day substitutions
      Case 0: Replace mDateHeader, "d", "T"
      Case 3000: Replace mDateHeader, "d", "J"
      Case 4000: Replace mDateHeader, "d", "g"
   End Select
   
End Function
Function mTimeHeader() As String
   
   mTimeHeader = mTimeFormat
   Select Case Lang
      Case 0: Replace mTimeHeader, "H", "S"
      Case 4000: Replace mTimeHeader, "H", "O"
   End Select
   
End Function
Function mDateFormat() As String
 
  ' If OnceOnlyDate <> "" Then
  '    mDateFormat = OnceOnlyDate
  '    Exit Function
  ' End If

   mDateFormat = LCase(GetLocaleString(LOCALE_SSHORTDATE))
    
   'Force 4 digits for year (Y2K compliance)
   If InStr(1, mDateFormat, "yyyy") Then
      'year is OK, do nothing
   ElseIf InStr(1, mDateFormat, "yyy") Then
      'Windows accepts this AND treats as 'yyyy'
      Replace mDateFormat, "yyy", "yyyy"
   ElseIf InStr(1, mDateFormat, "yy") Then
      Replace mDateFormat, "yy", "yyyy"
   ElseIf InStr(1, mDateFormat, "y") Then
      Replace mDateFormat, "y", "yyyy"
   End If

   On Error GoTo DateError
   Dim MyDate As String
   MyDate = Format(Now, mDateFormat)
   Exit Function
DateError:
   If InStr(mDateFormat, "d") = 1 Then
      mDateFormat = "dd/mm/yyyy"
   Else
      mDateFormat = "mm/dd/yyyy"
   End If
  ' OnceOnlyDate = mDateFormat
   MsgBox "Illegal value detected in regional date configuration: " & Chr(13) _
         & GetLocaleString(&H1F) & Chr(13) _
         & "Using default value of " & mDateFormat, vbCritical

End Function
Function mTimeFormat() As String
   
   ' If OnceOnlyTime <> "" Then
   '   mTimeFormat = OnceOnlyTime
   '   Exit Function
   ' End If
   
   mTimeFormat = GetLocaleString(LOCALE_STIMEFORMAT)
   'we expect one or more or following
   ' h hh H HH m mm s ss t tt
   ': (or other time separator)
   'First replace the t or tt with ampm.
   'ampm gets replaced by system string literals for am AND pm.
   If InStr(1, mTimeFormat, "tt", vbBinaryCompare) Then
      Replace mTimeFormat, "tt", "ampm"
   ElseIf InStr(1, mTimeFormat, "t", vbBinaryCompare) Then
      Replace mTimeFormat, "t", "ampm"
   End If
   'lower case hh or h means user wants 12 hour system so append 'ampm'
   'if not already set FROM t/tt above. This forces VB to 12 hr format.
   'if you don't want a/am or p/pm set literals blank in regional settings
   If InStr(1, mTimeFormat, "hh", vbBinaryCompare) And InStr(mTimeFormat, "ampm") = 0 Then
      mTimeFormat = mTimeFormat & (" ampm")
   ElseIf InStr(1, mTimeFormat, "h", vbBinaryCompare) And InStr(mTimeFormat, "ampm") = 0 Then
      mTimeFormat = mTimeFormat & (" ampm")
   End If

   On Error GoTo TimeError
   Dim MyTime As String
   MyTime = Format(Now, mTimeFormat)
   Exit Function

TimeError:
   mTimeFormat = "hh:mm:ss"
   'OnceOnlyTime = mTimeFormat
   MsgBox "Illegal value detected in regional time configuration: " & Chr(13) _
         & GetLocaleString(&H1003) & Chr(13) _
         & "Using default value of " & mTimeFormat, vbCritical

End Function
Private Sub Replace(ByRef sOriginal As String, ByVal sLookfor As String, ByVal sReplaceBy As String)
'
' Private internal routine for replacing strings
'
    Dim lStart As Long
    Dim lReplaceBy As Long
    
    On Error GoTo vbErrorHandler
    
    lReplaceBy = Len(sReplaceBy)
    
    lStart = 1
    
    Do
        lStart = InStr(lStart, sOriginal, sLookfor, vbTextCompare)
        If lStart > 0 Then
            sOriginal = Left$(sOriginal, lStart - 1) & sReplaceBy & Mid$(sOriginal, lStart + Len(sLookfor))
            lStart = lStart + lReplaceBy
        Else
            Exit Do
        End If
    Loop
    Exit Sub
    
vbErrorHandler:
    Err.Raise Err.Number, "CGLocaleInfo Replace", Err.Description
End Sub
Public Function GetLocaleString(ByVal lLocaleNum As Long) As String
'
' Generic routine to get the locale string FROM the Operating system.
'
    Dim lBuffSize As String
    Dim sBuffer As String
    Dim lRet As Long
'
' Create a string buffer large enough to hold the returned value, 256 should
' be more than enough
'
    lBuffSize = 256
    sBuffer = String$(lBuffSize, vbNullChar)
'
' Get the information FROM the registry
'
    lRet = GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, lLocaleNum, sBuffer, lBuffSize)
'
' If lRet > 0 then success - lret is the size of the string returned
'
    If lRet > 0 Then
        GetLocaleString = Left$(sBuffer, lRet - 1)
    End If
End Function