SubClassing The Form

شوگر مامی" به زن ثروتمندی گفته می شود که با مردان جذاب، جوان و پویا وارد رابطه می شود، البته به طور قطع هر پسری تمایل به برقراری رابطه با شوگرمامی ها ندارد.

برای 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.

' winuser-getmessage

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⁻³ or ¹/₁₀₀₀) 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

در یکی از برنامه‌های خبری شبکه بی‌بی‌سی عربی، وقتی از «مهدی عفیفی» به عنوان کارشناس درباره مسائل اوکراین پرسش شد، وی پس از مدت کوتاهی بعد از شروع صحبتش درباره این موضوع، ناگهان گفت: «موضوعی که می‌خواهم به آن اشاره کنم این است که بی‌بی‌سی دو سال است که پول برنامه‌های ما را نداده! مسئولان بی‌بی‌سی کجا هستند؟ چگونه می‌خواهید عدم پرداخت پول ما را توجیه کنید؟»