سلام و ارادت
ماژول MsgBoxFa مسیج باکس فارسی که در این تاپیک بود را باتوجه به اینکه روی ویندوزهای 64 بیتی عمل نمیکرد اصلاح کردم و در ویندوز 64 و 32 بیتی عمل خواهد کرد
Option Compare Database
'----------------------- MsgBoxFa -------------------------
'https://barnamenevis.org/showthread.php?51987-%D9%85%D8%B4%DA%A9%D9%84%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D9%88-%D8%B3%D9%88%D8%B1%D8%B3-%D9%87%D8%A7%DB%8C-%D9%85%D8%B1%D8%A8%D9%88%D8%B7%D9%87&p=1719291&vie wfull=1#post1719291
'------------------- مسيج باکس فارسي ----------------------
' مناسب سازي شده براي ويندوز 64 و32 بيت '
' توسط محسن آل آقا اصلاح شده '
' 1400/06/29 '
' Hematalea@gmail '
' MsgBox براي استفاده از اين ماژول کافيست بجاي نوشتن تابع '
' .استفاده کنيد MsgBoxFa از تابع '
' '
' ------------------------------------------------------- '
' Integer را به عنوان MsgBox توجه: اگر در جايي که متغير '
' را حذف کنيد Integer ،تعريف کرده ايد '
' '
' :مثال '
' Dim OutPut As Integer <------------ خطا خواهد داد '
' OutPut = MsgBoxFa(".... '
' '
' Dim OutPut <--- بدون خطا اجرا خواهد شد '
' OutPut = MsgBoxFa(".... '
' '
'------------------------- Msgbox -------------------------
Public Const WH_CBT = 5
Public Const GWL_HINSTANCE = (-6)
Public Const HCBT_ACTIVATE = 5
#If VBA7 Then
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As LongPtr
hHook As LongPtr
End Type
Public Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr
Public Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As LongPtr) As LongPtr
Public Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As LongPtr
Public Declare PtrSafe Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr
Public Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Public Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
#Else
Public Type MSGBOX_HOOK_PARAMS
hWndOwner As Long
hHook As Long
End Type
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Public Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Public 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
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
#End If
'need this declared at module level as
'it is used in the call and the hook proc
Public MSGHOOK As MSGBOX_HOOK_PARAMS
#If VBA7 Then
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As LongPtr
'Wrapper function for the MessageBox API
Dim hwndThreadOwner As LongPtr
#Else
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Tiltle = "", Optional HelpFile, Optional Context) As Long
Dim hwndThreadOwner As Long
#End If
Dim frmCurrentForm As Form
'On Error Resume Next
Set frmCurrentForm = Screen.ActiveForm
hwndThreadOwner = frmCurrentForm.hwnd
#If VBA7 Then
Dim hInstance As LongPtr
Dim hThreadId As LongPtr
Dim hWndOwner As LongPtr
#Else
Dim hInstance As Long
Dim hThreadId As Long
Dim hWndOwner As Long
#End If
hWndOwner = GetDesktopWindow()
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hWndOwner = hWndOwner
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MsgBoxFa = MessageBox(hwndThreadOwner, Prompt, Tiltle, Buttons)
End Function
#If VBA7 Then
Public Function MsgBoxHookProc(ByVal uMsg As LongPtr, _
ByVal wParam As LongPtr, _
ByVal LParam As LongPtr) As LongPtr
#Else
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal LParam As Long) As Long
#End If
If uMsg = HCBT_ACTIVATE Then
SetDlgItemText wParam, vbYes, ChrW(1576) & ChrW(1604) & ChrW(1607) '"بله"
SetDlgItemText wParam, vbNo, ChrW(1582) & ChrW(1740) & ChrW(1585) ' "خير"
SetDlgItemText wParam, vbIgnore, ChrW(1604) & ChrW(1594) & ChrW(1608) ' "لغو"
SetDlgItemText wParam, vbOK, ChrW(1578) & ChrW(1571) & ChrW(1740) & ChrW(1740) & ChrW(1583) ' "تاييد"
SetDlgItemText wParam, vbCancel, ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1585) & ChrW(1575) & ChrW(1601) ' "انصراف"
SetDlgItemText wParam, vbAbort, ChrW(1606) & ChrW(1575) & ChrW(1578) & ChrW(1605) & ChrW(1575) & ChrW(1605) & _
" " & ChrW(1605) & ChrW(1575) & ChrW(1606) & ChrW(1583) & ChrW(1606) ' "ناتمام ماندن"
SetDlgItemText wParam, vbRetry, ChrW(1578) & ChrW(1604) & ChrW(1575) & ChrW(1588) & _
" " & ChrW(1583) & ChrW(1608) & ChrW(1576) & ChrW(1575) & ChrW(1585) & ChrW(1607) ' "تلاش دوباره"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
پاسخ با نقل قول
