مقایسه VB و C++ از نظر سرعت ترجمه
شاید وقتی یک برنامه ی ساده که عملیات سنگینی نداره رو مینویسیم با مشکل سرعت اجرا مواجه نشیم.اما گاهی یکی از بزرگترین مشکل ها همین سرعت اجرا هستش.مثلا یک بازی کامپیوتری 3 بعدی به خاطر اینکه روون باشه و اصلا بشه باش بازی کرد باید تا اونجا که ممکنه سرعت اجرای کد رو بالا برد.

میخوام یک کد ساده رو با VB و با سی بنویسم و کامپایل کنم و اختلاف زمان اجرای این کد روببینیم.
کارش ساده هستش.یه حلفه ی معمولی که 1000 بار تکرار میشه و هر بار 0.00001 به یک مقدار double اضافه میکنه.

*** کد VB ***
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Form_Load()
Dim start_time As Long: start_time = GetTickCount()
Dim i As Double: i = 0
Do While (i < 1000)
i = i + 0.00001
Loop
Dim op_time As Long: op_time = GetTickCount() - start_time
MsgBox "Elapsed time : " & op_time & "ms"
End Sub

*** كد C++ ***
#include "stdafx.h"
#include "windows.h"
#include "stdio.h"
#include "conio.h"
int main(int argc, char* argv[])
{
DWORD start_time = GetTickCount();
double i=0;
while (i < 1000) {
i += 0.00001;
}
DWORD op_time = GetTickCount() - start_time;
printf("Elapsed time : %dms\n",op_time);
getch();
return 0;
}

نتایج :
C++ : 437 میلی ثانیه
VB : 2047 میلی ثانیه
یعنی یه چیزی بیشتر از 5 برابر توی این عملیات سرعت C++ بیشتر هستش.

****************************************
ایا میدانید ...
تعداد خطوط برنامه نویسی شده در ویندوز 95 تعداد 11.2 میلیون خط بوده است در حالیكه در ویندوز ویستا ، حداقل 50 میلیون خط برنامه وجود دارد. برای تولید ویندوز 95 دقیقا 200 برنامه نویس مشغول به كار بودند و در ویندوز ویستا 2000 برنامه نویس به صورت همزمان مشغول به كار بوده‌اند.

****************************************
برنامه نویسی API : ساخت یک Bitmap در حافظه و كار با آن
فرض كنين در VB يا مثلا در ++C ميخواهين يكسري عمليات گرافيكي مثل رسم خط ِاشكال مختلف و يا يك عكس و غيره رو انجام بدين و نتيجه رو روي پنجره ي اصلي نشون بدين.ميدونين هر پنجره يه DC يا Device Context داره و با استفاده از هندل اون یعنی hDC ی پنجره ی اصلی میشه روش عملیات گرافیکی رو انجام داد که عملیات همزمان روی پنجره ظاهر میشن.ولی مساله اینه که اگه پنجره رو تکون بدیم و یا پنجره ی دیگه ای روی پنجره مون بیاد محتویات ما تا زمانی که دوباره رسم بشن پاک میشن.توی VB ما واسه رفع این مشکل میتونیم AutoRedraw ی فرممون رو True کنیم ولی در یک برنامه ی Win32 ی معمولی مثل++C یا اسمبلی این طور نیست.در ضمن شاید ما بخواههیم توی VB هم اول کلیه عملیاتمون رو انجام بدیم و بعد روی فرم رسمشون کنیم و یا اصلا چند جا واسه رسم داشته باشیم و هر موقع خواستیم یکدوم رو نشون بدیم.کاری که با استفاده مستقیم از hDC فرم امکان پذیر نیست.
حالا راه حل چیه؟
ما میاییم یه بخش از حافظه رو به عنوان جایی که میخواهیم عملیاتمون رو انجام بدیم در نظر میگیریم و هر چیزی میخواهیم توی اون ناحیه انجام میدیم و بعد نتیجه رو روی پنجره نمایش میدیم. تغییراتی که روی حافظه میدیم تا وقتی ما نخواهییم روی پنجره ی اصلی نمایش داده نمیشن.و هربار که مثلا با اومدن یک پنجره روی پنجرمون,محتویاتی که روی پنجره درج شده پاک شدن دوبار تصویر رو روی پنجره رسم میکنیم.در واقع ما از یک واسطه برای رسم روی پنجره استفاده میکنیم تا اطلاعات تصویر رو هیچوقت از دست ندیم.
خوب! حالا با چه کدی ؟
ما میخواهیم یک بخش از حافظه رو به عنوان یک Bitmap در نظر بگیریم و عملیات گرافیکی رو روش انجام بدیم.واسه اینکار از تابع CreateCompatibleBitmap استفاده میکنیم و یک Bitmap سازگار با پنجره ی مورد نظرمون درست میکنیم :

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

آرگومان اول hDC ی پنجره ایه که میخواهیم رسم نهایی رو روش انجام بدیم.و آرگومان های بعدی هم طول و عرض Bitmap مورد نظرمون هست.در واقع این تابع یک Bitmap با طول و عرض معین برای ما در حافظه درست میکنه و هندلش رو برگشت میده.

مرحله ی بعدی اینکه که ما باید یکHandle Device Context برای این بیت مپ داشته باشیم تا بتونیم از طریق اون عملیات رسم رو انجام بدیم.واسه ساختن اون از CreateCompatibleDC استفاده میکنیم :

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

که آرگومان هم hDC ی پنجره ی مورد نظره.
حالا باید Bitmap ی که ساختیم رو به hDC ی جدیدمون وصل کنیم.واسه این کار از SelectObject استفاده میکنیم :

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

در واقع با این کار هر گونه عملیاتی که روی hDC ی جدید انجام بشه روی Bitmap ما اعمال میشه.یادتون باشه بعد از هر Select کردن, وقتی دیگه نیازی نبود از DeleteObject استفاده میکنیم و ارتباط این 2 تا رو قطع و حافظه رو آزاد میکنیم :

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

حالا بعد از Select کردن میتونین هر عملیاتی مانند رسم خط,متن,مستطیل و ... رو روی hDC ی جدید اعمال کنین و نتیجه روی Bitmap ما اعمال میشه.در مورد این رسم ها بعدا توضیح میدم.

بعد از اون فقط میمونه انتقال مداومBitmap از حافظه روی صفحه ی پنجرمون بعد از هر تغییر توی پنجره.
توی یک W32 Application توی C++ یا ASM این کار رو توی Procedure اصلی و با گرفتن پیغام WM_PAINT باید انجام داد.البته بین 2 تابع BeginPaint و EndPaint :

Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long


این تابع پنجره رو آماده ی رسم میکنه.آرگومان اول هندل پنجره و دومی یه متغیر از نوع PAINTSTRUCT که نیازی هم به مقدار دهیش نیست.خود تابع اون رو مقدار دهی میکنه و اطلاعات رسم رو توش قرار میده.

Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long

این تابع رو هم بعد از عملیات رسم فراخوانی میکنیم.آرگومان اول هندل پنجره و دومی هم همون متغیری که موقع فراخوانی BeginPaint استفاده کردیم.

ولی توی ویژوال بیسیک لازم به استفاده از این 2 تابع نیست فقط باید AutoRedraw ی فرم False باشه.
عملیات انتقال رو توی روال Form_Paint انجام میدیم.در واقع بعد از هر تغییر توی محیط پنجره,روال Form_Paint خود به خود فراخوانی میشه و ما دوباره Bitmap رو از حافظه روی فرم کپی میکنیم تا تغییری توی چیزی که رسم کرده بودیم ایجاد نشه.

واسه این کار از تابع هایی مثل BitBlt , StrechBlt و TransparetBlt میشه استفاده کرد که ساده ترینشون BitBlt هستش که قبلا در موردش گفتم,برای کپی کردن محتویات یک DC روی یک DC ی دیگست.کاری که الان میخواهیم بکنیم. یعنی محتویات DC ی جدیدمون که به Bitmap ی که ساختیم متصل هست رو توی فرم کپی کنیم.

این یک کد نمونه که کل کاری که تاحالا در موردش نوشتم رو انجام میده و یک Bitmap خالی 100x100 رو که چون خالیه رنگش مشکیه رو روی فرم رسم میکنه.چون هنوز روش کار با تابع هایی واسه رسم اشکال و ... نگفتم اینجا هم چیزی رسم نمیشه و فقط یک صفحه ی سیاهه:


Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source


Dim hCmpDC As Long, hBmp As Long


Private Sub Form_Load()

hCmpDC = CreateCompatibleDC(Me.hdc)
hBmp = CreateCompatibleBitmap(Me.hdc, 100, 100)
Call SelectObject(hCmpDC, hBmp)

End Sub

Private Sub Form_Paint()

Dim ps As PAINTSTRUCT
If (hCmpDC) Then
Call BitBlt(Me.hdc, 0, 0, 100, 100, hCmpDC, 0, 0, SRCCOPY)
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

DeleteObject (hBmp)
DeleteDC (hCmpDC)

End Sub

البته بهتره بعد از فراخوانی تابع های CreateCompatibleDC/Bitmap چک کنیم که اگه تابع ها با موفقیت کار نکردن برنامه رو متوقف یا مسیرش رو عوض کنیم. این رو از مقدار برگشتی میشه فهمید کافیه یه سر به MSDN بزنین

***********************
ادامه امــــــــــــــــــــــــــــــــــــــــوزش

الان میخوام کدی رو بگذارم که باهاش میشه اون Bitmap رو توی یک فایل با فرمت .bmp ذخیره کرد.

وقتی قبلا تابع BitBlt رو توضیح میدادم روش عکس گرفتن از صفحه ی نمایش(Screen Shot) رو توی ویبی و با استفاده از فرم گفتم.توی اون روش با این تابع اول محتویات صفحه ی نمایش توی فرم کپی میشد و بلافاصله با تابع داخلی ویبی یعنی SavePicture اون عکس توی فایل ذخیره میشد.حالا میخواییم بدون استفاده از اون فرم و درواقع با Bitmap ی که خودمون توی حافظه درست کردیم اون عکس رو بگیریم و save کنیم.یه قسمت از کد مثل پست قبله با این فرق که دیگه ما اصلا با فرم کاری نداریم و با صفحه ی نمایش کار داریم واسه همین بجای اینکه فرم رو بستر قرار بدیم و از HDC ش برای تابع CreateCompatableDC استفاده کنیم ایندفه با تابع CreateDC یک Device Context درست میکنیم و ازش استفاده میکنیم و آخر سر هم Delete ش میکنیم.برای ساختن یک Device Context از صفحه ی نمایش و گرفتن یک هندل از اون کافیه آرگومان اول تابع(Driver Name) رو “DISPLAY” قرار بدین و بقیه رو نال (Byval 0&) . بعد از اون با BitBlt محتویات رو توی Bitmap ی که ساختیم کپی میکنیم و اون رو توی فایل Save میکنیم

Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const BI_bitfields = 3&
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = 2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_BEGIN = 0
Private Const FILE_CURRENT = 1
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Private Type BITMAPFILEHEADER
bfType As Integer
bfSize As Long
bfReserved1 As Integer
bfReserved2 As Integer
bfOffBits As Long
End Type

Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(256) As RGBQUAD
End Type

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long

Private Sub Form_Load()
Dim retval As Long
retval = ScreenShot
If (retval) Then
MsgBox "Error (" & retval & ")"
Else
MsgBox "Succeed!", vbInformation
End If
Unload Me
End Sub

Private Function ScreenShot()
Dim scrWidth As Long, scrHeight As Long
Dim hScreenDC As Long, hCmpDC As Long, hBmp As Long
scrWidth = Screen.Width / 15
scrHeight = Screen.Height / 15
hScreenDC = CreateDC("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
hCmpDC = CreateCompatibleDC(hScreenDC)
hBmp = CreateCompatibleBitmap(hScreenDC, scrWidth, scrHeight)
Call SelectObject(hCmpDC, hBmp)
BitBlt hCmpDC, 0, 0, scrWidth, scrHeight, hScreenDC, 0, 0, SRCCOPY
Call BitmapToFile(hBmp, hCmpDC, Screen.Height / 15, "d:\mm.bmp")
DeleteObject (hBmp)
DeleteDC (hCmpDC)
DeleteDC (hScreenDC)
End Function

Private Function BitmapToFile(hBmp As Long, hCmpDC As Long, nHeight As Long, FileName As String) As Long
Dim BInfo As BITMAPINFO
BInfo.bmiHeader.biSize = 40
If (GetDIBits(hCmpDC, hBmp, 0, nHeight, ByVal 0&, BInfo, DIB_RGB_COLORS) = 0) Then
BitmapToFile = 1
Exit Function
End If
Dim BBits() As Byte
ReDim BBits(0 To BInfo.bmiHeader.biSizeImage - 1) As Byte
If (GetDIBits(hCmpDC, hBmp, 0, nHeight, BBits(0), BInfo, DIB_RGB_COLORS) = 0) Then
BitmapToFile = 2
Exit Function
End If
Dim BFheader As BITMAPFILEHEADER
BFheader.bfType = 19778
BFheader.bfReserved1 = 0
BFheader.bfReserved2 = 0
Dim hFile As Long: Dim SA As SECURITY_ATTRIBUTES
hFile = CreateFile(FileName, GENERIC_WRITE, 0, SA, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If (hFile = -1) Then
BitmapToFile = 3
Exit Function
End If
Dim bWritten As Long
WriteFile hFile, BFheader, Len(BFheader), bWritten, ByVal 0&
WriteFile hFile, BInfo.bmiHeader, 40, bWritten, ByVal 0&
Dim nPalette As Long
If (BInfo.bmiHeader.biClrUsed) Then
nPalette = lbinfo.bmiHeader.biClrUsed
Else
If (BInfo.bmiHeader.biCompression = BI_bitfields) Then
nPalette = 3
Else
nPalette = IIf(BInfo.bmiHeader.biBitCount <= 8, 2 ^ BInfo.bmiHeader.biBitCount, 0)
End If
End If
If (nPalette) Then
WriteFile hFile, BInfo.bmiColors(0), nPalette * 4, bWritten, ByVal 0&
End If
BFheader.bfOffBits = SetFilePointer(hFile, 0, 0, FILE_CURRENT)
WriteFile hFile, BBits(0), BInfo.bmiHeader.biSizeImage, bWritten, ByVal 0&
BFheader.bfSize = SetFilePointer(hFile, 0, 0, FILE_CURRENT)
Call SetFilePointer(hFile, 0, 0, FILE_BEGIN)
WriteFile hFile, BFheader.bfType, Len(BFheader.bfType), bWritten, ByVal 0&
Call ReverseWriteLong(hFile, bWritten, BFheader.bfSize)
WriteFile hFile, BFheader.bfReserved1, 2, bWritten, ByVal 0&
WriteFile hFile, BFheader.bfReserved2, 2, bWritten, ByVal 0&
Call ReverseWriteLong(hFile, bWritten, BFheader.bfOffBits)
closefile:
CloseHandle (hFile)
BitmapToFile = 0
End Function

Private Sub ReverseWriteLong(hFile As Long, ByRef bWritten As Long, ByVal DWORD As Long)
WriteFile hFile, loWord(DWORD), 2, bWritten, ByVal 0&
WriteFile hFile, hiWord(DWORD), 2, bWritten, ByVal 0&
End Sub

Private Function hiWord(ByVal DWORD As Long) As Integer
Dim hWord As Integer
Call CopyMemory(hWord, ByVal (VarPtr(DWORD) + 2), 2)
hiWord = hWord
End Function

Private Function loWord(ByVal DWORD As Long) As Integer
Dim lWord As Integer
Call CopyMemory(lWord, ByVal (VarPtr(DWORD)), 2)
loWord = lWord
End Function

****************************
برنامه نویسی APi : كار با Joy Stice با API

اولين تابعي كه ميخوام در موردش توضيح بدم تابع joyGetNumDevs هستش :

Private Declare Function joyGetNumDevs Lib "winmm.dll" () As Long

كه تعداد جوي استيك هايي كه درايور ساپورت ميكنه رو برميگردونه.براي من 16 هستش.
براي بدست آوردن اطلاعات در مورد جوي استيك از تابع joyGetDevCaps استفاده ميشه :

Private Declare Function joyGetDevCaps Lib "winmm.dll" Alias "joyGetDevCapsA" (ByVal id As Long, lpCaps As JOYCAPS, ByVal uSize As Long) As Long

آرگومان اول آيدي جوي استيك هستش كه ميتونه يكي از اين 2 مقدار باشه :

Private Const JOYSTICKID1 = 0
Private Const JOYSTICKID2 = 1

آرگومان دومي متغيري از نوع JOYCAPS هستش كه مشخصات جوي استيك رو تابع درون اين قرار ميده:

Private Type JOYCAPS
wMid As Integer
'مربوط به مايكروسافت ميشه MM_MICROSOFT آيدي توليدي كه جوي استيك رو توليد كرده مثلا
wPid As Integer
'آيدي محصول(جوي استيك)
szPname As String * MAXPNAMELEN
'اسم جوي استيك
wXmin As Integer
wXmax As Integer
wYmin As Integer
wYmax As Integer
wZmin As Integer
wZmax As Integer
'x,y,z حداقل و حداكثر مختصات جوي استيك توي جهت هاي مختلف
wNumButtons As Integer
'تعداد دكمه هاي جوي استيك
wPeriodMin As Integer
wPeriodMax As Integer
' (Polling frequency) حداقل و حداكثر تعداد پيغام هايي كه جوي استيك ميتونه توي 1 صدم ثانيه به برنامه ارسال كنه
End Type

البته اين ساختار چند تا متغير ديگه هم آخرش داره اما ايني كه من توي API Viewer ديدم نداشت منم ديگه بيخيال بقيش شدم...

آرگومان بعدي هم طول اين متغير هستش.
مقدار برگشتي تابع هم نشون ميده كه درست كار كرده يا نه :

JOYERR_NOERROR 'هيچ خطايي اتفاق نيفتاده
MMSYSERR_NODRIVER '(:Pدرايور جوي استيك آماده نيست(اشكال از فرستندس
MMSYSERR_INVALPARAM 'پارامتر هايي كه به تابع ارسال شده مشكل دارن

بعد از فراخواني تابع بايد برين سراغ متغيري كه به تابع ارسال شده و اطلاعات مورد نظر رو دريافت كنين:

Option Explicit
Private Declare Function joyGetDevCaps Lib "winmm.dll" Alias "joyGetDevCapsA" (ByVal id As Long, lpCaps As JOYCAPS, ByVal uSize As Long) As Long
Private Declare Function joyGetNumDevs Lib "winmm.dll" () As Long
Private Const JOYSTICKID1 = 0
Private Const JOYSTICKID2 = 1
Private Const JOYERR_NOERROR = (0) ' no error
Private Const MMSYSERR_BASE = 0
Private Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Private Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Private Const MAXPNAMELEN = 32 ' max product name length (including NULL)


Private Type JOYCAPS
wMid As Integer
wPid As Integer
szPname As String * MAXPNAMELEN
wXmin As Integer
wXmax As Integer
wYmin As Integer
wYmax As Integer
wZmin As Integer
wZmax As Integer
wNumButtons As Integer
wPeriodMin As Integer
wPeriodMax As Integer
End Type
Dim JC As JOYCAPS
Private Sub Form_Load()
Me.AutoRedraw = True
Print "Number of joys supported : " & joyGetNumDevs
Dim jResult As Long
jResult = joyGetDevCaps(JOYSTICKID1, JC, Len(JC))
If (jResult = JOYERR_NOERROR) Then 'succeed
Print "Product name : " & Left$(JC.szPname, InStr(1, JC.szPname, Chr(0)) - 1)
Print "Manufacture id : " & JC.wMid
Print "Number of buttons : " & JC.wNumButtons
Print "Period max : " & JC.wPeriodMax
Print "Period min : " & JC.wPeriodMin
Print "Product id : " & JC.wPid
Print "X max : " & JC.wXmax
Print "X min : " & JC.wXmin
Print "Y max : " & JC.wYmax
Print "Y min : " & JC.wYmin
Print "Z max : " & JC.wZmax
Print "Z min : " & JC.wZmin
Else
If (jResult = MMSYSERR_NODRIVER) Then
Print "Error : Driver is not ready!"
ElseIf (jResult = MMSYSERR_INVALPARAM) Then
Print "Error : Invalid parameter(s)"
Else
Print "Error : Unknown error"
End If
End If
End Sub

تابع بعدي joyGetPos هستش كه براي بدست آوردن وضعيت مكان و دكمه هاي جوي استيك بكار ميره :

Private Declare Function joyGetPos Lib "winmm.dll" Alias "joyGetPos" (ByVal uJoyID As Long, pji As JOYINFO) As Long

آرگومان اول همون آيدي جوي استيك هستش كه در موردش گفتم.دومي هم يه متغير از نوع JOYINFO هستش كه وضعيت حوي استيك توش قرار ميگيره :

Private Type JOYINFO
wXpos As Long
wYpos As Long
wZpos As Long
wButtons As Long
End Type

سه تا متغير اولي كه مشخصه.مربوط به طول و عرض و ارتفاع هستن.دومي هم مربوط به وضعيت دكمه هاست :

JOY_BUTTON1 'دكمه اول فشرده شده
JOY_BUTTON2 'دكمه ي دوم فشرده شده
JOY_BUTTON3 'دكمه ي سوم فشرده شده
JOY_BUTTON4 'دكمه ي چهارم فشرده شده

مقدار برگشتي هم مثل تابع قبل هستش با اين فرق كه اگه مقدار JOYERR_UNPLUGGED برگشت بشه يعني اينكه جوي استيك به سيستم connect نشده:

Option Explicit
Private Type JOYINFO
wXpos As Long
wYpos As Long
wZpos As Long
wButtons As Long
End Type
Private Declare Function joyGetPos Lib "winmm.dll" (ByVal uJoyID As Long, pji As JOYINFO) As Long
Private Const JOYSTICKID1 = 0
Private Const JOYSTICKID2 = 1
Private Const JOYERR_NOERROR = (0) ' no error
Private Const MMSYSERR_BASE = 0
Private Const MMSYSERR_INVALPARAM = (MMSYSERR_BASE + 11) ' invalid parameter passed
Private Const MMSYSERR_NODRIVER = (MMSYSERR_BASE + 6) ' no device driver present
Private Const JOYERR_BASE = 160
Private Const JOYERR_UNPLUGGED = (JOYERR_BASE + 7) ' joystick is unplugged


Private Sub Form_Load()
Dim JI As JOYINFO
Dim jResult As Long
Me.AutoRedraw = True
jResult = joyGetPos(JOYSTICKID1, JI)
If (jResult = JOYERR_NOERROR) Then
Print "X : " & JI.wXpos
Print "Y : " & JI.wYpos
Print "Z : " & JI.wZpos
Print "Button : " & JI.wButtons
Else
If (jResult = MMSYSERR_NODRIVER) Then
Print "Error : Driver is not ready!"
ElseIf (jResult = MMSYSERR_INVALPARAM) Then
Print "Error : Invalid parameter(s)"
ElseIf (jResult = JOYERR_UNPLUGGED) Then
Print "Error : Joystick is not connected!"
Else
Print "Error : Unknown error"
End If
End If
End Sub

تابع بعدي joyGetPosEx هستش كه كار تابع قبلي رو به صورت گستره تري انجام ميده و براي كار كردن با دستگاه هاي پيشرفته مثل دسته هايي كه دكمه زياد دارن يا كلاه ها يا ... بكار ميره.اگه ميخواهين با يه جوي استيك معمولي كار كنين برين سراغ تابع قبلي:

Private Declare Function joyGetPosEx Lib "winmm.dll" Alias "joyGetPosEx" (ByVal uJoyID As Long, pji As JOYINFOEX) As Long

آرگومان اول آيدي جوي استيك و دومي هم يه متغير از نوع JOYINFOEX هستش :

Private Type JOYINFOEX
dwSize As Long 'طول ساختار كه بايد قبل از ارسال به تابع مقدار دهيش كنين
dwFlags As Long ' ي كه با مقدار دهي كردنش بايد مشخص كنيم چه اطلاعاتي رو تابع براي ما برگردونهflag
dwXpos As Long ' xموقيعت
dwYpos As Long ' y موقيعت
dwZpos As Long ' z موقيعت
dwRpos As Long ' بعد ديد چهارم
dwUpos As Long ' بعد ديد پنجم
dwVpos As Long ' بعد ديد ششم
dwButtons As Long ' وضعيت دكمه ها
dwButtonNumber As Long ' تعداد دكمه هايي كه فشرده شدن
dwPOV As Long ' زاويه ديد
dwReserved1 As Long ' رزور شده
dwReserved2 As Long ' رزرو شده
End Type

چيزي كه در مورد اين ساختار بايد توجه كنين Flags هستش كه با دادن مقدار هاي مختلف بايد به تابع گفت كه در چه مورد اطلاعات ميخواهيم كه مقاديري كه بش ميشه داد خيلي زياده و ديگه من بيخيالش ميشم توي MSDN انواع مقدار ها با توضيحاتشون هست...
كار بااين تابع هم مثل كدي قبلي هستش فقط همونطور كه گفتم بايد قبل از ارسال متغير به تابع مقدار dwSize رو برابر طول متغير قرار بدين :

JI.dwSize = Len(JI)

مقدار برگشتي هم مثل قبليه فقط اگه MMSYSERR_BADDEVICEID باشه يعني اينكه آيدي جوي استيك غير قابل قبول هستش... .

حالا ميريم سراغ اصل كاري يعني capture كردن جوي استيك .

كلا روش كلي براي اين كه يك جوي استيك رو كنترل كنيم و بفهميم كي حركت ميكنه يا دكمه هاش فشرده ميشه اينه كه با دادن هندل پنجره به تابع joySetCapture پيغام هايي كه به پنجره مياد رو كنترل كنيم.در واقع تابع joySetCapture باعث ميشه هنگام هر گونه رويداد توسط جوي استيك(يا بطور متناوب) يك پيغام به پنجره اي كه هندلش رو به تابع داديم ارسال بشه و با توجه به تابعي كه ما براي كنترل پنجره نوشتيم ميتونيم نوع رويداد و مشخصات رويداد رو مشخص كنيم.اگه قسمت Messages ها ي اين وبلاگ رو نخوندين بد نيست اول اون رو بخونين تا بهتر اين قضيه رو متوجه بشين.
پيغام هايي كه توسط جوي استيك به پنجره مورد نظر ارسال ميشه :

MM_JOY1BUTTONDOWN

اين پيغام وقتي ارسال ميشه كه يكي از دكمه هاي جوي استيك اول فشرده بشه.همونطور كه ميدونين وقتي يه پيغام به يه پنجره ارسال ميشه 2 تا مقدار هم به عنوان wParam و lParam به پنجره ارسال ميشن.در اين حالت مقدار wParam نشون ميده كه وضعيت كدوم يكي از دكمه هاي جوي استيك تغيير كرده :

JOY_BUTTON1CHG 'دكمه ي اول
JOY_BUTTON2CHG 'دكمه ي دوم
JOY_BUTTON3CHG 'دكمه ي سوم
JOY_BUTTON4CHG 'دكمه ي چهارم

و كدوم دكمه ها فشرده شدن(2 سري مقدار بصورت تركيبي بكارميرن) :

JOY_BUTTON1 'دكمه ي اول
JOY_BUTTON2 'دكمه ي دوم
JOY_BUTTON3 'دكمه ي سوم
JOY_BUTTON4 'دكمه ي چهارم

و توي lParam هم مختصات x و y جوي استيك قرار داره.به اين صورت كه توي دوبايت پاييني مختصات x و توي 2 بايت بالايي y

MM_JOY1BUTTONUP

مثل قبلي فقط براي رها شدن دكمه ي جوي استيك اول

MM_JOY1MOVE

اين پيغام وقتي ارسال ميشه كه جوي استيك اول حركت كنه
مقدار wParam دكمه هايي كه فشرده شدن رو نشون ميده :

JOY_BUTTON1 'دكمه ي اول
JOY_BUTTON2 'دكمه ي دوم
JOY_BUTTON3 'دكمه ي سوم
JOY_BUTTON4 'دكمه ي چهارم

مقدار lParam مثل قبلي هستش.

MM_JOY1ZMOVE

اين پيغام وقتي ارسال ميشه كه جوي استيك توي محور z ها مكانش تغيير كنه.
مقدار wParam مثل قبلي هستش و توي 2 بايت بالايي lParam هم مختصات z جوي استيك قرار ميگيره.

MM_JOY2BUTTONDOWN

مثل قبلي فقط براي جوي استيك دوم

MM_JOY2BUTTONUP

مثل قبلي فقط براي جوي استيك دوم

MM_JOY2MOVE

مثل قبلي فقط براي جوي استيك دوم

MM_JOY2ZMOVE

مثل قبلي فقط براي جوي استيك دوم

حالا ميريم سراغ خود تابع ها:

با تابع joySetThreshold ميشه تعيين كرد كه براي فرستادن پيغام به پنجره حداقل مكان جوي استيك چقدر تغيير كنه.يعني ما به با اين تابع به تابع joySetCapture ميگين كه تا وقتي كه جوي استيك اينقدر تغيير مكان نداده پيغام هاي مربوط به حركت (MM_JOY1MOVE, MM_JOY1ZMOVE, MM_JOY2MOVE, or MM_JOY2ZMOVE) رو براي پنجره ي ما نفرسته:

Private Declare Function joySetThreshold Lib "winmm.dll" Alias "joySetThreshold" (ByVal id As Long, ByVal uThreshold As Long) As Long

آرگومان اول آيدي جوي استيك و دومي مقدار مورد نظر هستش.مقدار برگشتيش هم مثل تابع joyGetDevCaps هستش

تابع joyGetThreshold هم مثل قبلي هستش با اين تفاوت كه براي گرفتن مقدار Threshold استفاده ميشه:

Private Declare Function joyGetThreshold Lib "winmm.dll" Alias "joyGetThreshold" (ByVal id As Long, lpuThreshold As Long) As Long

حالا ميريم سراغ تابع اصل كاري يعني joySetCapture كه توضيح كليش رو دادم :

Private Declare Function joySetCapture Lib "winmm.dll" Alias "joySetCapture" (ByVal hwnd As Long, ByVal uID As Long, ByVal uPeriod As Long, ByVal bChanged As Long) As Long

آرگومان اول هندل پنجره ي مورد نظر هستش.دومي آيدي جوي استيك سومي همون تعدادي هستش كه اول كار با تابع joyGetDevCaps مقدار حداقل و حداكثرش رو بدست آورديم يعني حداقل و حداكثر تعداد پيغام هايي كه جوي استيك ميتونه توي 1 صدم ثانيه به برنامه ارسال كنه (Polling frequency).

آرگومان آخر هم اگه True باشه تابع پيغام هاي حركتي رو فقط وقتي ارسال ميكنه كه تغيير حركت موس بيشتر از مقدار Threshold ي باشه كه با تابع joySetThreshold تنظيم كرديم.اگه False باشه به طور متناوب و بسته به مقدار Polling frequency تابع به پنجره ي ما پيغام ارسال ميكنه.در واقع اگه مقدار Threshold رو تنظيم كردين اين رو True بگذارين و گر نه False.

اگه كار تابع موفقيت آميز باشه مقدار برگشتي JOYERR_NOERROR هستش. در غير اين صورت :

MMSYSERR_NODRIVER 'درايور جوي استيك آماده نيست
JOYERR_NOCANDO 'يه مشكلي تو كار هستش(اينطور كه مايكروسافت گفته مثلا تايمر ويندوز فراهم نيست
JOYERR_UNPLUGGED 'نشده Connect جوي استيك به سيسيتم

اين رو هم بگم كه اگه از قبل تابع joySetCapture رو فراخواني كرده باشين و بخواهين دوباره فراخوانيش كنين تابع كار نميكنه.قبل از فراخواني دوباره بايد تابع joyReleaseCapture رو فراخواني كنين :

Private Declare Function joyReleaseCapture Lib "winmm.dll" Alias "joyReleaseCapture" (ByVal id As Long) As Long

در واقع وقتي كه ميخواهين تابع joySetCapture بيخيال پنجره ي شما بشه و ديگه كاري با جوي استيك ندارين و نميخواهين كنترلش كنين اين تابع رو بايد فراخواني كنين.آرگومانش هم همون آيدي جوي استيك هستش.

حالا بريم سراغ نوشتن تابع كنترل پيغام ها.
توي محيط اسمبلي يا مثلا C++ Visual سيستم كلي كد نويسي و كنترل پيغام ها توسط به تابع (Window Prodedure)هستش و اگه شما توي اين محيط ها بخواهين پيغام هاي فرستاده شده رو كنترل كنين كارتون خيلي راحته چون عملا دارين كد مربوط به كنترل پيغام ها رو ميبينين.اما توي محيط ويژوال بيسيك اين عمليات از برنامه نويس پنهان شده و شما فقط يكسري Event هاي از پيش تعيين شده مثل OnClick يا OnMouseDown يا ... رو ميبينين و دسترسي به پيغام هاي ديگه ندارين.اما حالا بايد چكار كرد؟
اگه ميخواهين يك بازي درست و حسابي درست كنين بهتره همين الان بيخيال ويبي شين و برين سراغ Visual C++. اما براي ويبي هم راه هايي پيدا ميشه :

يك راهش استفاده از توابع Hook و راه ديگش هم استفاده از تابع SetWindowLong هستش.اينجا من از روش دوم استفاده ميكنم اما صرفا قصد ندارم در مورد كنترل كردن پيغام هاي پنجره توضيح بدم و اين كار رو ميگذارم واسه يه پست ديگه.
اول با استفاده از تابع SetWindowLong تابع مربوط به كنترل پيغام ها رو كه بايد توي يك ماژول هم باشه مشخص ميكنيم:

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

و در همين حين آدرس تابع قبلي رو هم از تابع ميگيريم چون بعد از اينكه كارمون تموم شد ميخوايم وضعيت رو به حالت عادي برگردونيم. بعد يه تابع به صورت زير براي كنترل پيغام ها درست ميكنيم :

Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)

'Control messages here ...

End Function

تابع CallWindowProc رو هم براي اين استفاده ميكنيم كه پيغامي كه فرستاده ميشه رو به تابع كنترل اصلي(قبلي) هم بفرستيم و بعد كار كنترل پيغام هايي كه توسط تابع اصلي قابل كنترل نيستن رو انجام ميديم.

بعد هم دوباره با تابع SetWindowLong آدرس قبلي رو براي كنترل پيغام ها تعيين ميكنيم :

SetWindowLong Form1.hwnd, GWL_WNDPROC, PrevProc

براي مثال كد كلي ما براي كنترل پيغام هايي كه به از جوي استيك(1) براي فشرده شدن دكمه ها ارسال ميشه به اين صورت ميشه :

توي فرم 2 تا دكمه (يكي براي شروع و يكي براي پايان) بگذارين و اين كد رو وارد كنين :

Private Sub Command1_Click()
joySetCapture Form1.hwnd, JOYSTICKID1, 100, False
start
End Sub

Private Sub Command2_Click()
joyReleaseCapture JOYSTICKID1
finish
End Sub

و توي يك ماژول هم اين رو بگذارين :

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function joySetCapture Lib "winmm.dll" (ByVal hwnd As Long, ByVal uID As Long, ByVal uPeriod As Long, ByVal bChanged As Long) As Long
Public Declare Function joyReleaseCapture Lib "winmm.dll" (ByVal id As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Const WM_KEYDOWN = &H100
Public Const JOY_BUTTON1 = &H1
Public Const JOY_BUTTON3 = &H4
Public Const JOY_BUTTON2 = &H2
Public Const JOY_BUTTON4 = &H8
Public Const JOY_BUTTON1CHG = &H100
Public Const JOY_BUTTON2CHG = &H200
Public Const JOY_BUTTON3CHG = &H400
Public Const JOY_BUTTON4CHG = &H800
Public Const JOYSTICKID1 = 0
Public Const JOYSTICKID2 = 1
Dim PrevProc As Long
Public Const MM_JOY1BUTTONDOWN = &H3B5
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = MM_JOY1BUTTONDOWN Then
Form1.Print
Form1.Print "Joystick(1),Button down event occured : "
Form1.Print "Button changed : ";
If wParam And JOY_BUTTON1CHG Then
Form1.Print "one"
ElseIf wParam And JOY_BUTTON2CHG Then
Form1.Print "two"
ElseIf wParam And JOY_BUTTON3CHG Then
Form1.Print "three"
ElseIf wParam And JOY_BUTTON4CHG Then
Form1.Print "four"
End If
Form1.Print "Button(s) are pressed : ";
If wParam And JOY_BUTTON1 Then Form1.Print "one ";
If wParam And JOY_BUTTON2 Then Form1.Print "two ";
If wParam And JOY_BUTTON3 Then Form1.Print "three ";
If wParam And JOY_BUTTON4 Then Form1.Print "four "
Form1.Print
Form1.Print "X : " & Get_LoWord(lParam) & " Y : " & Get_HiWord(lParam)
End If
End Function
Public Sub start()
PrevProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub finish()
Call SetWindowLong(Form1.hwnd, GWL_WNDPROC, PrevProc)
End Sub
Function Get_LoWord(ByRef dword As Long) As Integer
CopyMemory Get_LoWord, ByVal VarPtr(dword), 2
End Function
Public Function Get_HiWord(ByRef dword As Long) As Integer
CopyMemory Get_HiWord, ByVal VarPtr(dword) + 2, 2
End Function

در ضمن 2 تا تابع آخر هم براي بدست آوردن دو بايت بالايي و دوبايت پاييني lParam استفاده ميشن


***************************
امــــــــــــــــــــــــــــــــــــــــــــوزش Process توسط API
امروز ميخوام در مورد كار با Process ها يكم بنويسم.مخصوصن در مورد بستن Process برنامه ها.

واسه بستن Processيه فايل اجرايي(طبق اين راهي كه من بلدم) :
اول بايد آيدي اون Process رو بدست بياريم.
بعد بايد با تابع OpenProcess يه هندل از اون Process بدست بياريم.
بعد با تابع TerminateProcess اون رو ببنديم .

واسه بدست آوردن آيدي Process با توجه به اطلاعاتي كه ما از اون برنامه داريم چند تا راه هست كه من 2 تاشو ميگم.
يكيش با استفاده از اسم يا مسير اون فايلي كه در حال اجراست.
يكيش با استفاده از داشتن هندل يكي از پنجره هاي اون برنامه.

توي راه اول ما با 3 تا تابع ليست Process ها و آيدي اونها رو بدست مياريم.هر كدوم اسمش با اسم مورد نظر ما يكي بود از آيديش استفاده ميكنيم و اون رو ميبنديم.

فعلا همينو ميگم بعد ميرم سراغ راه بعدي.
واسه ي كاري كه گفتم اول بايد با تابع CreateToolhelp32Snapshot (كه واسه بدست آوردن ليست Process ها و يا heap ها ، Module ها و... ي Process بكار ميره) يه هندل ليست از Process ها بدست بدست بياريم:

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long

بعد با تابع Process32First و Process32Next اطلاعاتي در مورد هر كدوم از Process ها مثل نام فايل و ProcessID و ... كه با بقيش فعلا كاري بدست بياريم:

Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long

البته اين روش تا اين مرحله فقط اسم فايل رو به ما ميده مثل (notepad.exe) نه آدرس كامل اون رو كه در مورد بدست آوردن آدرس كامل هم توضيح ميدم.

آرگومان اول تابع CreateToolhelp32Snapshot بستگي به ليستي كه ميخواهيم بدست بياريم داره كه ما اينجا چون ميخواهيم ليست همه ي Process هاي سيستم رو بدست بياريم اون رو Private Const TH32CS_SNAPPROCESS = &H2 ميگذاريم.

آرگومان بعدي هم آيدي Process يه كه ميخواهيم در موردش اطلاعات بدست بياريم كه چون ما اينجا نميخواهيم اطلاعاتي (ليست Module ها و ...) در مورد Process خاصي بدست بياريم (چون هنوز IDيي نداريم) و فعلا ميخواهيم خود ليست Process ها رو بدست بياريم و آرگومان اول رو هم TH32CS_SNAPPROCESS قرار داديم اينجا هرچي بگذاريم فرقي نداره. آرگومان دوم براي وقتيه كه آرگومان اول رو چيز ديگه اي بغير از ايني كه ما الان گذشتيم بگذاريم...(فكر كنم زيادي توضيح دادم!!!!)

حالا براي شروع بدست آوردن اطلاعات مورد نظرمون از Process32First استفاده ميكنيم.آرگومان اول هندليه كه با تابع قبلي بدست آورديم.بعدي يه متغير از نوع PROCESSENTRY32 هستش كه تابع اطلاعات مورد نظر رو توي اين قرار ميده:

CONST MAX_PATH = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type

توي اين szExeFile ٬Type اسم فايل ، th32ProcessID هم همون آيدي مورد نظرمونه.با بقيش هم همونطور كه گفتم كاري نداريم.
(آرگومان هاي تابع Process3Next هم طبعا مثل Process32First هستش.)
بعد با يك حلقه تا زماني كه مقدار برگشتي تابع Process32Next صفر نباشه به فراخواني اين تابع ادامه ميديم و توي هر بار فراخواني اطلاعات يكي از Process ها رو بدست مياريم.(وقتي كه تابع صفر برگردونه يعني به انتهاي ليست رسيديم)
بعد از بدست آوردن اطلاعات مورد نظر بايد هندلي كه با تابع CreateToolhelp32Snapshot بدست آورديم رو ببنديم :

Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long

خوب ميريم سراغ كد :

Private Const MAX_PATH = 260
Private Const TH32CS_SNAPPROCESS = &H2

Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long

Private Sub Command1_Click()
Dim hSnap As Long, pResult As Long, Process As PROCESSENTRY32
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
Process.dwSize = Len(Process)
pResult = Process32First(hSnap, Process)
Do While pResult <> 0
List1.AddItem Left$(Process.szExeFile, InStr(1, Process.szExeFile, Chr(0)) - 1) & " : " & Process.th32ProcessID
pResult = Process32Next(hSnap, Process)
Loop
CloseHandle hSnap
End Sub

همه چيزه اين كد رو به غير از 2 چيز كوچيك توضيح دادم.يكي ايكنه براي اينكه ميخواهيم متغير Process كه از نوع PROCESSENTRY32 هستش رو به تابع ارسال كنيم بايد طولش رو توي عضو .dwSize اون قرار بديم.(اين موضوع فقط مال اين تابع و اين نوع نيست...)
بعدي اينكه از نام فايل اون مقدار مورد نظر رو كه ميخواهيم جدا كنيم و كاراكتر هاي (0) رو از اسم فايل جدا كنيم از Left و Instr استفاده كرديم .مثل كاري كه توي پست قبلي توضيح دادم.(قبلا از Replace استفاده ميكردم اما تابلوه كه اين روش سرعتش بيشتره)

خوب تا اينجا فعلا ليست اسم ها و آيدي Process ها رو بدست آورديم.با اين روش و با تابعي كه ميگم ميتونيم برنامه اي اسم فايل اجراييش رو داشته باشيم ببنديم.اما چون ممكنه فايل اجرايي 2 تا برنامه ي جدا 1 اسم داشته باشن ميتونه مشكل پيش بياد و بهتره با استفاده از مسير فايل ها كارمون رو انجام بديم كه هنوز روش بدست آوردن مسير رو نگفتم.
الان روش بستن Process به همين روش رو توضيح ميدم بعد ميرم سراغ بدست آوردن مسير...

همونطور كه اول گفتم بايد با OpenProcess يه هندل از Process ايجاد كنيم :

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

آرگومان اول نوع دسترسي هستش كه ما PROCESS_ALL_ACCESS = &H1F0FFF (همه ي دسترسي ها) رو ميگذاريم و خيال خودمون رو راحت ميكنيم.

آرگومان بعدي رو هم True بگذارين(تاثيري تو كار ما نداره).بعد هم همون آيديه Process هستش . حالا بايد مقدار برگشتي رو به تابع TerminateProcess بديم :

Private Declare Function TerminateProcess Lib "kernel32" Alias "TerminateProcess" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

آرگومان اول همون هندله.دومي رو هم 0 قرار بدين.
حالا ميخواهيم يه برنامه بنوسيم كه هرچي برنامه ي NotePad كه در حال اجراس رو ببنده.(يا هر فايلي كه اسمش notepad.exe باشه ) :

Private Const MAX_PATH = 260
Private Const TH32CS_SNAPPROCESS = &H2
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, Uprocess As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Sub Command1_Click()
Dim hSnap As Long, pResult As Long, Process As PROCESSENTRY32
Dim AppName As String, pID As Long, hProcess As Long

hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
Process.dwSize = Len(Process)
pResult = Process32First(hSnap, Process)
Do While pResult <> 0
AppName = Left$(Process.szExeFile, InStr(1, Process.szExeFile, Chr(0)) – 1)
If StrComp(AppName, "notepad.exe", vbTextCompare) = 0 Then 'file name = notepad.exe ?
pID = Process.th32ProcessID
hProcess = OpenProcess(PROCESS_ALL_ACCESS, True, pID)
TerminateProcess hProcess, 0
CloseHandle hProcess
End If
pResult = Process32Next(hSnap, Process)

Loop
CloseHandle hSnap
End Sub

در ضمن بعد از اينكه Process رو بستيم هندل رو هم با CloseHandle ميبنديم.

خوب حالا مياييم سراغ بدست آوردن آدرس كامل فايل هاي در حال اجرا.
اگه يادتون باشه واسه بدست آوردن يك ليست از كل Process ها وقتي از تابع CreateToolhelp32Snapshot استفاده كرديم آرگومان اول رو TH32CS_SNAPPROCESS قرار داديم و چون با Process خاصي كار نداشتيم آرگومان دوم رو 0 گذاشتيم.براي اينكه بتونيم اطلاعات ديگه اي از Process ها مانند اطلاعاتModule هايي(dll ها ocx ها و ...) كه Process داره ازشون استفاده ميكنه (و مسير كامل فايل كه اين هم خودش آدرس يكي از همون Module هاست) رو بدست بياريم بايد روي يك Process تمركز كنيم و مثل دفعه قبل نيست كه با يك حلقه اطلاعاتي رو در مورد همه ي Process ها بدست بياريم.براي اين كار بعد از بدست آوردن آيدي هر Process ،آرگومان اول تابع رو Private Const TH32CS_SNAPMODULE = &H8 قرار ميديم و آرگومان دوم رو هم آيدي اون رو.
حالا به جاي استفاده از Process32First و Process32Next از Module32First و Module32Next استفاده ميكنيم:

Private Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long
Private Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long

آرگومان اول كه ميدونين چيه.دومي يه متغير از نوع MODULEENTRY32 هستش كه اطلاعات Module ها توش قرار ميگيره:

Private Const MAX_PATH = 260
Private Type MODULEENTRY32
dwSize As Long
th32ModuleID As Long
th32ProcessID As Long
GlblcntUsage As Long
ProccntUsage As Long
modBaseAddr As Long
modBaseSize As Long
hModule As Long
szModule As String * 256
szExePath As String * MAX_PATH
End Type

اوني كه ما باش كار داريم szExePath هستش كه مسير اون Module هستش چون فايلي كه ما ميخواهيم آدرسش رو بدست بياريم هم يكي از همين Module هاست(اولين Module كه توسط تابع Module32First برگردونه ميشه) بنابر اين آدرس همون آدرسيه كه ما دنبالشيم.البته szModule هم فقط اسم Module هستش(بدون مسير)

چون ما اينجا فقط ميخوايم آدرس اولين Module كه همون آدرس فايل Exe هستش رو بدست بياريم و با بقيه Module ها كاري نداريم ديگه واسه Module ها از حلقه استفاده نميكنيم.شما اگه خواستين اين كار رو بكنين فرم كار مثل كد قبيليه كه گذشتم.
كد ما براي بدست آوردن آدرس همه ي فايل هاي در حال اجرا اينطوري ميشه :


Option Explicit
Private Const MAX_PATH = 260
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPMODULE = &H8
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Type MODULEENTRY32
dwSize As Long
th32ModuleID As Long
th32ProcessID As Long
GlblcntUsage As Long
ProccntUsage As Long
modBaseAddr As Long
modBaseSize As Long
hModule As Long
szModule As String * 256
szExePath As String * 260
End Type
Private Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long
Private Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Sub Command1_Click()
'Process :
Dim hSnap As Long, pResult As Long, Process As PROCESSENTRY32
Dim pID As Long
'Module :
Dim hSnapM As Long, Module As MODULEENTRY32
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0(
Process.dwSize = Len(Process(
pResult = Process32First(hSnap, Process)
Do While pResult <> 0
pID = Process.th32ProcessID
'
hSnapM = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, pID)
Module.dwSize = Len(Module)
Call Module32First(hSnapM, Module)
List1.AddItem Left$(Module.szExePath, InStr(1, Module.szExePath, Chr(0)) – 1)
CloseHandle hSnapM
'
pResult = Process32Next(hSnap, Process)

Loop
CloseHandle hSnap
End Sub

البته با اين روش به دليلي كه نميدونم آدرس كامل يكسري از فايل ها كه تا اونجايي كه چك كردم Process اون ها از نوع System بود و آدرسون هم توي دايركتوريه سيستم(مثل svchost.exe) رو تابع برنميگردونه و فقط اسم اون ها رو برميگردونه!
بگذريم.حالا ميخواهيم برنامه اي كه قبل از اين نوشتيم رو با روش جديدي كه گفتم بنويسيم.يعني بجاي اينكه همه ي فايل هايي كه در حال اجرا هستن و اسمشون notepad.exe هستش رو ببنديم همه ي اونهايي كه آدرسشون c:\windows\systtem32\notepad.exe هست رو ببنديم.كدمون چيز جديدي نداره :

Option Explicit
Private Const MAX_PATH = 260
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPMODULE = &H8
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Type MODULEENTRY32
dwSize As Long
th32ModuleID As Long
th32ProcessID As Long
GlblcntUsage As Long
ProccntUsage As Long
modBaseAddr As Long
modBaseSize As Long
hModule As Long
szModule As String * 256
szExePath As String * 260
End Type
Private Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long
Private Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, uProcess As MODULEENTRY32) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function Process32First Lib "kernel32.dll" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32.dll" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Sub Command1_Click()
'Process :
Dim hSnap As Long, pResult As Long, Process As PROCESSENTRY32
Dim pID As Long, hProcess As Long, appPath As String
'Module :
Dim hSnapM As Long, Module As MODULEENTRY32
hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
Process.dwSize = Len(Process)
pResult = Process32First(hSnap, Process)
Do While pResult <> 0
pID = Process.th32ProcessID
'
hSnapM = CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, pID)
Module.dwSize = Len(Modul(
Call Module32First(hSnapM, Module)
appPath = Left$(Module.szExePath, InStr(1, Module.szExePath, Chr(0)) – 1)
If StrComp(appPath, "c:\windows\system32\notepad.exe", vbTextCompare) = 0 Then 'file name = notepad.exe
pID = Module.th32ProcessID
hProcess = OpenProcess(PROCESS_ALL_ACCESS, True, pID)
TerminateProcess hProcess, 0
CloseHandle hProcess
End If

CloseHandle hSnapM
'
pResult = Process32Next(hSnap, Process)

Loop
CloseHandle hSnap
End Sub

براي تست برنامه فايل notepad.exe رو يكبار از پوشه ي سيستم يبار هم از پوشه ي ويندوز باز كنين.برنامه رو اجرا كنين ميبينين فقط اوني كه توي پوشه ي سيستم هستش بسته ميشه.
اينهايي كه تاحالا گفتم در مورد روش اول بدست آوردن ProcessID بود.راه ديگش همونطور كه اول كار اشاره كردم استفاده از هندل يكي از پنجره هاي برنامه هستش.با اين روش مثلا ميتونين برنامه اي كه موس روش هست رو ببندين.واسه اين كار از تابع GetWindowThreadProcessId استفاده ميكنيم تا آيديه Process رو بدست بياريم :

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

آرگومان اول هندل مورد نظر هست.دومي هم يك متغير از نوع Long كه تابع آيديه Process رو توش قرار ميده .(مقدار برگشتي هم آيديه Thread هستش كه كاري باش نداريم)
بعد از بدست آوردن آيديه Process رو بدست آورديم مثل قبل عمل ميكنيم و برنامه مورد نظر رو ميبنديم.
ميخواهيم برنامه اي بنوسيم كه وقتي روي يك دكمه فشار داده ميشه برنامه اي كه موس روشه بسته بشه.واسه اين كار با تابع هاي GetCursorPos و WindowFromPoint كه قبلا در موردشون گفتم(به آرشيو مراجعه كنين) هندل پنجره اي كه موس روشه رو بدست مياريم و با روشي كه گفتم ميبنديمش :

Option Explicit
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Sub Command1_Click()
Dim wHandle As Long, PAPI As POINTAPI, pID As Long, hProcess As Long
GetCursorPos PAPI
wHandle = WindowFromPoint(PAPI.x, PAPI.y)
GetWindowThreadProcessId wHandle, pID
hProcess = OpenProcess(PROCESS_ALL_ACCESS, True, pID)
TerminateProcess hProcess, 0
CloseHandle hProcess
End Sub

توي اين كد چون بايد موس روي برنامه اي باشه كه بايد بسته بشه با خود موس نميتونين روي دكمه كليك كنين چون برنامه ي خودتون بسته ميشه!!! Focus رو بهش بدين و با Enter كردن اونو فشار بدين!!!!! :پي

توي اين پست روش هايي واسه بستن Processبرنامه ها رو گفتم.هدف من از گفتن اين مطلب ها فقط راه بستن Process نبود..با بدست آوردن ProcessID كارهاي زيادي در مورد Process ها و Thread ها و .. ميشه كرد كه اينجا 2 تا روش براي اين كار گفتم


*****************************
اموزش برنامه نویسی یک Consol توسط API

ميخوام در مورد درست كردن يه برنامه Console توي ويژوال بيسيك با API توضيح بدم(البته خيلي مختصر).خود ويبي امكان درست كردن Console Application رو نداره.

درسته كه برنامه هاي Console ي كه توي Windows32 درست ميكنيم ظاهرا خيلي فرقي با برنامه هاي تحت داس ندارن اما در محيط داس قابل اجرا نيستن و فقط توي محيط ويندوز ميشه ازشون استفاده كرد.

كارهايي كه كلا بايد انجام بديم اينه كه اول يه instance از پنجره ي كنسول درست كنيم و قسمتي از حافظه رو به كنسول مورد نظرمون اختصاص بديم...يه هندل واسه نوشتن،يه هندل واسه خواندن و يه هندل براي دستگيري خطا درست كنيم و عمل خواندن و نوشتن رو توي كنسول انجام بديم.وقتي اعمال خواندن و نوشتن اطلاعات (تبادل اطلاعات متني بين برنامه و كاربر كه تنها كاريه كه يه كنسول ميتونه بكنه!) تموم شد طبيعتا برنامه كنسول ما بايد تموم بشه پس اون رو ميبنديم و حافظه اي كه بش اختصاص داده شده رو آزاد ميكنيم.

پس براي اولين مرحله تابع AllocConsole رو فراخواني ميكنيم :

Private Declare Function AllocConsole Lib "kernel32" Alias "AllocConsole" () As Long

كه آرگوماني هم نداره.
آخرين مرحله هم آزاد كردن كنسول هست كه از تابع FreeConsole استفاده ميشه :

Private Declare Function FreeConsole Lib "kernel32" Alias "FreeConsole" () As Long

حالا براي مثال ما فقط ميخواهيم با لود شدن فرم يك كنسول رو نشون بديم و با كليك كردن روي دكمه اون رو ببنديم قبل از اينکه اين کد رو توی پروژتون وارد کنين بخاطر مشکلاتی که ممکنه پيش بياد و ويژوال بيسيک ناگهانی بسته بشه(اند ضدحال) و هنگ کنه و اينا اگه به جای اينکه واسه اجرای برنامه از ديباگ استفاده کنين ٬ فايل Exe درست کنين و اونو اجرا کنين بهتره:

Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function AllocConsole Lib "kernel32" () As Long

Private Sub Command1_Click()
FreeConsole
End Sub

Private Sub Form_Load()
AllocConsole
End Sub

خوب اين كنسول ما هيچ كاري انجام نميده.ميريم سراغ عمل نوشتن و خواندن.
همونطور كه گفتم براي خواندن بايد يه هندل ايجاد كنيم.براي اين كار از تابع GetSTDHandle استفاده ميشه:

Private Declare Function GetStdHandle Lib "kernel32" Alias "GetStdHandle" (ByVal nStdHandle As Long) As Long

اين تابع 1 آرگومان ميگيره كه يكي از اين ها ميتونه باشه :

STD_ERROR_HANDLE دستگيره براي خطا
STD_INPUT_HANDLE دستگيره براي خواندن
STD_OUTPUT_HANDLE دستگيره براي نوشتن

بعد از ايجاد هندل براي نوشتن توي كنسول از تابع WriteConsole استفاده ميشه:

Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long

آرگومان اول همون هندل براي نوشتنه.دومي متني كه ميخواهيم چاپ بشه.بعدي تعداد كاراكتريه كه ميخواهيم چاپ بشه كه ما به طور پيشفرض طول متني كه ميخواهيم چاپ بشه رو ميگذاريم.2 تا آرگومان بعدي رو هم vbNull قرار بدين.

حالا همون برنامه ي قبلي رو طوري تغيير ميديم كه وقتي پنجره ي كنسول نشون داده شد يك متن چاپ بشه :

Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Const STD_ERROR_HANDLE = -12&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&

Dim whandle As Long
Private Sub Command1_Click()
FreeConsole
End Sub

Private Sub Form_Load()
AllocConsole
whandle = GetStdHandle(STD_OUTPUT_HANDLE)
SendOutPut "This is a w32 console application!"
End Sub
Sub SendOutPut(strOutPut As String)
WriteConsole whandle, ByVal strOutPut, Len(strOutPut), vbNull, vbNull
End Sub

توي اين كد من براي نوشتن يه تابع جدا درست كردم.در ضمن به چگونگي ارسال متن به تابع توجه كنين.

حالا ميريم سراغ خوندن.اول با همون تابع GetSTDHandle و دادن آرگومان STD_INPUT_HANDLEيه هندل واسه خواندن درست ميكنيم.بعد با تابع ReadConsole يه متن رو ميخونيم:

Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long

آرگومان اول هندل ايجاد شدس.دومي يه متغير هستش كه متن خونده شده توش قرار ميگيره.سومي حداكثر تعداد كاراكتريه كه ميخواهيم خونده بشه و طبيعتا از طول متغيري كه به عنوان آرگومان دوم به تابع داديم نبايد بيشتر باشه.2 تاي ديگه رو هم vbNull بزارين.

حالا برنامه رو طوري تغيير ميديم كه توي اون پنجره ي كنسول يه متن رو بخونه.بعد از خوندن متن يه پيغام كه حاوي متن هستش نشون داده بشه:

Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Const STD_ERROR_HANDLE = -12&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&

Dim whandle As Long
Dim rhandle As Long
Dim Result As String
Private Sub Form_Load()
AllocConsole
whandle = GetStdHandle(STD_OUTPUT_HANDLE(
rhandle = GetStdHandle(STD_INPUT_HANDLE(
SendOutPut "This is a w32 console application! , Enter a text :" & vbCrLf
Result = GetinPut
MsgBox Result,vbSystemModal
FreeConsole
End Sub
Sub SendOutPut(strOutPut As String(
WriteConsole whandle, ByVal strOutPut, Len(strOutPut), vbNull, vbNull
End Sub
Function GetinPut() As String
Dim strInput As String * 256
ReadConsole rhandle, ByVal strInput, Len(strInput), vbNull, vbNull
GetinPut = Left(strInput, InStr(strInput,Chr(0)) - 3)
End Function

چون ما نميدونيم مقداري كه كاربر وارد ميكنه طولش چقدره يه مقدار پيشفرض در نظر ميگيريم(اينجا 256) كه اين مقدار رو به دلخواه ميتونيم تغيير بديم.
باز هم به چگونگي ارسال متغير -ي كه متن توش قرار ميگيره- كه به تابع ارسال ميشه توجه كنين.
البته متني كه خونده ميشه كاراكتر هاي اضافه داره.همونطور كه گفتم چون ما طول رشته اي كه كاربر ميخواد وارد كنه رو نميدونيم يه طول پيشفرض در نظر گرفتيم و رشته رو از يه كاراكتر خاص پر كرديم مثلا از كاراكتر نال (كد اسكي 0) .علاوه بر اين كاراكتر ها 2 تا كاراكتر اضافه ي ديگه هم به آخر وردوي اضافه ميشن.يكي كاراكتر با كد اسكي 13 و بعدي 10 (همون Newline و Return و يا vbCrLf) مثلا اگه اول كار رشته اي كه به تابع داديم مقدارش توي حافظه اين بوده :

00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00

و وروديه كاربر متن API بوده باشه رشته بعد از خوندن ميشه:

65 80 73 13 10 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00

كه ما با يه Left و ۳InStr تا كاراكتر اول رو جدا ميكنيم.

حالا با تركيب عمل خوندن و نوشتن يه برنامه مينويسيم كه يكي از سه مقدار C B A رو بگيره و در مقابل مقدار گرفته شده به ترتيب زمان ، تاريخ و يا هر دو رو چاپ كنه.اگه مقدار وارد شده چيزه ديگه اي بود، برنامه بسته بشه.
در ضمن اينجا ديگه از فرم استفاده نميكنيم چون ميخواهيم برنامه مثل يه Console واقعي بشه.پس فرم رو حذف كنيد و يه Module به پروژه اضافه كنين و كد زير رو توي Module وارد كنين :

Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Const STD_ERROR_HANDLE = -12&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&

Dim whandle As Long
Dim rhandle As Long
Dim Result As String
Private Sub Main()
AllocConsole
whandle = GetStdHandle(STD_OUTPUT_HANDLE)
rhandle = GetStdHandle(STD_INPUT_HANDLE)
SendOutPut "Press one of the following keys,any other key to exit :" & vbCrLf & _
"A to get time" & vbCrLf & _
"B to get date" & vbCrLf & _
"C to get both" & vbCrLf
While True
Result = UCase(GetinPut)
Select Case Result
Case "A"
SendOutPut "Time is " & CStr(Time) & vbCrLf
Case "B"
SendOutPut "Date is " & CStr(Date) & vbCrLf
Case "C"
SendOutPut "Now is " & CStr(Now) & vbCrLf
Case Else
FreeConsole
End
End Select
Wend
End Sub
Sub SendOutPut(strOutPut As String)
WriteConsole whandle, ByVal strOutPut, Len(strOutPut), vbNull, vbNull
End Sub
Function GetinPut() As String
Dim strInput As String * 256
ReadConsole rhandle, ByVal strInput, Len(strInput), vbNull, vbNull
GetinPut = Left(strInput, InStr(strInput, Chr(0)) - 3)
End Function

خوب! اينم از اين مبحث.البته توابع مختلفي واسه كار با Console ها هست مثلا واسه رنگي نوشتن و ...