Điều khiển hiển thị Msgbox?

Liên hệ QC
sealand

sealand

Thành viên gạo cội
Tham gia
16/5/08
Bài viết
4,883
Được thích
7,688
Giới tính
Nam
Nghề nghiệp
Kế Toán
Mình muốn khi thực hiện lệnh hoặc hàm Msgbox thì cửa sổ thông báo hiện tại 1 vị trí xác định trước chứ không phải ở giữa màn hình như mặc định. Việc này có làm được không, các bạn hướng dẫn giúp.
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Nguyễn Duy Tuân đã viết:
UniMsgBoxPos với Unicode

Code trên viết không chuẩn, không an toàn. Nó hook sự kiện MsgBox chỉ bằng điều kiện If lMsg = HCBT_ACTIVATE Then, nó hiểu bất kỳ một cửa sổ (Window) nào hoạt động (active) đều là cửa sổ của MsgBox-->Lỗi.

Tôi sửa lại code trên đảm bảo tối ưu:
+ Hook đúng cửa sổ MsgBox
+ Hỗ trợ Unicode
+ Giải phóng việc Hook trước đó an toàn.

Bổ sung thêm 3 hàm Windows API
Mã: 
Private Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function MessageBox Lib "user32.dll" Alias "MessageBoxW" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long

Hàm GetClassName để kiểm tra loại của sổ.
Hàm MessageBox để thay thế MsgBox trong VBA-->Gải pháp cho Unicode.
Hàm GetActiveWindow để nhận điều khiển (Handle) của cửa sổ hiện thời.

Viết lại hàm MsgBoxHookProc
Mã: 
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
                                ByVal wParam As Long, _
                                ByVal lParam As Long) As Long
    If lMsg = HCBT_ACTIVATE Then[COLOR="SeaGreen"] 'Kiểm tra cửa sổ hoạt động[/COLOR]
       
[COLOR="SeaGreen"]        'Modified by Nguyen Duy Tuan
        'Begin checking class for MsgBox Window
        'wParam is the handle of Window[/COLOR]

        Dim cClsName As String [COLOR="SeaGreen"]'Nhận tên Class của cửa sổ[/COLOR]
        Dim x As Long [COLOR="SeaGreen"]'Xác định số ký tự của chỗi[/COLOR]
       
        cClsName = Space(32)
        x = GetClassName(wParam, cClsName, 32)
        cClsName = Left(cClsName, x) [COLOR="SeaGreen"]'string convertion[/COLOR]
       
        If cClsName = "#32770" Then [COLOR="SeaGreen"]'Kiểm tra Class có phải của cửa sổ MsgBox không[/COLOR]
          
           [COLOR="SeaGreen"]' Change position[/COLOR]
           SetWindowPos wParam, 0, msgbox_x, msgbox_y, _
                        0, 0, SWP_NOSIZE + SWP_NOZORDER
   
           [COLOR="SeaGreen"]' Release the Hook[/COLOR]
           UnhookWindowsHookEx hHook
           hHook = 0
           MsgBoxHookProc = True
        End If
    End If
 
    MsgBoxHookProc = False
End Function
Nhấp chuột vào đây để mở rộng...
Em chào anh! Em vô tình đọc được bài này.
Anh cho em hỏi 1 chút là mình có thể tùy biến code này dạng câu hỏi yes/no được không ạ?
Ví dụ: Nếu bấm No thì ẩn msgbox đi. Còn nếu bấm Yes thì sẽ thực thi những dòng code bên dưới.
Em thử làm theo cách của msgbox thông thường thì không được.
Hi vọng anh còn truy cập web này ^^ mong anh phản hồi!
 
Upvote 0
Congtunho đã viết:
Em chào anh! Em vô tình đọc được bài này.
Anh cho em hỏi 1 chút là mình có thể tùy biến code này dạng câu hỏi yes/no được không ạ?
Ví dụ: Nếu bấm No thì ẩn msgbox đi. Còn nếu bấm Yes thì sẽ thực thi những dòng code bên dưới.
Em thử làm theo cách của msgbox thông thường thì không được.
Hi vọng anh còn truy cập web này ^^ mong anh phản hồi!
Nhấp chuột vào đây để mở rộng...

Bạn chỉ cần làm theo code mẫu thế này
If UniMsgBox(“Hỏi gì đấy”, vbYesNo, “Tiêu đề”) = vbNo Then Exit Sub
 
Upvote 0
Nguyễn Duy Tuân đã viết:
Bạn chỉ cần làm theo code mẫu thế này
If UniMsgBox(“Hỏi gì đấy”, vbYesNo, “Tiêu đề”) = vbNo Then Exit Sub
Nhấp chuột vào đây để mở rộng...
Dạ em làm hoài không được luôn, cứ báo lỗi cú pháp hoài. Em gửi lại file của anh, bên trong em có chỉnh lại thử mà hông được ^^
 

File đính kèm

  • UniMsgBoxPos.xls
    44 KB · Đọc: 3
Upvote 0
Congtunho đã viết:
Dạ em làm hoài không được luôn, cứ báo lỗi cú pháp hoài. Em gửi lại file của anh, bên trong em có chỉnh lại thử mà hông được ^^
Nhấp chuột vào đây để mở rộng...

Code cũ viết ở dạng Sub nên không theo ý bạn được. Tôi đã sửa lại như sau, bạn copy thay thế vào code cũ ở tên thủ tục (Sub) MsgBoxPosW

C#: 
Sub TestMsgBoxW()
    
   If MsgBoxPosW(Range("A1"), _
              vbYesNo, _
              Range("A2").Value, _
              100, 100) = vbNo Then Exit Sub
              
        MsgBoxPosW "Set non-Center Position", _
              vbOKOnly, _
              "Message Box Hooking", _
              100, 100

End Sub
 
'Created by Nguyen Duy Tuan
Public Function MsgBoxPosW(strPromt As String, _
              vbButtons As VbMsgBoxStyle, _
              strTitle As String, _
              xPos As Long, _
              yPos As Long)
 
    ' Store position
    msgbox_x = xPos
    msgbox_y = yPos
 
    ' Set Hook
    hHook = SetWindowsHookEx(WH_CBT, _
                              AddressOf MsgBoxHookProc, _
                              0, _
                              GetCurrentThreadId)
 
    ' Run MessageBox
    
    'Modified by Nguyen Duy Tuan
    MsgBoxPosW = MessageBox(GetActiveWindow, StrConv(strPromt, vbUnicode), StrConv(strTitle, vbUnicode), vbButtons)
    
    If hHook <> 0 Then ' Release the Hook again (important!)
        UnhookWindowsHookEx hHook
        hHook = 0
    End If
End Function
 

File đính kèm

  • UniMsgBoxPos.xls
    50.5 KB · Đọc: 6
Upvote 0
@Congtunho Bạn có thể tham khảo Hàm Alert để thông báo tiếng Việt hoặc InputBox dưới đây để nhập Password
Hàm Alert có một chức năng hiện thị tại vị trí chuột rất cần thiết.

JavaScript: 
'MsgBox VN
' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\
'

Option Explicit: Option Compare Text
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

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

#If VBA7 Then
Private Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
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 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 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 DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) 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
Private Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) 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" (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 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
Private Declare Function GetWindowRect Lib "USER32" (ByVal hwnd As Long, lpRect As RECT) 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 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 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 DeleteObject Lib "gdi32.dll" ( ByVal hObject 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
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
#End If
#If VBA7 And Win64 Then
Private hDlgHook^, hDlgHWnd^
#ElseIf VBA7 Then
Private hDlgHook As LongPtr, hDlgHWnd As LongPtr
#Else
Private hDlgHook&, hDlgHWnd&
#End If

Private hFont&, newRECT As RECT, newPoint As POINTAPI, iShowUnderCursor As Boolean
Private lButton1$, lButton2$, lButton3$



#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "USER32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "USER32" () As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "USER32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "USER32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "USER32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function DrawEdge Lib "USER32" (ByVal hDC As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare PtrSafe Function SetRect Lib "USER32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
  Private Declare PtrSafe Function SendDlgItemMessage Lib "USER32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Private Declare PtrSafe Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
  Private Declare PtrSafe Function DefWindowProc Lib "USER32" Alias "DefWindowProcW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare  Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare  Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Private Const WM_SETTEXT = &HC
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Var64

Private Const IDCANCEL = &H2
Private Const BM_CLICK = &HF5
Private Const DT_CALCRECT = &H400
Private Const COLOR_BTNFACE = 15
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private bTimedOut As Boolean
Private bCharPassword As Boolean

Private bShowCountDown As Boolean
Private sTimer As Single
Private sTimeOut As Single
Private hwnd As Var64
Private tFont As LOGFONT, tRect As RECT, tEdgeRect As RECT, tPt1 As POINTAPI, tpt2 As POINTAPI
Private sTimeLeft$, sPrompt$, sTitle$, hNewFont As Var64, hDC As Var64, ForeColor As Long

Sub test()
Call InputBox(Prompt:="Nh" & ChrW(7853) & "p m" & ChrW(7853) & "t kh" & ChrW(7849) & "u " & ChrW(273) & ChrW(7875) & " s" & ChrW(7917) & "a:", _
                title:="Nh" & ChrW(7853) & "p m" & ChrW(7853) & "t kh" & ChrW(7849) & "u " & ChrW(273) & ChrW(7875) & " s" & ChrW(7917) & "a:", _
                Timeout:=1125, _
  ShowCountDown:=True, Password:=True)

End Sub

Function InputBox(Prompt, _
          Optional title$, _
          Optional default, _
          Optional x As Single, _
          Optional y As Single, _
          Optional HelpFile, _
          Optional Context, _
          Optional Timeout As Single = 15, _
          Optional Password As Boolean = False, _
          Optional ShowCountDown As Boolean = True, _
          Optional ByVal ShowUnderCursor As Boolean = True)
  If Timeout > 0 Then
    bShowCountDown = ShowCountDown
    sTimer = Timer
    sTimeOut = VBA.IIf(Timeout > 86400, 86400, Timeout)
    bTimedOut = False
    bCharPassword = Password
    iShowUnderCursor = ShowUnderCursor
    hwnd.Long = 0
    Call SetTimer(Application.hwnd, 0, 0, AddressOf TimerProc)
  End If
  sPrompt = Prompt
  sTitle = title
  InputBox = VBA.InputBox(Prompt, title, default, x, y, HelpFile, Context)
  sTimeOut = 0
End Function

#If VBA7 And Win64 Then
Private Sub TimerProc(ByVal hhwnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#Else
Private Sub TimerProc(ByVal hhwnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
#If VBA7 And Win64 Then
  Dim hStatic1^, hStatic2^, hButton^, nCaption$, lCaption$
#ElseIf VBA7 Then
  Dim hStatic1 As LongPtr, hStatic2 As LongPtr, hButton As LongPtr, nCaption$, lCaption$
#Else
  Dim hStatic1&, hStatic2&, hButton&, nCaption$, lCaption$
#End If
  If hwnd.Long = 0 Then
    hwnd.Long = GetActiveWindow
    If bCharPassword Then
      SendDlgItemMessage hwnd.Long, &H1324, EM_SETPASSWORDCHAR, 42, &H0
    End If
    '''''''''''''''''''''''''''''''''''''
    hFont = CreateFont(13, 0, 0, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
    hStatic1 = FindWindowEx(hwnd.Long, 0&, "Static", VBA.vbNullString)
    hStatic2 = FindWindowEx(hwnd.Long, hStatic1, "Static", VBA.vbNullString)
    hDlgHWnd = hwnd.Long
    DefWindowProc hDlgHWnd, WM_SETTEXT, 0, StrPtr(sTitle)
    Call SetWindowPos(hDlgHWnd, -3, 0, 0, 0, 0, &H2 Or &H1)
    If hStatic2 = 0 Then hStatic2 = hStatic1
    SendMessage hStatic2, &H30, hFont, ByVal 1&
    SetWindowTextW hStatic2, StrPtr(sPrompt)
    '--------------------------------------
    nCaption = IIf(lButton1 = vbNullString, "&X" & VBA.ChrW(225) & "c nh" & VBA.ChrW(7853) & "n", lButton1)
    lCaption = "OK":      GoSub Send
    nCaption = IIf(lButton3 = vbNullString, "&H" & VBA.ChrW(7911) & "y", lButton3)
    lCaption = "Cancel":  GoSub Send
    '--------------------------------------
    If iShowUnderCursor Then
      GetCursorPos newPoint
      GetWindowRect hwnd.Long, newRECT
      Dim w&, h&
      w = (newRECT.RIGHT - newRECT.Left - 1)
      h = (newRECT.BOTTOM - newRECT.Top - 1)
      MoveWindow hwnd.Long, newPoint.x - w \ 2, newPoint.y - h \ 2, w, h, True
    End If
  End If
  If sTimeOut Then
    '------------------------------------
    sTimeLeft = sTimeOut - (VBA.Timer - sTimer)
    If sTimeLeft <= "0.5" Then
      sTimeLeft = "  Finish   ": ForeColor = VBA.vbRed
    Else
      sTimeLeft = VBA.Format(VBA.TimeSerial(0, 0, sTimeLeft), "hh:mm:ss")
      ForeColor = VBA.vbBlue
    End If
    If bShowCountDown Then
      Call GetWindowRect(GetDlgItem(hwnd.Long, IDCANCEL), tRect)
      tPt1.x = tRect.Left + 2
      tPt1.y = tRect.Top + (tRect.BOTTOM - tRect.Top) * 1.5
      tpt2.x = tRect.RIGHT + 1
      tpt2.y = tPt1.y + (tRect.BOTTOM - tRect.Top) / 1.5
      Call ScreenToClient(hwnd.Long, tPt1)
      Call ScreenToClient(hwnd.Long, tpt2)
      hDC.Long = GetDC(hwnd.Long)

      tFont.lfHeight = 13: tFont.lfFaceName = "Rockwell Extra Bold" & Chr(0)

      hNewFont.Long = CreateFontIndirect(tFont)
      Call DeleteObject(SelectObject(hDC.Long, hNewFont.Long))
      Call SetRect(tEdgeRect, tPt1.x - 2, tPt1.y - 2, tpt2.x, tpt2.y)
      Call DrawEdge(hDC.Long, tEdgeRect, EDGE_ETCHED, BF_RECT)
      Call SetTextColor(hDC.Long, ForeColor)
      Call SetBkColor(hDC.Long, GetSysColor(COLOR_BTNFACE))

      Call DrawText(hDC.Long, sTimeLeft, Len(sTimeLeft), tRect, DT_CALCRECT)
      Call TextOut(hDC.Long, tPt1.x, tPt1.y, sTimeLeft, Len(sTimeLeft))

      Call DeleteObject(hNewFont.Long)
      Call ReleaseDC(hwnd.Long, hDC.Long)
    End If
    bTimedOut = (VBA.Timer - sTimer) >= sTimeOut
    If bTimedOut Xor GetLastActivePopup(Application.hwnd) <> hwnd.Long Then
        Call KillTimer(hhwnd, idEvent)
        Call SendMessage(GetDlgItem(hwnd.Long, IDCANCEL), BM_CLICK, 0, ByVal 0)
    End If
  Else
    Call KillTimer(hhwnd, idEvent)
  End If
Exit Sub
Send:
  hButton = FindWindowEx(hwnd.Long, 0&, "Button", lCaption)
  SendMessage hButton, &H30, hFont, 0
  SetWindowTextW hButton, StrPtr(nCaption)
Return
End Sub


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
' Last Edit: 09/03/2020 17:01
#If VBA7 Then
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 = True, Optional button1$, Optional button2$, Optional button3$) As VbMsgBoxResult
#Else
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& = 2, Optional ByVal ShowUnderCursor As Boolean = True, Optional button1$, Optional button2$, Optional button3$) As VbMsgBoxResult
#End If
  lButton1 = button1
  lButton2 = button2
  lButton3 = button3
  iShowUnderCursor = ShowUnderCursor
  If Timeout <= 0 Then Timeout = 3600
  #If VBA7 And 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, VBA.StrConv(Prompt, 64), VBA.StrConv(title, 64), Buttons Or &H2000&, 0&, Timeout * 1000)
  DeleteObject hFont
End Function

#If VBA7 And Win64 Then
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam^, ByVal lParam^)
  Dim hStatic1^, hStatic2^, hButton^, nCaption$, lCaption$
#ElseIf VBA7 Then
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam As LongPtr, ByVal lParam As LongPtr)
  Dim hStatic1 As LongPtr, hStatic2 As LongPtr, hButton As LongPtr, nCaption$, lCaption$
#Else
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam&, ByVal lParam&)
  Dim hStatic1&, hStatic2&, hButton&, nCaption$, lCaption$
#End If
  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", VBA.vbNullString)
    hStatic2 = FindWindowEx(wParam, hStatic1, "Static", VBA.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" & VBA.ChrW(225) & "c nh" & VBA.ChrW(7853) & "n", lButton1)
    lCaption = "OK":      GoSub Send
    nCaption = IIf(lButton1 = vbNullString, "&C" & VBA.ChrW(243), lButton1)
    lCaption = "&Yes":    GoSub Send
    nCaption = IIf(lButton2 = vbNullString, "&Kh" & VBA.ChrW(244) & "ng", lButton2)
    lCaption = "&No":     GoSub Send
    nCaption = IIf(lButton3 = vbNullString, "&H" & VBA.ChrW(7911) & "y", lButton3)
    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
    '--------------------------------------
    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
 
Upvote 0
Nguyễn Duy Tuân đã viết:
Code cũ viết ở dạng Sub nên không theo ý bạn được. Tôi đã sửa lại như sau, bạn copy thay thế vào code cũ ở tên thủ tục (Sub) MsgBoxPosW

C#: 
Sub TestMsgBoxW()
   
   If MsgBoxPosW(Range("A1"), _
              vbYesNo, _
              Range("A2").Value, _
              100, 100) = vbNo Then Exit Sub
             
        MsgBoxPosW "Set non-Center Position", _
              vbOKOnly, _
              "Message Box Hooking", _
              100, 100

End Sub
 
'Created by Nguyen Duy Tuan
Public Function MsgBoxPosW(strPromt As String, _
              vbButtons As VbMsgBoxStyle, _
              strTitle As String, _
              xPos As Long, _
              yPos As Long)
 
    ' Store position
    msgbox_x = xPos
    msgbox_y = yPos
 
    ' Set Hook
    hHook = SetWindowsHookEx(WH_CBT, _
                              AddressOf MsgBoxHookProc, _
                              0, _
                              GetCurrentThreadId)
 
    ' Run MessageBox
   
    'Modified by Nguyen Duy Tuan
    MsgBoxPosW = MessageBox(GetActiveWindow, StrConv(strPromt, vbUnicode), StrConv(strTitle, vbUnicode), vbButtons)
   
    If hHook <> 0 Then ' Release the Hook again (important!)
        UnhookWindowsHookEx hHook
        hHook = 0
    End If
End Function
Nhấp chuột vào đây để mở rộng...
Dạ em làm được rồi, cảm ơn anh nhiều!
Bài đã được tự động gộp:

HeSanbi đã viết:
@Congtunho Bạn có thể tham khảo Hàm Alert để thông báo tiếng Việt hoặc InputBox dưới đây để nhập Password
Hàm Alert có một chức năng hiện thị tại vị trí chuột rất cần thiết.

JavaScript: 
'MsgBox VN
' __   _____   _ ®
' \ \ / / _ | / \
'  \ \ /| _ \/ / \
'   \_/ |___/_/ \_\
'

Option Explicit: Option Compare Text
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

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

#If VBA7 Then
Private Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
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 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 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 DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) 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
Private Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) 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" (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 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
Private Declare Function GetWindowRect Lib "USER32" (ByVal hwnd As Long, lpRect As RECT) 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 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 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 DeleteObject Lib "gdi32.dll" ( ByVal hObject 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
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
#End If
#If VBA7 And Win64 Then
Private hDlgHook^, hDlgHWnd^
#ElseIf VBA7 Then
Private hDlgHook As LongPtr, hDlgHWnd As LongPtr
#Else
Private hDlgHook&, hDlgHWnd&
#End If

Private hFont&, newRECT As RECT, newPoint As POINTAPI, iShowUnderCursor As Boolean
Private lButton1$, lButton2$, lButton3$



#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "USER32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "USER32" () As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "USER32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "USER32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function GetSysColor Lib "USER32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function DrawEdge Lib "USER32" (ByVal hDC As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare PtrSafe Function SetRect Lib "USER32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
  Private Declare PtrSafe Function SendDlgItemMessage Lib "USER32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Private Declare PtrSafe Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr
  Private Declare PtrSafe Function DefWindowProc Lib "USER32" Alias "DefWindowProcW" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function DrawEdge Lib "user32" (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare  Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare  Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam 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 DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
Private Const WM_SETTEXT = &HC
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As Var64

Private Const IDCANCEL = &H2
Private Const BM_CLICK = &HF5
Private Const DT_CALCRECT = &H400
Private Const COLOR_BTNFACE = 15
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private bTimedOut As Boolean
Private bCharPassword As Boolean

Private bShowCountDown As Boolean
Private sTimer As Single
Private sTimeOut As Single
Private hwnd As Var64
Private tFont As LOGFONT, tRect As RECT, tEdgeRect As RECT, tPt1 As POINTAPI, tpt2 As POINTAPI
Private sTimeLeft$, sPrompt$, sTitle$, hNewFont As Var64, hDC As Var64, ForeColor As Long

Sub test()
Call InputBox(Prompt:="Nh" & ChrW(7853) & "p m" & ChrW(7853) & "t kh" & ChrW(7849) & "u " & ChrW(273) & ChrW(7875) & " s" & ChrW(7917) & "a:", _
                title:="Nh" & ChrW(7853) & "p m" & ChrW(7853) & "t kh" & ChrW(7849) & "u " & ChrW(273) & ChrW(7875) & " s" & ChrW(7917) & "a:", _
                Timeout:=1125, _
  ShowCountDown:=True, Password:=True)

End Sub

Function InputBox(Prompt, _
          Optional title$, _
          Optional default, _
          Optional x As Single, _
          Optional y As Single, _
          Optional HelpFile, _
          Optional Context, _
          Optional Timeout As Single = 15, _
          Optional Password As Boolean = False, _
          Optional ShowCountDown As Boolean = True, _
          Optional ByVal ShowUnderCursor As Boolean = True)
  If Timeout > 0 Then
    bShowCountDown = ShowCountDown
    sTimer = Timer
    sTimeOut = VBA.IIf(Timeout > 86400, 86400, Timeout)
    bTimedOut = False
    bCharPassword = Password
    iShowUnderCursor = ShowUnderCursor
    hwnd.Long = 0
    Call SetTimer(Application.hwnd, 0, 0, AddressOf TimerProc)
  End If
  sPrompt = Prompt
  sTitle = title
  InputBox = VBA.InputBox(Prompt, title, default, x, y, HelpFile, Context)
  sTimeOut = 0
End Function

#If VBA7 And Win64 Then
Private Sub TimerProc(ByVal hhwnd As LongPtr, ByVal wMsg^, ByVal idEvent As LongPtr, ByVal dwTime^)
#Else
Private Sub TimerProc(ByVal hhwnd&, ByVal wMsg&, ByVal idEvent&, ByVal dwTime&)
#End If
#If VBA7 And Win64 Then
  Dim hStatic1^, hStatic2^, hButton^, nCaption$, lCaption$
#ElseIf VBA7 Then
  Dim hStatic1 As LongPtr, hStatic2 As LongPtr, hButton As LongPtr, nCaption$, lCaption$
#Else
  Dim hStatic1&, hStatic2&, hButton&, nCaption$, lCaption$
#End If
  If hwnd.Long = 0 Then
    hwnd.Long = GetActiveWindow
    If bCharPassword Then
      SendDlgItemMessage hwnd.Long, &H1324, EM_SETPASSWORDCHAR, 42, &H0
    End If
    '''''''''''''''''''''''''''''''''''''
    hFont = CreateFont(13, 0, 0, 0, 500, 0, 0, 0, 0, 0, 0, 0, 0, "Tahoma")
    hStatic1 = FindWindowEx(hwnd.Long, 0&, "Static", VBA.vbNullString)
    hStatic2 = FindWindowEx(hwnd.Long, hStatic1, "Static", VBA.vbNullString)
    hDlgHWnd = hwnd.Long
    DefWindowProc hDlgHWnd, WM_SETTEXT, 0, StrPtr(sTitle)
    Call SetWindowPos(hDlgHWnd, -3, 0, 0, 0, 0, &H2 Or &H1)
    If hStatic2 = 0 Then hStatic2 = hStatic1
    SendMessage hStatic2, &H30, hFont, ByVal 1&
    SetWindowTextW hStatic2, StrPtr(sPrompt)
    '--------------------------------------
    nCaption = IIf(lButton1 = vbNullString, "&X" & VBA.ChrW(225) & "c nh" & VBA.ChrW(7853) & "n", lButton1)
    lCaption = "OK":      GoSub Send
    nCaption = IIf(lButton3 = vbNullString, "&H" & VBA.ChrW(7911) & "y", lButton3)
    lCaption = "Cancel":  GoSub Send
    '--------------------------------------
    If iShowUnderCursor Then
      GetCursorPos newPoint
      GetWindowRect hwnd.Long, newRECT
      Dim w&, h&
      w = (newRECT.RIGHT - newRECT.Left - 1)
      h = (newRECT.BOTTOM - newRECT.Top - 1)
      MoveWindow hwnd.Long, newPoint.x - w \ 2, newPoint.y - h \ 2, w, h, True
    End If
  End If
  If sTimeOut Then
    '------------------------------------
    sTimeLeft = sTimeOut - (VBA.Timer - sTimer)
    If sTimeLeft <= "0.5" Then
      sTimeLeft = "  Finish   ": ForeColor = VBA.vbRed
    Else
      sTimeLeft = VBA.Format(VBA.TimeSerial(0, 0, sTimeLeft), "hh:mm:ss")
      ForeColor = VBA.vbBlue
    End If
    If bShowCountDown Then
      Call GetWindowRect(GetDlgItem(hwnd.Long, IDCANCEL), tRect)
      tPt1.x = tRect.Left + 2
      tPt1.y = tRect.Top + (tRect.BOTTOM - tRect.Top) * 1.5
      tpt2.x = tRect.RIGHT + 1
      tpt2.y = tPt1.y + (tRect.BOTTOM - tRect.Top) / 1.5
      Call ScreenToClient(hwnd.Long, tPt1)
      Call ScreenToClient(hwnd.Long, tpt2)
      hDC.Long = GetDC(hwnd.Long)

      tFont.lfHeight = 13: tFont.lfFaceName = "Rockwell Extra Bold" & Chr(0)

      hNewFont.Long = CreateFontIndirect(tFont)
      Call DeleteObject(SelectObject(hDC.Long, hNewFont.Long))
      Call SetRect(tEdgeRect, tPt1.x - 2, tPt1.y - 2, tpt2.x, tpt2.y)
      Call DrawEdge(hDC.Long, tEdgeRect, EDGE_ETCHED, BF_RECT)
      Call SetTextColor(hDC.Long, ForeColor)
      Call SetBkColor(hDC.Long, GetSysColor(COLOR_BTNFACE))

      Call DrawText(hDC.Long, sTimeLeft, Len(sTimeLeft), tRect, DT_CALCRECT)
      Call TextOut(hDC.Long, tPt1.x, tPt1.y, sTimeLeft, Len(sTimeLeft))

      Call DeleteObject(hNewFont.Long)
      Call ReleaseDC(hwnd.Long, hDC.Long)
    End If
    bTimedOut = (VBA.Timer - sTimer) >= sTimeOut
    If bTimedOut Xor GetLastActivePopup(Application.hwnd) <> hwnd.Long Then
        Call KillTimer(hhwnd, idEvent)
        Call SendMessage(GetDlgItem(hwnd.Long, IDCANCEL), BM_CLICK, 0, ByVal 0)
    End If
  Else
    Call KillTimer(hhwnd, idEvent)
  End If
Exit Sub
Send:
  hButton = FindWindowEx(hwnd.Long, 0&, "Button", lCaption)
  SendMessage hButton, &H30, hFont, 0
  SetWindowTextW hButton, StrPtr(nCaption)
Return
End Sub


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
' Last Edit: 09/03/2020 17:01
#If VBA7 Then
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 = True, Optional button1$, Optional button2$, Optional button3$) As VbMsgBoxResult
#Else
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& = 2, Optional ByVal ShowUnderCursor As Boolean = True, Optional button1$, Optional button2$, Optional button3$) As VbMsgBoxResult
#End If
  lButton1 = button1
  lButton2 = button2
  lButton3 = button3
  iShowUnderCursor = ShowUnderCursor
  If Timeout <= 0 Then Timeout = 3600
  #If VBA7 And 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, VBA.StrConv(Prompt, 64), VBA.StrConv(title, 64), Buttons Or &H2000&, 0&, Timeout * 1000)
  DeleteObject hFont
End Function

#If VBA7 And Win64 Then
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam^, ByVal lParam^)
  Dim hStatic1^, hStatic2^, hButton^, nCaption$, lCaption$
#ElseIf VBA7 Then
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam As LongPtr, ByVal lParam As LongPtr)
  Dim hStatic1 As LongPtr, hStatic2 As LongPtr, hButton As LongPtr, nCaption$, lCaption$
#Else
Private Function HookProcMsgBox&(ByVal nCode&, ByVal wParam&, ByVal lParam&)
  Dim hStatic1&, hStatic2&, hButton&, nCaption$, lCaption$
#End If
  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", VBA.vbNullString)
    hStatic2 = FindWindowEx(wParam, hStatic1, "Static", VBA.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" & VBA.ChrW(225) & "c nh" & VBA.ChrW(7853) & "n", lButton1)
    lCaption = "OK":      GoSub Send
    nCaption = IIf(lButton1 = vbNullString, "&C" & VBA.ChrW(243), lButton1)
    lCaption = "&Yes":    GoSub Send
    nCaption = IIf(lButton2 = vbNullString, "&Kh" & VBA.ChrW(244) & "ng", lButton2)
    lCaption = "&No":     GoSub Send
    nCaption = IIf(lButton3 = vbNullString, "&H" & VBA.ChrW(7911) & "y", lButton3)
    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
    '--------------------------------------
    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
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn anh! Em tham khảo thêm a, nhiều cái hay ho quá :) Chúc anh nhiều sức khỏe!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
Trả lời
14
Đọc
110
ptm0412
ptm0412
N
cộng các dữ liệu không trùng nhau
Trả lời
11
Đọc
162
hoangtuaotrang_hp_vn
H
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
2
Đọc
30
Excel my love_1
E
D
  • Question
Xin cách tạo tab và button cho Add-in trên ribbon Maintabs
Trả lời
1
Đọc
32
befaint
befaint
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
3
Đọc
109
HieuCD
H
T
Trùng 2 lần: Tìm dữ liệu nhiều điều kiện
Trả lời
0
Đọc
31
Thulib
T
N
  • Question
Xin mã code ẩn hiện dòng theo điều kiện
Trả lời
10
Đọc
97
Nguyễn Diêu Hiền
N
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
11
Đọc
183
quocphuoc88
quocphuoc88
N
Công thức tính số phù hợp với % mong muốn
Trả lời
9
Đọc
135
CHAOQUAY
C
B
Giúp em xử lý lỗi macro khi chạy VBA
2
Trả lời
21
Đọc
434
huhumalu
H
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
6
Đọc
323
DeTong
D
T
cả nhà hỗ trợ giúp em là em phải dùng hàm gì cho đúng ạ, em làm mãi không được
    • Cười
Trả lời
2
Đọc
84
DeTong
D
nguyenanhhoa
Nhờ các bác giúp: e muốn tô màu khác nhau đối với các ô giống nhau về giá trị
    • Cười
Trả lời
7
Đọc
132
SA_DQ
SA_DQ
LuuAnh980
Từ "cân đối" trong tiếng Anh là gì?
2 3
Trả lời
44
Đọc
2K
VetMini
V
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
11
Đọc
628
VetMini
V
C
Tiếng Việt
    • Cười
2
Trả lời
32
Đọc
1K
VetMini
V
HeSanbi
  • Question
Hàm FilterA và FilterV - Bổ trợ tận dụng bộ lọc AutoFilter và AdvancedFilter
    • Thích
    • Yêu thích
    • Cảm ơn
2 3
Trả lời
48
Đọc
4K
Manhhung90
Manhhung90
N
Giúp em công thức lấy dữ liệu không trùng để in phiếu thu bán hàng
Trả lời
5
Đọc
187
nguyenthieny
N
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
173
Đọc
9K
ongke0711
ongke0711
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
13
Đọc
1K
hoangtuaotrang_hp_vn
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom