'MsgBox Tiêìng Viêòt
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal CodeNo As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal ParenthWnd As LongPtr, ByVal ChildhWnd As LongPtr, ByVal ClassName As String, ByVal Caption As String) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As Any) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Boolean
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function MessageBoxW Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal uType As Long) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal U As Long, ByVal S As Long, ByVal c As Long, ByVal OP As Long, ByVal cp As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare PtrSafe Function SetWindowTextW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function MsgBoxTimeoutW Lib "user32" Alias "MessageBoxTimeoutW" (ByVal hWnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#Else
Private Declare Function MsgBoxTimeoutW Lib "user32" Alias "MessageBoxTimeoutW" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( ByVal hHook As Long, ByVal CodeNo As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( ByVal hHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal className As String, ByVal Caption As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" ( ByVal lpFileName As Any) As Long
Private Declare Function SetWindowPos Lib "user32" ( ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" ( ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" ( ByVal hwnd As Long) As Long
Private Declare Function DestroyCursor Lib "user32" ( ByVal hCursor As Long) As Boolean
Private Declare Function IsWindow Lib "user32" ( ByVal hwnd As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( ByVal hObject As Long) As Long
Private Declare Function MessageBoxW Lib "user32.dll" ( ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( ByVal h As Long, ByVal W As Long, ByVal e As Long, ByVal o As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal s As Long, ByVal c As Long, ByVal OP As Long, ByVal CP As Long, ByVal q As Long, ByVal PAF As Long, ByVal f As String) As Long
Private Declare Function SetWindowTextW Lib "user32" ( ByVal hwnd As Long, ByVal lpString As Long) As Long
#End If
Public Type Var64
#If Win64 Then
Long As LongPtr
#Else
Long As Long
#End If
End Type
Public hDlgHook As Var64, hDlgHWnd As Var64
Private Const WM_SETFONT = &H30
Private Const MB_TASKMODAL = &H2000&
Public hFont&
Private Const FONT_FACE = "Tahoma"
Sub Kieudulieu()
Dim Ten As String 'Khai báo tên ngýõÌi là chuôÞi
Dim TUOi As Integer 'Khai báo tuôÒi là sôì nguyên
Dim Chieucao As Single 'Khai báo chiêÌu cao là sôì thâòp phân
TUOi = 22 'Gán týÌng giá triò Tuoi, Chieucao, Ten
Chieucao = 1.74
Ten = "NguyêÞn Vãn Ðýìc"
Alert VietnameseUTF8("Hoò và tên: " & Ten & Chr(13) & "TuôÒi là " & TUOi & _
" tuôÒi" & Chr(13) & "ChiêÌu Cao " & Chieucao & " (m)", True)
End Sub
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
' Last Edit: 09/03/2020 17:01
Public Function Alert(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String = "Thông báo", Optional ByVal hWnd& = &H0, Optional ByVal Timeout& = 10) As VbMsgBoxResult
If Timeout <= 0 Then Timeout = 3600
#If Win64 Then
hDlgHook.Long = SetWindowsHookEx(5, AddressOf HookProcMsgBox, Application.HinstancePtr, GetCurrentThreadId())
#Else
hDlgHook.Long = SetWindowsHookEx(5, AddressOf HookProcMsgBox, Application.hInstance, GetCurrentThreadId())
#End If
Alert = MsgBoxTimeoutW(hWnd, VBA.StrConv(Prompt, 64), VBA.StrConv(Title, 64), Buttons Or MB_TASKMODAL, 0&, Timeout * 1000)
DeleteObject hFont
End Function
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
#If Win64 Then
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam^, ByVal lParam^)
#Else
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam&, ByVal lParam&)
#End If
Dim hStatic1 As Var64, hStatic2 As Var64, hButton As Var64, nCaption As String, lCaption As String
HookProcMsgBox = CallNextHookEx(hDlgHook.Long, nCode, wParam, lParam)
If nCode = 5 Then
hFont = CreateFont(13, 0, 0, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, FONT_FACE)
hStatic1.Long = FindWindowEx(wParam, 0&, "Static", VBA.vbNullString)
hStatic2.Long = FindWindowEx(wParam, hStatic1.Long, "Static", VBA.vbNullString)
hDlgHWnd.Long = wParam
Call SetWindowPos(hDlgHWnd.Long, -1, 0, 0, 0, 0, &H2 Or &H1)
If hStatic2.Long = 0 Then hStatic2.Long = hStatic1.Long
SendMessage hStatic2.Long, WM_SETFONT, hFont, ByVal 1&
'--------------------------------------
nCaption = "&X" & VBA.ChrW$(225) & "c nh" & VBA.ChrW$(226) & "n"
lCaption = "OK": GoSub Send
nCaption = "&C" & VBA.ChrW$(243)
lCaption = "&Yes": GoSub Send
nCaption = "&Kh" & VBA.ChrW$(244) & "ng"
lCaption = "&No": GoSub Send
nCaption = "&H" & VBA.ChrW$(7911) & "y"
lCaption = "Cancel": GoSub Send
nCaption = "&Th" & VBA.ChrW$(7917) & " l" & VBA.ChrW$(7841) & "i"
lCaption = "&Retry": GoSub Send
nCaption = "&B" & VBA.ChrW$(7887) & " qua"
lCaption = "&Ignore": GoSub Send
nCaption = "H" & VBA.ChrW$(7911) & "&y b" & VBA.ChrW$(7887)
lCaption = "&Abort": GoSub Send
nCaption = "Tr" & VBA.ChrW$(7907) & " &gi" & VBA.ChrW$(250) & "p"
lCaption = "Help": GoSub Send
'--------------------------------------
UnhookWindowsHookEx hDlgHook.Long
End If
Exit Function
Send:
hButton.Long = FindWindowEx(wParam, 0&, "Button", lCaption)
SendMessage hButton.Long, WM_SETFONT, hFont, 0
SetWindowTextW hButton.Long, StrPtr(nCaption)
Return
End Function
'---------------------------------------------
' ChuyêÒn ðôÒi Tiêìng viêòt giýÞa Unicode và UTF-8
' Last Edit: 12/03/2020 15:16
Public Function VietnameseUTF8(ByVal Text As String, Optional ByVal Reverse As Boolean) As String
Dim Utf8 As Variant, Char As Variant, i As Long
'' Const Acute = "ì"
'' Const graveAccent = "Ì"
'' Const questionMark = "Ò"
'' Const tilde = "Þ"
'' Const Dot = "ò"
'' "Á á à À í Í é É È è ó Ó Ú ú ù Ù ê Ê â Â ô Ô Ð "
'' "ã Ã ý Ý õ Õ Yì yì ð"
Char = VBA.Array(ChrW(195), ChrW(227), ChrW(258), ChrW(259), ChrW(204), ChrW(236), ChrW(210), ChrW(242), ChrW(213), ChrW(245), _
ChrW(7854), ChrW(7855), ChrW(7856), ChrW(7857), ChrW(7858), ChrW(7859), ChrW(7860), ChrW(7861), ChrW(7862), ChrW(7863), _
ChrW(7844), ChrW(7845), ChrW(7846), ChrW(7847), ChrW(7848), ChrW(7849), ChrW(7850), ChrW(7851), ChrW(7852), ChrW(7853), _
ChrW(7870), ChrW(7871), ChrW(7872), ChrW(7873), ChrW(7874), ChrW(7875), ChrW(7876), ChrW(7877), ChrW(7878), ChrW(7879), _
ChrW(7888), ChrW(7889), ChrW(7890), ChrW(7891), ChrW(7892), ChrW(7893), ChrW(7894), ChrW(7895), ChrW(7896), ChrW(7897), _
ChrW(7898), ChrW(7899), ChrW(7900), ChrW(7901), ChrW(7902), ChrW(7903), ChrW(7904), ChrW(7905), ChrW(7906), ChrW(7907), _
ChrW(7912), ChrW(7913), ChrW(7914), ChrW(7915), ChrW(7916), ChrW(7917), ChrW(7918), ChrW(7919), ChrW(7920), ChrW(7921), _
ChrW(7842), ChrW(7843), ChrW(7840), ChrW(7841), ChrW(7866), ChrW(7867), ChrW(7868), ChrW(7869), ChrW(7864), ChrW(7865), _
ChrW(7880), ChrW(7881), ChrW(296), ChrW(297), ChrW(7882), ChrW(7883), ChrW(7886), ChrW(7887), ChrW(7884), ChrW(7885), _
ChrW(7910), ChrW(7911), ChrW(360), ChrW(361), ChrW(7908), ChrW(7909), _
ChrW(7922), ChrW(7923), ChrW(7926), ChrW(7927), ChrW(7928), ChrW(7929), ChrW(7924), ChrW(7925), ChrW(273))
Utf8 = VBA.Array("AÞ", "aÞ", "Ã", "ã", "IÌ", "iÌ", "OÌ", "oÌ", "OÞ", "oÞ", _
"Ãì", "ãì", "ÃÌ", "ãÌ", "ÃÒ", "ãÒ", "ÃÞ", "ãÞ", "Ãò", "ãò", _
"Âì", "âì", "ÂÌ", "âÌ", "ÂÒ", "âÒ", "ÂÞ", "âÞ", "Âò", "âò", _
"Êì", "êì", "ÊÌ", "êÌ", "ÊÒ", "êÒ", "ÊÞ", "êÞ", "Êò", "êò", _
"Ôì", "ôì", "ÔÌ", "ôÌ", "ÔÒ", "ôÒ", "ÔÞ", "ôÞ", "Ôò", "ôò", _
"Õì", "õì", "ÕÌ", "õÌ", "ÕÒ", "õÒ", "ÕÞ", "õÞ", "Õò", "õò", _
"Ýì", "ýì", "ÝÌ", "ýÌ", "ÝÒ", "ýÒ", "ÝÞ", "ýÞ", "Ýò", "ýò", _
"AÒ", "aÒ", "Aò", "aò", "EÒ", "eÒ", "EÞ", "eÞ", "Eò", "eò", _
"IÒ", "iÒ", "IÞ", "iÞ", "Iò", "iò", "OÒ", "oÒ", "Oò", "oò", _
"UÒ", "uÒ", "UÞ", "uÞ", "Uò", "uò", _
"YÌ", "yÌ", "YÒ", "yÒ", "YÞ", "yÞ", "Yò", "yò", "ð")
If Reverse Then
For i = UBound(Char) To LBound(Char) Step -1: Text = VBA.Replace(Text, Utf8(i), Char(i)): Next i
Char = VBA.Array(ChrW(221), ChrW(253), ChrW(431), ChrW(432), ChrW(416), ChrW(417))
Utf8 = VBA.Array("Yì", "yì", "Ý", "ý", "Õ", "õ")
For i = UBound(Char) To LBound(Char) Step -1: Text = VBA.Replace(Text, Utf8(i), Char(i)): Next i
Else
For i = LBound(Char) To UBound(Char)
If "Ýì" = Utf8(i) Then
Text = VBA.Replace(Text, ChrW(253), "yì")
Text = VBA.Replace(Text, ChrW(221), "Yì")
End If
Text = VBA.Replace(Text, Char(i), Utf8(i))
Next i
Text = VBA.Replace(Text, ChrW(416), "Õ")
Text = VBA.Replace(Text, ChrW(417), "õ")
Text = VBA.Replace(Text, ChrW(431), "Ý")
Text = VBA.Replace(Text, ChrW(432), "ý")
End If
VietnameseUTF8 = Text
Erase Char: Erase Utf8
End Function
