Đánh giá chủ đề:
  • 1 Votes - 5 Average
  • 1
  • 2
  • 3
  • 4
  • 5
[Thủ Thuật] Thiết lập tự động Windows Regional ngày/tháng, định dạng tiền, số
#1
Thiết lập tự động định dạng ngày/tháng, phân cách hàng ngàn của tiền tệ, số cho hệ thống Windows từ VBA. 
—————————————————————————————————————

Demo sau đây giúp bạn thiết lập lại các kiểu định dạng ngày/tháng/năm cũng như kiểu tiền tệ, kiểu số cho hệ thống máy tính để phù hợp với định dạng trong ứng dụng Access của bạn. Thiết lập này chạy tự động khi mở ứng dụng, bạn không cần phải đi thiết lập thủ công cho từng máy tính - thay đổi trong Control Panel - Region and Language Setting.
Để thiết lại thông tin của hệ thống Windows, bạn phải dùng tới các hàm API như: SetLocaleInfo (), GetLocaleInfo ()
Dưới đây là code cho hàm ChangeSysDatNumCur(). Copy đoạn code này vào module.

Mã PHP:
Option Explicit
Public Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As LongByVal LCType As LongByVal lpLCData As String) As Boolean
Public Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As LongByVal LCType As LongByVal lpLCData As StringByVal cchData As Long) As Long
Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongByVal wMsg As LongByVal wParam As LongByVal lParam As Long) As Long

Public Const LOCALE_ICENTURY = &H24
Public Const LOCALE_ICOUNTRY = &H5
Public Const LOCALE_ICURRDIGITS = &H19
Public Const LOCALE_ICURRENCY = &H1B
Public Const LOCALE_IDATE = &H21
Public Const LOCALE_IDAYLZERO = &H26
Public Const LOCALE_IDEFAULTCODEPAGE = &HB
Public Const LOCALE_IDEFAULTCOUNTRY = &HA
Public Const LOCALE_IDEFAULTLANGUAGE = &H9
Public Const LOCALE_IDIGITS = &H11
Public Const LOCALE_IINTLCURRDIGITS = &H1A
Public Const LOCALE_ILANGUAGE = &H1
Public Const LOCALE_ILDATE = &H22
Public Const LOCALE_ILZERO = &H12
Public Const LOCALE_IMEASURE = &HD
Public Const LOCALE_IMONLZERO = &H27
Public Const LOCALE_INEGCURR = &H1C
Public Const LOCALE_INEGSEPBYSPACE = &H57
Public Const LOCALE_INEGSIGNPOSN = &H53
Public Const LOCALE_INEGSYMPRECEDES = &H56
Public Const LOCALE_IPOSSEPBYSPACE = &H55
Public Const LOCALE_IPOSSIGNPOSN = &H52
Public Const LOCALE_IPOSSYMPRECEDES = &H54
Public Const LOCALE_ITIME = &H23
Public Const LOCALE_ITLZERO = &H25
Public Const LOCALE_NOUSEROVERRIDE = &H80000000
Public Const LOCALE_S1159 = &H28
Public Const LOCALE_S2359 = &H29
Public Const LOCALE_SABBREVCTRYNAME = &H7
Public Const LOCALE_SABBREVDAYNAME1 = &H31
Public Const LOCALE_SABBREVDAYNAME2 = &H32
Public Const LOCALE_SABBREVDAYNAME3 = &H33
Public Const LOCALE_SABBREVDAYNAME4 = &H34
Public Const LOCALE_SABBREVDAYNAME5 = &H35
Public Const LOCALE_SABBREVDAYNAME6 = &H36
Public Const LOCALE_SABBREVDAYNAME7 = &H37
Public Const LOCALE_SABBREVLANGNAME = &H3
Public Const LOCALE_SABBREVMONTHNAME1 = &H44
Public Const LOCALE_SCOUNTRY = &H6
Public Const LOCALE_SCURRENCY = &H14
Public Const LOCALE_SDATE = &H1D
Public Const LOCALE_SDECIMAL = &HE
Public Const LOCALE_SENGCOUNTRY = &H1002
Public Const LOCALE_SENGLANGUAGE = &H1001
Public Const LOCALE_SGROUPING = &H10
Public Const LOCALE_SINTLSYMBOL = &H15
Public Const LOCALE_SLANGUAGE = &H2
Public Const LOCALE_SLIST = &HC
Public Const LOCALE_SLONGDATE = &H20
Public Const LOCALE_SMONDECIMALSEP = &H16
Public Const LOCALE_SMONTHOUSANDSEP = &H17
Public Const LOCALE_SNATIVECTRYNAME = &H8
Public Const LOCALE_SNATIVEDIGITS = &H13
Public Const LOCALE_SNATIVELANGNAME = &H4
Public Const LOCALE_SNEGATIVESIGN = &H51
Public Const LOCALE_SPOSITIVESIGN = &H50
Public Const LOCALE_SSHORTDATE = &H1F
Public Const LOCALE_STHOUSAND = &HF
Public Const LOCALE_STIME = &H1E
Public Const LOCALE_STIMEFORMAT = &H1003

Public Const WM_SETTINGCHANGE = &H1A
Public Const HWND_BROADCAST = &HFFFF&

'Nhap kieu dinh dang Ngay, So
Public Const FormatCurrSymb = "Vnd "             '
Ky tu dau cua dang Currency
Public Const FormatDec ","                  'Phan cach so thap phan
Public Const FormatThou = "."                 '
Phan cach hang ngan
Public Const FormatSDate "dd-MM-yyyy"       'Kieu Short Date
Public Const FormatLDate = "dd MMMM yyyy"     '
Kieu Long Date

Public Sub ChangeSysDatNumCur()
   Dim lLocal As Long
   Dim LenDate 
As LongLenCur As LongLenNum As Long
   Dim dwLCID 
As Long
   Dim BufDate 
As String 1024BufCur As String 1024BufNum As String 1024

   On Error 
GoTo ChangeSysDatNumCur_Error

   lLocal 
GetSystemDefaultLCID()
   LenDate GetLocaleInfo(lLocalLOCALE_SSHORTDATEBufDateLen(BufDate))
   LenCur GetLocaleInfo(lLocalLOCALE_SMONTHOUSANDSEPBufCurLen(BufCur))
   LenNum GetLocaleInfo(lLocalLOCALE_STHOUSANDBufNumLen(BufNum))
   If Not Left$(BufDateLenDate 1) = FormatSDate Or Not Left$(BufCurLenCur 1) = FormatThou Or Not Left$(BufNumLenNum 1) = FormatThou Then   'Kiem tra ngay he thong co cung dinh dang mong muon ko?
       dwLCID = GetSystemDefaultLCID()
       If SetLocaleInfo(dwLCID, LOCALE_SSHORTDATE, FormatSDate) = False Then  '
Thiet lap thu xem co loi ko?
           MsgBox "Khong doi duoc dinh dang ngay, so cua he thong."64"Lien he nhan vien Quan tri he thong"
           Exit Sub
       Else
           Change_LocaleInfo
           MsgBox 
"Ung dung se tu khoi dong lai de cac thiet lap co hieu luc."vbInformation"Thông báo"
           RestartAccessApp.Restart
       End 
If
   Else
       MsgBox 
"Dinh dang Ngay/Thang, kieu Tiên te, kieu So phu hop voi ung dung, khong can thiet lap lai." vbCrLf _
              
"- Kieu ngày: " FormatSDate vbCrLf _
              
"- Kieu so  : 1" FormatThou "000" FormatDec "00"vbInformation"Chuc mung!"
       DoCmd.OpenForm "frmMain"
       DoCmd.Close acForm"frmSplash"
       Exit Sub
   End 
If


ChangeSysDatNumCur_Error:
   MsgBox "Loi khong xac dinh No. " Err.Number _
          
" trong thu tuc [ChangeSysDatNumCur] cua form khoi dong. " _
          
vbCrLf vbCrLf Err.Description64"Ung dung Access"
End Sub

Sub Change_LocaleInfo
()

   Dim LCID As Long
   LCID 
GetSystemDefaultLCID()

   'Thiet lap kieu Ngay/Thang
   SetLocaleInfo LCID, LOCALE_SLONGDATE, FormatLDate
   SetLocaleInfo LCID, LOCALE_SSHORTDATE, FormatSDate
   
   '
Thiet lap kieu tien Currency
   SetLocaleInfo LCID
LOCALE_SCURRENCYFormatCurrSymb
   SetLocaleInfo LCID
LOCALE_SMONDECIMALSEPFormatDec
   SetLocaleInfo LCID
LOCALE_SMONTHOUSANDSEPFormatThou
   
   
'Thiet lap kieu so Number
   SetLocaleInfo LCID, LOCALE_SDECIMAL, FormatDec
   SetLocaleInfo LCID, LOCALE_STHOUSAND, FormatThou
   
   PostMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0

End Sub 

- Bạn muốn thay đổi kiểu định dạng thì thay đổi ở phần khai báo Hằng: FormatSDate, FormatDec...
[Hình: 38404423752_3015dfdfe3_o.png]

- Để thay đổi hệ thống có hiệu lực thì buộc phải khởi động lại ứng dụng Access của bạn. Bản thân code VBA Access không thể khởi động lại chính nó vì khi ứng dụng nó đóng (Application.Quit) thì làm sao chạy các code kế tiếp để khởi động lại chính nó. Do vậy phải thông qua một công cụ khác là lệnh Shell  để chạy file .bat của DOS. Tác giả Renaud Bompuis đã có đoạn code rất hay thực hiện việc vừa Compact và khởi động lại chính ứng dụng Access nó đang chạy. Tôi có sử dụng code này trong demo.
- Chú ý để đoạn code khởi động lại ứng dụng Access chạy thì bạn phải "bỏ chọn" tính năng "Compact On Close" của Access.

Sau đây là đoạn code để khởi động và nén ứng dụng Access. Copy vào module đặt tên là "RestartAccessApp". 

Mã PHP:
'-----------------------------------------------------------------------------
Utilities from http://blog.nkadesign.com/microsoft-access/
' (c) Renaud Bompuis, 2008-2009
Licensed under the Creative Commons Attribution License
' http://creativecommons.org/licenses/by/3.0/
http://creativecommons.org/licenses/by/3.0/legalcode
'-----------------------------------------------------------------------------

Option Compare Database
Option Explicit

Time out set to 60 iterationsafter which the batch file should delete itself
Private Const TIMEOUT 60

Public Sub Restart(Optional Compact As Boolean False)
   Dim scriptpath As String
   
   
' Construct the full path of our temporary batch file
   scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat"
   
   ' 
if the script already existsthen check it isn't an old remnant
   ' 
that has passed it's timeout.
   If Dir(scriptpath, vbNormal) <> "" Then
       If DateAdd("s", TIMEOUT * 2, FileDateTime(scriptpath)) < Date Then
           ' 
We've passed twice the batch file timeout, giving ample time for
           ' 
it to exectuteso if it's still there, it's most probably a dud
           Kill scriptpath
       Else
           
' Timeout hasn't expired beyond the acceptable limitso it's probably
           ' 
still activejust try to close the application again
           Application
.Quit acQuitSaveAll
           Exit Sub
       End 
If
   End If
   
   
' Construct the batch file
   ' 
Note that the TIMEOUT value is only used as a loop counter and
   ' we do not really count elapsed time in the batch file.
   ' 
The ping command takes some time to load and start and even though
   
' we set its timeout to 100ms, it will take much longer than that to
   ' 
execute.
   ' If we've been asked to comnpact the databasewe launch the database
   
' using the /compact command line switch
   Dim s As String
   s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf
   s = s & "SET /a counter=0" & vbCrLf
   s = s & ":CHECKLOCKFILE" & vbCrLf
   s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf
   s = s & "SET /a counter+=1" & vbCrLf
   s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf
   s = s & "IF EXIST ""%~f2.%4"" GOTO CHECKLOCKFILE" & vbCrLf
   If Compact Then
       s = s & """%~f1"" ""%~f2.%3"" /compact" & vbCrLf
   End If
   s = s & "start "" "" ""%~f2.%3""" & vbCrLf
   s = s & ":CLEANUP" & vbCrLf
   s = s & "del %0"
   
   ' 
Write batch file
   Dim intFile 
As Integer
   intFile 
FreeFile()
   Open scriptpath For Output As #intFile
   Print #intFile, s
   Close #intFile
   
       
   
' Create the arguments to be passed to the script
   ' 
Here we pass it the full path to the database minus the extension which we pass separately
   
' this is done so that we can reconstruct the path to the lock file easily in the script.
   ' 
The extension to the lock file is also passed as a third argument.
   Dim dbname As Stringext As Stringlockext As Stringaccesspath As String
   Dim idx 
As Integer
   
   
' Get the path to the msaccess executable, wherever that is
   accesspath = SysCmd(acSysCmdAccessDir) & "msaccess.exe"
   
   ' 
Find the extensionstarting from the end
   For idx 
Len(CurrentProject.FullNameTo 1 Step -1
       If Mid
(CurrentProject.FullNameidx1) = "." Then Exit For
   Next idx
   dbname 
Left(CurrentProject.FullNameidx 1)
   ext Mid(CurrentProject.FullNameidx 1)
   
   
' Depending on the database extension, determine its lock file extension
   If Left(ext, 2) = "ac" Then
       lockext = "laccdb"
   Else
       lockext = "ldb"
   End If
   
   ' 
Call the batch file
   s 
"""" scriptpath """ """ accesspath """ """ dbname """ " ext " " lockext
   Shell s
vbHide
   
   
' Close our application
  Application.Quit acQuitSaveAll
End Sub 

- Để sử dụng hàm này, trong Form bạn dùng code: RestartAccessApp.Restart True

------------------------------------------------------------------------------------------------------------------
Kết quả:

[Hình: 38403832322_c16bedfa1d_o.png]  [Hình: 38403832452_3f66c5503f_o.png]

[Hình: 38403832642_9bcfe9f8e3_o.png]

Bạn thay đổi các kiểu định dạng trong Windows để test thử đi nhé. Chạy Form frmSplash trong demo.

Link file demo: http://www.mediafire.com/file/0s2hvcu4fl...NumCur.mdb


File đính kèm
.zip   ChangeSysDateNumCur.zip (Kích cỡ: 37.26 KB / Tải về: 14)
Chữ ký của ongke0711 If you BORN poor, it's not your mistake. But if you DIE poor, It's your mistake!
ღღღღღTài sản của ongke0711 (View All Items) ღღღღღ
Reply
Những người đã cảm ơn maidinhdan , cpucloi , kiepgiangho79 , huuduy.duy , Che_Guevara , Noname , vuthaiha90 , ketoan_it
#2
Em cảm ơn bác ạ. Rất chi tiết. Em đã áp dụng thành công vào chương trình của em (sửa lại: dd/MM/yyyy; bỏ qua các Msgbox báo thành công, giữ lại Msgbox báo lỗi (vì người dùng lại phải ấn OK thêm lần nữa mới vào được form Startup)) và nó nén chương trình của em lại khá tốt: từ 50Mb xuống 22,6Mb. Em cảm ơn ạ!
Chữ ký của vuthaiha90 vuthaiha90,gia nhập Thủ Thuật Access từ 26-02 -16.
Reply
Những người đã cảm ơn


Có thể liên quan đến chủ đề
Chủ đề: Tác giả Trả lời: Xem: Bài mới nhất
  Function check các biến chưa đóng mrsiro 0 101 13-10-18, 05:44 PM
Bài mới nhất: mrsiro
  [Hỏi] Click vào button mở form mới ngay dưới button đó mrsiro 1 159 22-09-18, 12:04 PM
Bài mới nhất: lmthu
  [Hỏi] Mã Số Nhân Viên Tự Động Tăng pherotao 9 1,007 24-12-17, 02:00 AM
Bài mới nhất: pherotao
  [Hỏi] Căn Chỉnh Form Tự Động pherotao 9 1,099 21-12-17, 11:38 PM
Bài mới nhất: ongke0711
  [Hỏi] Định dạng dd/mm/yyyy và 123.456.789,00 trong vba vuthaiha90 2 601 15-11-17, 12:17 AM
Bài mới nhất: ongke0711

Chuyển nhanh:


User(s) browsing this thread: 1 Guest(s)
Diễn Đàn Thơ Văn Thi Ẩm Lâu|Nhà Hàng Sông Thơ| PMA Nha Trang| Gỗ Acrylic Không Đường Line