mchangesystemdate.bas

需要控件：Active Report 2.0(专业报表控件破解版)2.0下的ardespro2.dll和arpro2.dll ARVIEW2.OCX等文件。即可打开源代码。

Attribute VB_Name = "mChangeSystemDate"
Option Explicit

'-----------------------------------------------------------------------------------------
' Copyright ?1996-2004 VBnet, Randy Birch. All Rights Reserved Worldwide.
'        Terms of use http://vbnet.mvps.org/terms/pages/terms.htm
'-----------------------------------------------------------------------------------------

Public Const LOCALE_SLANGUAGE As Long = &H2     '语言的当地名称
Public Const LOCALE_SSHORTDATE As Long = &H1F   '短日期格式
Public Const LOCALE_SLONGDATE As Long = &H20    '长日期格式
Public Const DATE_LONGDATE As Long = &H2
Public Const DATE_SHORTDATE As Long = &H1
Public Const HWND_BROADCAST As Long = &HFFFF&
Public Const WM_SETTINGCHANGE As Long = &H1A

Public Declare Function PostMessage Lib "user32" _
   Alias "PostMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long

Public Declare Function EnumDateFormats Lib "kernel32" _
   Alias "EnumDateFormatsA" _
  (ByVal lpDateFmtEnumProc As Long, _
   ByVal Locale As Long, _
   ByVal dwFlags As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)

Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long

Public 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

Public Declare Function SetLocaleInfo Lib "kernel32" _
    Alias "SetLocaleInfoA" _
   (ByVal Locale As Long, _
    ByVal LCType As Long, _
    ByVal lpLCData As String) As Long


Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, _
                                  ByVal dwLCType As Long) As String

   Dim sReturn As String
   Dim R As Long

  'call the function passing the Locale type
  'variable to retrieve the required size of
  'the string buffer needed
   R = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
    
  'if successful..
   If R Then
    
     'pad the buffer with spaces
      sReturn = Space$(R)
       
     'and call again passing the buffer
      R = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
     
     'if successful (r > 0)
      If R Then
      
        'r holds the size of the string
        'including the terminating null
         GetUserLocaleInfo = Left$(sReturn, R - 1)
      
      End If
   
   End If
    
End Function


Private Function StringFromPointer(lpString As Long) As String

   Dim POS As Long
   Dim buffer As String
   
  'pad a string to hold the data
   buffer = Space$(128)
   
  'copy the string pointed to by the return value
   CopyMemory ByVal buffer, lpString, ByVal Len(buffer)
   
  'remove the trailing null and trim
   POS = InStr(buffer, Chr$(0))
   
   If POS Then
      StringFromPointer = Left$(buffer, POS - 1)
   End If

End Function