WNDPROC

متغیرهایی تعریف شده که زمان ارجاع به آن راحت باشید و مقادیری را به آن تخصیص بدهید با Private Type و مشخص کردن نام و دیتا تایپ آن.

Private Type CUSTOM_MSGBOX lTimeout As Long
lExitButton As Long
lInterval As Long
strPrompt As String
End Type

Public cm As CUSTOM_MSGBOX

برای آفیس 32 بیت است نه 64 برای 64 باید Longptr شود .

Private Function WinProc(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 

Dim hwndCaption As Long 

Dim CurrentStyle As Long 

Dim ClassName As String 

Dim lResult As Long 

Dim Timeout As Long 

اگر پنجره ای فعال شد می بایست ClassName آنرا گرفته و چنانچه 32770 بود یعنی درست است و مطمئن میشوید که خود پنجره مسیج باکس است.

If lMsg = HCBT_ACTIVATE Then

ClassName = Space(256)

lResult = GetClassNameA(wParam, ClassName, 256)

If Left(ClassName, lResult) = "#32770" Then

' Make sure we spotted a messagebox (dialog)

hwndMsgBox = wParam 

Timeout = cm.lInterval 

'IIntrval=10000 Miliseconds

If Timeout = 0 Then

Timeout = cm.lTimeout 

If cm.lTimeout Then 

در اینجا تابع SetTimer عمل میکند و تابع TimeHandler اجرا می شود 

lTimerHandle = SetTimer(0&, 0&, Timeout, AddressOf TimerHandler)

از بین بردن hook که توسط SetWindowsHookEx نصب شده

'Remove Hook Procedure installed By a hook chaib  SetWindowsHookEx 

UnhookWindowsHookEx hHook 

End If

End If 

این خط مهم است وگرنه خطا ایجاد میکند.

WinProc = False 

End Function 

Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long 

Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long

Private Declare Function PostMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Function SetDlgItemTextA Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long 

Private Const WM_LBUTTONDOWN = &H201

Private Const WM_LBUTTONUP = &H202

Public Const IDPROMPT = &HFFFF&

Public Sub TimerHandler(hwnd As Long, uMSG As Integer, idEvent As Integer, dwTime As Double)

Dim hWndTargetBtn As Long

cm.lTimeout = cm.lTimeout - cm.lInterval  SetDlgItemTextA hwndMsgBox,IDPROMPT,

 Replace(cm.strPrompt, "%T",CStr(cm.lTimeout / 1000)) 

If cm.lTimeout <= 0 Then

hWndTargetBtn = GetDlgItem(hwndMsgBox, cm.lExitButton) 

' set the focus to the target button and ' simulate a click to close the dialog and ' return the correct value

فوکس را به باتن مقصد می برد و پیام ویندوزی LButtonDown و سپس LButtonUp را به پنجره باتن ارسال میکند و در نتیجه Close انجام میشود ( یک کلیک را تصویر گری می کند )

If hWndTargetBtn <> 0 Then 

SetFocus hWndTargetBtn

DoEvents

Call PostMessageA(hWndTargetBtn, WM_LBUTTONDOWN, 0, ByVal 0&)

Call PostMessageA(hWndTargetBtn, WM_LBUTTONUP, 0, ByVal 0&)

End If 

End If 

End Sub 

Private hHook As Long

Public hwndMsgBox As Long

Public lTimerHandle As Long

Public hAppInstance As Long

Public Function vbTimedMsgBox(Prompt As String,Optional Buttons As VbMsgBoxStyle = vbOKOnly,Optional Title As String, Optional Timeout As Long = 0,Optional Tick As Long = 1000,Optional DefaultExitButton As ExitButton = IDOK) As Long 

cm.lTimeout = TimeOut

cm.lExitButton = DefaultExitButton

hAppInstance =GetWindowLong(hWndAccessApp, GWL_HINSTANCE) 

' Access specific. In VB, this would be App.hInstance

hHook = SetWindowsHookEx(WH_CBT, AddressOf WinProc, hAppInstance, 0)

vbTimedMsgBox = MsgBox(Prompt, Buttons, Title) 

End Function

این یک نمونه کار است هر زمان که توابع API را مطالعه کردید می توانید با چیدمان درست کدها به مقاصد خود دست یابید البته هوک کردن مشکل است اگر خطایی اتفاق بیافتد سیستم هنگ خواهد کرد به WSCRIP.SHELL و POPUT هم می توان مراجعه کرد .

CREATEOBJECT("WSCRIPT.SHELL")

OBJECT.POPUP

Wscript Popup Method vbsedit

Echo Method vbsedit

Wscript.Shell + Shell.Application Objects shell.html

فرضا ساختن مرجع آبجکت یا شئ به یک فولدر با متد NAMESPACE از آبجکت SHELL.APPLICATION

filesystemobject-object

FolderItems.Count property :

Contains the number of items in the collection.


ssfWINDOWS = 36

Dim objShell,objFolder As Object

Set objShell =CreateObject("Shell.Application")

Set objFolder = objShell.NameSpace(ssfWINDOWS)

Set objFolderItems = objFolder.Items

nCount = objFolderItems.Count

Debug.Print nCount

WM_MOUSEMOVE در Custom Draw Control

---

برگرفته از فروم خارجی 

Dim r As RECT

(HWND h=GetDlgItem(hwndDlg,IDC_YOURCTLID

GetWindowRect h, r ' get window rect of control relative to screen

POINT pt={r.left,r.top } 'new point object using rect x, y

Above means ->>>??? pt.x=r.left:pt.y=r.top '

ScreenToClient hwndDlg,pt ' convert screen co-ords to

 client based points

example if I wanted to move said control'

-MoveWindow h,pt.x,pt.y+15,r.right-r.left, r.bottom

(r.top,TRUE

 r.right - r.left, r.bottom - r.top to keep control at its '

current size

---

برگرفته از فروم خارجی

(void CMyButton::OnTimer(UINT nIDEvent

()DWORD GetMessagePos'

Point p(GetMessagePos

Dim p As PONIAPI And p=GetMessagePos ??? '

'BOOL ScreenToClient(HWND hWnd,LPPOINT lpPoint'

ScreenToClient hBtn ,p

(Get the bounds of the control (just the client area '
 CRect rect

(BOOL GetClientRect(HWND hWnd,LPRECT lpRect'

GetClientRect hBtn,rect

 Check the mouse is inside the control '

(BOOL PtInRect(const RECT *lprc,POINT pt'

if PtInRect(rect,p)<>0 Then

Else
 ...if not then stop looking '
m_bOverControl=FALSE

(BOOL KillTimer(HWND hWnd,UINT_PTR uIDEvent'

KillTimer lhwnd,m_nTimerID

 ...and redraw the control '
  InvalidateRect ? Or Redraw 

CButton::OnTimer(nIDEvent ??? '

تایمر در توابع API

مربوط به 32 بیت 

Declare Function SetTimer Lib “user32” (ByVal hWnd As Long, ByVal nIDEvent_ As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

Declare Function KillTimer Lib “user32” (ByVal hWnd As Long, _ ByVal nIDEvent As Long) As Long

Dim timerID As Long

Create a timer that sends a notification every 500'

milliseconds. 

(timerID = SetTimer(0, 0, 500, AddressOf Timer_CBK

Destroy the timer created previously '

KillTimer  0,timerID

Sub Timer_CBK(ByVal hWnd As Long, ByVal uMsg As Long, _ ByVal idEvent As Long, ByVal SysTime As Long)

 Just display the system time in a label control '

Form1.lblTimer = SysTime 

End Sub