' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
'MsgBox VNI
Option Explicit
Option Private Module
#If VBA7 Then
#Else
Private Enum LongLong:[_]:End Enum
#If Win64 Then
#Else
Private Enum LongPtr:[_]:End Enum
#End If
#End If
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type
#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 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 Long
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 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 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 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
Private Declare PtrSafe Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace 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 GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function moveWindow Lib "user32.dll" Alias "MoveWindow" (ByVal hwnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
#Else
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 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 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 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 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 CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SetWindowTextW Lib "user32" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
#End If
Public hDlgHook As LongLong, hDlgHWnd As LongLong
Private Const WM_SETFONT = &H30
Private Const MB_TASKMODAL = &H2000&
Public hFont&
Private Const FONT_FACE = "Tahoma"
Private lButton1$
Private lButton2$
Private lButton3$
Private iShowUnderCursor As Boolean, NewPoint As POINTAPI
Private newRECT As RECT
Private Sub Alert_test()
Alert "Xin ch" & ChrW$(224) & "o, b" & ChrW$(7841) & "n mu" & ChrW$(7889) & "n bao nhi" & ChrW$(234) & "u gi" & ChrW$(226) & "y t" & ChrW$(7921) & " " & ChrW$(273) & ChrW$(7897) & "ng " & ChrW$(273) & ChrW$(243) & "ng th" & ChrW$(244) & "ng b" & ChrW$(225) & "o?", vbOKCancel, TimeOut:=5
End Sub
Private Sub Alert_test2()
'Return Value:
' End Timeout = 32000 (Het thoi gian chon)
' OK = 1 (Xac Nhan)
' Cancel = 2 (Huy 1)
' Abort = 3 (Huy 2)
' Retry = 4 (Thu Lai)
' Ignore = 5 (Bo Qua)
' Yes = 6 (Co)
' No = 7 (Khong)
'Debug.Print Alert("OK?", vbOKCancel, Timeout:=5)
'Debug.Print Alert("OK?", vbAbortRetryIgnore, Timeout:=5)
'Debug.Print Alert("OK?", vbYesNoCancel, Timeout:=5)
End Sub
' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
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 As LongPtr = &H0, Optional ByVal TimeOut& = 2, Optional ByVal ShowUnderCursor As Boolean = False, Optional button1$, Optional button2$, Optional button3$) As VbMsgBoxResult
lButton1 = button1
lButton2 = button2
lButton3 = button3
iShowUnderCursor = ShowUnderCursor
If TimeOut <= 0 Then TimeOut = 3600
#If Win64 Then
hDlgHook = SetWindowsHookEx(5, AddressOf HookProcMsgBox, Application.HinstancePtr, GetCurrentThreadId())
#Else
hDlgHook = SetWindowsHookEx(5, AddressOf HookProcMsgBox, Application.Hinstance, GetCurrentThreadId())
#End If
Call SetWindowPos(hDlgHWnd, -1, 0, 0, 0, 0, &H2 Or &H1)
Alert = MsgBoxTimeoutW(hwnd, StrConv(Prompt, 64), StrConv(Title, 64), buttons Or &H2000&, 0&, TimeOut * 1000)
DeleteObject hFont
End Function
Private Function HookProcMsgBox&(ByVal ncode&, ByVal wParam As LongLong, ByVal lParam As LongLong)
Dim hStatic1 As LongLong, hStatic2 As LongLong, hButton As LongLong, nCaption$, lCaption$
HookProcMsgBox = CallNextHookEx(hDlgHook, ncode, wParam, lParam)
If ncode = 5 Then
hFont = CreateFont(13, 0, 0, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
hStatic1 = FindWindowEx(wParam, 0&, "Static", vbNullString)
hStatic2 = FindWindowEx(wParam, hStatic1, "Static", vbNullString)
hDlgHWnd = wParam
Call SetWindowPos(hDlgHWnd, -3, 0, 0, 0, 0, &H2 Or &H1)
If hStatic2 = 0 Then hStatic2 = hStatic1
SendMessage hStatic2, &H30, hFont, ByVal 1&
'--------------------------------------
nCaption = IIf(lButton1 = vbNullString, "&X" & ChrW$(225) & "c nh" & ChrW$(7853) & "n", lButton1)
lCaption = "OK": GoSub Send
nCaption = IIf(lButton1 = vbNullString, "&C" & ChrW$(243), lButton1)
lCaption = "&Yes": GoSub Send
nCaption = IIf(lButton2 = vbNullString, "&Kh" & ChrW$(244) & "ng", lButton2)
lCaption = "&No": GoSub Send
nCaption = IIf(lButton3 = vbNullString, "&H" & ChrW$(7911) & "y", lButton3)
lCaption = "Cancel": GoSub Send
nCaption = "&Th" & ChrW$(7917) & " l" & ChrW$(7841) & "i"
lCaption = "&Retry": GoSub Send
nCaption = "&B" & ChrW$(7887) & " qua"
lCaption = "&Ignore": GoSub Send
nCaption = "H" & ChrW$(7911) & "&y b" & ChrW$(7887)
lCaption = "&Abort": GoSub Send
nCaption = "Tr" & ChrW$(7907) & " &gi" & ChrW$(250) & "p"
lCaption = "Help": GoSub Send
'--------------------------------------
If iShowUnderCursor Then
GetCursorPos NewPoint
GetWindowRect wParam, newRECT
Dim w&, h&
w = (newRECT.Right - newRECT.left - 1)
h = (newRECT.Bottom - newRECT.top - 1)
moveWindow wParam, NewPoint.X - w \ 2, NewPoint.Y - h \ 2, w, h, False
End If
UnhookWindowsHookEx hDlgHook
End If
Exit Function
Send:
hButton = FindWindowEx(wParam, 0&, "Button", lCaption)
SendMessage hButton, &H30, hFont, 0
SetWindowTextW hButton, StrPtr(nCaption)
Return
End Function
Sub ClipboardDataSet(Text$)
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Text, 1: .PutInClipboard
End With
End Sub
Private Sub Text2CodeVBA_test()
Dim p$
p = Application.InputBox("Input")
' Dán vãn baÒn bãÌng phím tãìt Ctrl+V
If p = vbNullString Then Exit Sub
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText Text2CodeVBA(p), 1
.PutInClipboard
'CreateObject("WScript.Shell").SendKeys "^v"
Alert ChrW(272) & ChrW(227) & " t" & ChrW(7841) & "o chu" & ChrW(7895) & "i Unicode th" & ChrW(224) & "nh m" & ChrW(227) & " VBA" & vbLf & "Nh" & ChrW(7845) & "n Ctrl+V " & ChrW(273) & ChrW(7875) & " d" & ChrW(225) & "n v" & ChrW(224) & "o m" & ChrW(227) & "!"
End With
End Sub
Function Text2CodeVBA(ByVal Text As String, Optional ByVal procedureName$, Optional ByVal limitRows% = 300, Optional ByVal limitColumns% = 950)
Dim l&
l = Len(Text)
If l < 1 Then Exit Function
Dim i&, s, s1, s2, s3$, s4$, t$, lt$, t1$, t2$, k&, kk&, v&
t1 = "Dim s$"
If procedureName <> "" Then
t2 = "s = s & """
Else
t2 = """"
End If
s3 = t2
For i = 1 To l
t = Mid$(Text, i, 1)
v = 0
Select Case t
Case """": s3 = s3 & """"""
Case vbCr:
Case vbLf:
k = k + 1
If k > limitRows Then
GoSub join
Else
s3 = s3 & """ & vbLF" & vbLf & IIf(i = l, "", "s = s & """)
End If
Case Else
'StrConv(t, 64) Like "[! ][!" & vbNullChar & "]" Or
v = AscW(t)
If v > 127 Then
s3 = s3 & """ & chrw$(" & CStr(v) & ") " & IIf(i = l, "", "& """)
Else
s3 = s3 & t
End If
End Select
If Len(Split(s3, vbLf)(UBound(Split(s3, vbLf)))) >= limitColumns Then
s3 = s3 & """ & vbLF" & vbNewLine & IIf(i = l, "", "s = s & """)
End If
lt = t
Next i
GoSub join
If kk > 0 Then
s = s2
End If
Text2CodeVBA = s
Exit Function
join:
If s3 <> t2 Then
kk = kk + 1
If procedureName <> "" Then
s1 = s1 & "s = s & " & procedureName & kk & " & n" & vbNewLine
s2 = s2 & "Function " & procedureName & kk & "()" & vbNewLine & _
t1 & vbNewLine & s3 & IIf(s3 Like "*& vbLF" & vbNewLine, "", """") & vbNewLine & _
procedureName & kk & " = s" & vbNewLine & _
"End Function" & vbNewLine
Else
s2 = s3 & IIf(v > 127 Or s3 Like "*& vbLF" & vbNewLine, "", """")
End If
End If
k = 0: s3 = t2
Return
End Function
www.giaiphapexcel.com
