شوگر مامی" به زن ثروتمندی گفته می شود که با مردان جذاب، جوان و پویا وارد رابطه می شود، البته به طور قطع هر پسری تمایل به برقراری رابطه با شوگرمامی ها ندارد.
برای SubClass کردن پنجره حتما پنجره VBE بسته باشد و در صورت لزوم انجام تغییرات حتما از برنامه خارج شده و دوباره وارد شوید.
WikiBooks : SubClassing
Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Private PrevProc As LongPtr
Private Const WM_SETTEXT=&HC As Long
Function WindowProc(ByVal Hwnd As LongPtr,Byval uMsg As Long,ByVal wParam As LongPtr,ByVal lParam As LongPtr)
Select Case uMsg
' SendMessageList
Case WM_LBUTTONUP
Case WM_SETTEXT
در این پیام wparam استفاده نمی شود و lparam هم رشته است .
sTemp=StrConv("SubClassing" & Chr(0),VbFromUnicode)
lParam=lParam & "..." & sTemp
End Select
WindowProc=CallWindowProc(PrevProc,Hwnd,uMsg,wParam,lParam)
End Function
Function SubClassForm(Frm As Form)
PrevProc=SetWindowLongPtr(Frm.hwnd,(-4),AddressOf WindowProc)
End Function
Function UnSubClassForm(Frm As Form)
SetWindowLongPtr Frm.hwnd,(-4),PrevProc
End Function
Form 1 :
Event:Load
SubClassForm Me
Event UnLoad
UnSubClassForm Me
CommandButton0
SendMessage Me.hwnd,&HC,0&,Byval "This is a test..."
توجه : اگر توابع درست فراخوانی نشوند یا اینکه دیتا تایپ اشتباه باشد یا در جایی که نیاز است ByVal استفاده نشود ، Crash خواهد داد ( وباید از Task Manager یا زدن کلید ترکیبی ctrl+shift+esc اکسس اجرایی را ببندید ) و باعث آسیب به دیتا بیس خواهد شد هر چند اکسس قبلش یک BackUp می سازد.
برای اصلاح در محیط VBE حتما از فایل خارج شوید و دوباره وارد فایل شوید و گرنه کلوز باتن فرم در اجرای مجدد فریز شده و می بایست به اپلیکیشن دیگر فوکس کرده یا به دسکتاپ Move کنید و سپس به اکسس بروید . در این صورت پیام ویندوزی هم دریافت نمی گردد.
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private hXLDesk As LongPtr
Private lPrevWnd As LongPtr
Private bXitLoop As Boolean
Public Sub InstallHook()
If lPrevWnd = 0 Then
hXLDesk =FindWindowEx(FindWindow("XLMAIN",Application.Caption),0, "XLDESK", vbNullString)
lPrevWnd=SetWindowLongPtr(hXLDesk,(-4), AddressOf TransitionalProc)
' Msg pump for safe subclassing !!!!
MessageLoop
End If
End Sub
Public Sub ClearHook()
'cleanUp.
bXitLoop = True
SetWindowLongPtr hXLDesk,(-4),lPrevWnd
lPrevWnd = 0
hXLDesk = 0
End Sub
Private Sub MessageLoop()
Dim aMsg As MSG
bXitLoop = False
On Error Resume Next
'ensure all Msgs are posted during the subclassing.
Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
DoEvents
PostMessage 0,aMsg.message, aMsg.wParam, aMsg.lParam
Loop
End Sub
Dim loword As Long,hiword As Long
Case WM_SETCURSOR
GetHiLoword lParam, loword, hiword
If hiword = WM_MOUSEMOVE Then
GetCursorPos tPt
End If
Private Sub GetHiLoword (lParam As Long, ByRef loword As Long, ByRef hiword As Long)
loword = lParam And &HFFFF&
hiword = lParam \ &H10000 And &HFFFF&
End Sub
MINMAXINFO
The minimum tracking width (x member) and the minimum tracking height (y member) of the window. This value can be obtained programmatically from the system metrics SM_CXMINTRACK and SM_CYMINTRACK
Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any,ByVal cbCopy As Long)
Type POINTAPI
x As Long : y As Long
End Type
Type MINMAXINFO
ptReserved As POINTAPI :ptMaxSize As POINTAPI
ptMaxPosition As POINTAPI :ptMinTrackSize As POINTAPI
ptMaxTrackSize As POINTAPI
End Type
Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long,ByVal wParam As Long,ByVal lParam As Long) As Long
Dim mmiT As MINMAXINFO
' Copy parameter to local variable for processing
کپی کردن lparam که منبع است به متغیر mmiT که مقصد است
CopyMemory mmiT, ByVal lParam, LenB(mmiT)
' Minimium width and height for sizing mmiT.ptMinTrackSize.x = 128
mmiT.ptMinTrackSize.y = 128
' Copy modified results back to parameter
CopyMemory ByVal lParam,mmiT, LenB(mmiT)
End Function
Declare PtrSafe Function SetWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32" (ByVal hWnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
Declare PtrSafe Function DefSubclassProc Lib "comctl32" (ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
TIMER :
A millisecond (from milli- and second; symbol: ms) is a thousandth (0.001 or 10−3 or 1/1000) of a second.
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr,ByVal nIDEvent As Long,ByVal uElapse As Long,ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr,ByVal nIDEvent As Long) As Long
Public TimerID As LongPtr
Dim lCount As Long
Sub SetTheTimer()
lCount = 0
TimerID = SetTimer(0&, 0&, 500, AddressOf TimerProc)
End Sub
Sub KillTheTimer()
KillTimer 0, TimerID
End Sub
Function TimerProc(ByVal hwnd As LongPtr,ByVal wMsg As Long,ByVal idEvent As LongPtr,ByVal dwTime As Long)
On Error Resume Next 'necessary
lCount = lCount + 1
Debug.Print "Timer callback " & lCount
If lCount = 10 Then KillTimer 0, TimerID
End Function
در یکی از برنامه‌های خبری شبکه بی‌بی‌سی عربی، وقتی از «مهدی عفیفی» به عنوان کارشناس درباره مسائل اوکراین پرسش شد، وی پس از مدت کوتاهی بعد از شروع صحبتش درباره این موضوع، ناگهان گفت: «موضوعی که می‌خواهم به آن اشاره کنم این است که بی‌بی‌سی دو سال است که پول برنامه‌های ما را نداده! مسئولان بی‌بی‌سی کجا هستند؟ چگونه می‌خواهید عدم پرداخت پول ما را توجیه کنید؟»
to 
تا
