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